+2017-09-11 Jerome Lambourg <lambourg@adacore.com>
+
+ * libgnarl: Rename ?-[a-z]*-* into ?-[a-z]*__*
+ * gcc-interface/Makefile.in: Take this renaming into account.
+
+2017-09-11 Arnaud Charlet <charlet@adacore.com>
+
+ * s-auxdec-empty.ads, s-auxdec-empty.adb, 9drpc.adb: Removed, no
+ longer used.
+
2017-09-11 Yannick Moy <moy@adacore.com>
* sem_util.adb (Check_Result_And_Post_State):
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . E X E C U T I O N _ T I M E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2007-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Darwin version of this package
-
-with Ada.Task_Identification; use Ada.Task_Identification;
-with Ada.Unchecked_Conversion;
-
-with System.Tasking;
-with System.OS_Interface; use System.OS_Interface;
-with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
-
-with Interfaces.C; use Interfaces.C;
-
-package body Ada.Execution_Time is
-
- ---------
- -- "+" --
- ---------
-
- function "+"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Ada.Real_Time.Time (Left) + Right);
- end "+";
-
- function "+"
- (Left : Ada.Real_Time.Time_Span;
- Right : CPU_Time) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Left + Ada.Real_Time.Time (Right));
- end "+";
-
- ---------
- -- "-" --
- ---------
-
- function "-"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Ada.Real_Time.Time (Left) - Right);
- end "-";
-
- function "-"
- (Left : CPU_Time;
- Right : CPU_Time) return Ada.Real_Time.Time_Span
- is
- use type Ada.Real_Time.Time;
- begin
- return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
- end "-";
-
- -----------
- -- Clock --
- -----------
-
- function Clock
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task) return CPU_Time
- is
- function Convert_Ids is new
- Ada.Unchecked_Conversion (Task_Id, System.Tasking.Task_Id);
-
- function To_CPU_Time is
- new Ada.Unchecked_Conversion (Duration, CPU_Time);
- -- Time is equal to Duration (although it is a private type) and
- -- CPU_Time is equal to Time.
-
- subtype integer_t is Interfaces.C.int;
- subtype mach_port_t is integer_t;
- -- Type definition for Mach.
-
- type time_value_t is record
- seconds : integer_t;
- microseconds : integer_t;
- end record;
- pragma Convention (C, time_value_t);
- -- Mach time_value_t
-
- type thread_basic_info_t is record
- user_time : time_value_t;
- system_time : time_value_t;
- cpu_usage : integer_t;
- policy : integer_t;
- run_state : integer_t;
- flags : integer_t;
- suspend_count : integer_t;
- sleep_time : integer_t;
- end record;
- pragma Convention (C, thread_basic_info_t);
- -- Mach structure from thread_info.h
-
- THREAD_BASIC_INFO : constant := 3;
- THREAD_BASIC_INFO_COUNT : constant := 10;
- -- Flavors for basic info
-
- function thread_info (Target : mach_port_t;
- Flavor : integer_t;
- Thread_Info : System.Address;
- Count : System.Address) return integer_t;
- pragma Import (C, thread_info);
- -- Mach call to get info on a thread
-
- function pthread_mach_thread_np (Thread : pthread_t) return mach_port_t;
- pragma Import (C, pthread_mach_thread_np);
- -- Get Mach thread from posix thread
-
- Result : Interfaces.C.int;
- Thread : pthread_t;
- Port : mach_port_t;
- Ti : thread_basic_info_t;
- Count : integer_t;
- begin
- if T = Ada.Task_Identification.Null_Task_Id then
- raise Program_Error;
- end if;
-
- Thread := Get_Thread_Id (Convert_Ids (T));
- Port := pthread_mach_thread_np (Thread);
- pragma Assert (Port > 0);
-
- Count := THREAD_BASIC_INFO_COUNT;
- Result := thread_info (Port, THREAD_BASIC_INFO,
- Ti'Address, Count'Address);
- pragma Assert (Result = 0);
- pragma Assert (Count = THREAD_BASIC_INFO_COUNT);
-
- return To_CPU_Time
- (Duration (Ti.user_time.seconds + Ti.system_time.seconds)
- + Duration (Ti.user_time.microseconds
- + Ti.system_time.microseconds) / 1E6);
- end Clock;
-
- --------------------------
- -- Clock_For_Interrupts --
- --------------------------
-
- function Clock_For_Interrupts return CPU_Time is
- begin
- -- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
- -- is set to False the function raises Program_Error.
-
- raise Program_Error;
- return CPU_Time_First;
- end Clock_For_Interrupts;
-
- -----------
- -- Split --
- -----------
-
- procedure Split
- (T : CPU_Time;
- SC : out Ada.Real_Time.Seconds_Count;
- TS : out Ada.Real_Time.Time_Span)
- is
- use type Ada.Real_Time.Time;
- begin
- Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
- end Split;
-
- -------------
- -- Time_Of --
- -------------
-
- function Time_Of
- (SC : Ada.Real_Time.Seconds_Count;
- TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
- return CPU_Time
- is
- begin
- return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
- end Time_Of;
-
-end Ada.Execution_Time;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . E X E C U T I O N _ T I M E --
--- --
--- S p e c --
--- --
--- Copyright (C) 2007-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Task_Identification;
-with Ada.Real_Time;
-
-package Ada.Execution_Time with
- SPARK_Mode
-is
-
- type CPU_Time is private;
-
- CPU_Time_First : constant CPU_Time;
- CPU_Time_Last : constant CPU_Time;
- CPU_Time_Unit : constant := Ada.Real_Time.Time_Unit;
- CPU_Tick : constant Ada.Real_Time.Time_Span;
-
- use type Ada.Task_Identification.Task_Id;
-
- function Clock
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task)
- return CPU_Time
- with
- Volatile_Function,
- Global => Ada.Real_Time.Clock_Time,
- Pre => T /= Ada.Task_Identification.Null_Task_Id;
-
- function "+"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- with
- Global => null;
-
- function "+"
- (Left : Ada.Real_Time.Time_Span;
- Right : CPU_Time) return CPU_Time
- with
- Global => null;
-
- function "-"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- with
- Global => null;
-
- function "-"
- (Left : CPU_Time;
- Right : CPU_Time) return Ada.Real_Time.Time_Span
- with
- Global => null;
-
- function "<" (Left, Right : CPU_Time) return Boolean with
- Global => null;
- function "<=" (Left, Right : CPU_Time) return Boolean with
- Global => null;
- function ">" (Left, Right : CPU_Time) return Boolean with
- Global => null;
- function ">=" (Left, Right : CPU_Time) return Boolean with
- Global => null;
-
- procedure Split
- (T : CPU_Time;
- SC : out Ada.Real_Time.Seconds_Count;
- TS : out Ada.Real_Time.Time_Span)
- with
- Global => null;
-
- function Time_Of
- (SC : Ada.Real_Time.Seconds_Count;
- TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
- return CPU_Time
- with
- Global => null;
-
- Interrupt_Clocks_Supported : constant Boolean := False;
- Separate_Interrupt_Clocks_Supported : constant Boolean := False;
-
- pragma Warnings (Off, "check will fail at run time");
- function Clock_For_Interrupts return CPU_Time with
- Volatile_Function,
- Global => Ada.Real_Time.Clock_Time,
- Pre => Interrupt_Clocks_Supported;
- pragma Warnings (On, "check will fail at run time");
-
-private
- pragma SPARK_Mode (Off);
-
- type CPU_Time is new Ada.Real_Time.Time;
-
- CPU_Time_First : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_First);
- CPU_Time_Last : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_Last);
-
- CPU_Tick : constant Ada.Real_Time.Time_Span := Ada.Real_Time.Tick;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
-
-end Ada.Execution_Time;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . E X E C U T I O N _ T I M E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2007-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Windows native version of this package
-
-with Ada.Task_Identification; use Ada.Task_Identification;
-with Ada.Unchecked_Conversion;
-
-with System.OS_Interface; use System.OS_Interface;
-with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
-with System.Tasking; use System.Tasking;
-with System.Win32; use System.Win32;
-
-package body Ada.Execution_Time with
- SPARK_Mode => Off
-is
-
- ---------
- -- "+" --
- ---------
-
- function "+"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Ada.Real_Time.Time (Left) + Right);
- end "+";
-
- function "+"
- (Left : Ada.Real_Time.Time_Span;
- Right : CPU_Time) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Left + Ada.Real_Time.Time (Right));
- end "+";
-
- ---------
- -- "-" --
- ---------
-
- function "-"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Ada.Real_Time.Time (Left) - Right);
- end "-";
-
- function "-"
- (Left : CPU_Time;
- Right : CPU_Time) return Ada.Real_Time.Time_Span
- is
- use type Ada.Real_Time.Time;
- begin
- return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
- end "-";
-
- -----------
- -- Clock --
- -----------
-
- function Clock
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task) return CPU_Time
- is
- Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7;
-
- function To_Time is new Ada.Unchecked_Conversion
- (Duration, Ada.Real_Time.Time);
-
- function To_Task_Id is new Ada.Unchecked_Conversion
- (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id);
-
- C_Time : aliased Long_Long_Integer;
- E_Time : aliased Long_Long_Integer;
- K_Time : aliased Long_Long_Integer;
- U_Time : aliased Long_Long_Integer;
- Res : BOOL;
-
- begin
- if T = Ada.Task_Identification.Null_Task_Id then
- raise Program_Error;
- end if;
-
- Res :=
- GetThreadTimes
- (HANDLE (Get_Thread_Id (To_Task_Id (T))),
- C_Time'Access, E_Time'Access, K_Time'Access, U_Time'Access);
-
- if Res = System.Win32.FALSE then
- raise Program_Error;
- end if;
-
- return
- CPU_Time
- (To_Time
- (Duration
- ((Long_Long_Float (K_Time) / Hundreds_Nano_In_Sec)
- + (Long_Long_Float (U_Time) / Hundreds_Nano_In_Sec))));
- end Clock;
-
- --------------------------
- -- Clock_For_Interrupts --
- --------------------------
-
- function Clock_For_Interrupts return CPU_Time is
- begin
- -- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
- -- is set to False the function raises Program_Error.
-
- raise Program_Error;
- return CPU_Time_First;
- end Clock_For_Interrupts;
-
- -----------
- -- Split --
- -----------
-
- procedure Split
- (T : CPU_Time;
- SC : out Ada.Real_Time.Seconds_Count;
- TS : out Ada.Real_Time.Time_Span)
- is
- use type Ada.Real_Time.Time;
- begin
- Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
- end Split;
-
- -------------
- -- Time_Of --
- -------------
-
- function Time_Of
- (SC : Ada.Real_Time.Seconds_Count;
- TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
- return CPU_Time
- is
- begin
- return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
- end Time_Of;
-
-end Ada.Execution_Time;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . E X E C U T I O N _ T I M E --
--- --
--- S p e c --
--- --
--- Copyright (C) 2009-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Windows native version of this package
-
-with Ada.Task_Identification;
-with Ada.Real_Time;
-
-package Ada.Execution_Time with
- SPARK_Mode
-is
- type CPU_Time is private;
-
- CPU_Time_First : constant CPU_Time;
- CPU_Time_Last : constant CPU_Time;
- CPU_Time_Unit : constant := 0.000001;
- CPU_Tick : constant Ada.Real_Time.Time_Span;
-
- use type Ada.Task_Identification.Task_Id;
-
- function Clock
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task)
- return CPU_Time
- with
- Volatile_Function,
- Global => Ada.Real_Time.Clock_Time,
- Pre => T /= Ada.Task_Identification.Null_Task_Id;
-
- function "+"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- with
- Global => null;
-
- function "+"
- (Left : Ada.Real_Time.Time_Span;
- Right : CPU_Time) return CPU_Time
- with
- Global => null;
-
- function "-"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- with
- Global => null;
-
- function "-"
- (Left : CPU_Time;
- Right : CPU_Time) return Ada.Real_Time.Time_Span
- with
- Global => null;
-
- function "<" (Left, Right : CPU_Time) return Boolean with
- Global => null;
- function "<=" (Left, Right : CPU_Time) return Boolean with
- Global => null;
- function ">" (Left, Right : CPU_Time) return Boolean with
- Global => null;
- function ">=" (Left, Right : CPU_Time) return Boolean with
- Global => null;
-
- procedure Split
- (T : CPU_Time;
- SC : out Ada.Real_Time.Seconds_Count;
- TS : out Ada.Real_Time.Time_Span)
- with
- Global => null;
-
- function Time_Of
- (SC : Ada.Real_Time.Seconds_Count;
- TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
- return CPU_Time
- with
- Global => null;
-
- Interrupt_Clocks_Supported : constant Boolean := False;
- Separate_Interrupt_Clocks_Supported : constant Boolean := False;
-
- pragma Warnings (Off, "check will fail at run time");
- function Clock_For_Interrupts return CPU_Time with
- Volatile_Function,
- Global => Ada.Real_Time.Clock_Time,
- Pre => Interrupt_Clocks_Supported;
- pragma Warnings (On, "check will fail at run time");
-
-private
- pragma SPARK_Mode (Off);
-
- type CPU_Time is new Ada.Real_Time.Time;
-
- CPU_Time_First : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_First);
- CPU_Time_Last : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_Last);
-
- CPU_Tick : constant Ada.Real_Time.Time_Span := Ada.Real_Time.Tick;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
-
-end Ada.Execution_Time;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . E X E C U T I O N _ T I M E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2007-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the POSIX (Realtime Extension) version of this package
-
-with Ada.Task_Identification; use Ada.Task_Identification;
-with Ada.Unchecked_Conversion;
-
-with System.Tasking;
-with System.OS_Interface; use System.OS_Interface;
-with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
-
-with Interfaces.C; use Interfaces.C;
-
-package body Ada.Execution_Time is
-
- pragma Linker_Options ("-lrt");
- -- POSIX.1b Realtime Extensions library. Needed to have access to function
- -- clock_gettime.
-
- ---------
- -- "+" --
- ---------
-
- function "+"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Ada.Real_Time.Time (Left) + Right);
- end "+";
-
- function "+"
- (Left : Ada.Real_Time.Time_Span;
- Right : CPU_Time) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Left + Ada.Real_Time.Time (Right));
- end "+";
-
- ---------
- -- "-" --
- ---------
-
- function "-"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Ada.Real_Time.Time (Left) - Right);
- end "-";
-
- function "-"
- (Left : CPU_Time;
- Right : CPU_Time) return Ada.Real_Time.Time_Span
- is
- use type Ada.Real_Time.Time;
- begin
- return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
- end "-";
-
- -----------
- -- Clock --
- -----------
-
- function Clock
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task) return CPU_Time
- is
- TS : aliased timespec;
- Clock_Id : aliased Interfaces.C.int;
- Result : Interfaces.C.int;
-
- function To_CPU_Time is
- new Ada.Unchecked_Conversion (Duration, CPU_Time);
- -- Time is equal to Duration (although it is a private type) and
- -- CPU_Time is equal to Time.
-
- function Convert_Ids is new
- Ada.Unchecked_Conversion (Task_Id, System.Tasking.Task_Id);
-
- function clock_gettime
- (clock_id : Interfaces.C.int;
- tp : access timespec)
- return int;
- pragma Import (C, clock_gettime, "clock_gettime");
- -- Function from the POSIX.1b Realtime Extensions library
-
- function pthread_getcpuclockid
- (tid : Thread_Id;
- clock_id : access Interfaces.C.int)
- return int;
- pragma Import (C, pthread_getcpuclockid, "pthread_getcpuclockid");
- -- Function from the Thread CPU-Time Clocks option
-
- begin
- if T = Ada.Task_Identification.Null_Task_Id then
- raise Program_Error;
- else
- -- Get the CPU clock for the task passed as parameter
-
- Result := pthread_getcpuclockid
- (Get_Thread_Id (Convert_Ids (T)), Clock_Id'Access);
- pragma Assert (Result = 0);
- end if;
-
- Result := clock_gettime
- (clock_id => Clock_Id, tp => TS'Unchecked_Access);
- pragma Assert (Result = 0);
-
- return To_CPU_Time (To_Duration (TS));
- end Clock;
-
- --------------------------
- -- Clock_For_Interrupts --
- --------------------------
-
- function Clock_For_Interrupts return CPU_Time is
- begin
- -- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
- -- is set to False the function raises Program_Error.
-
- raise Program_Error;
- return CPU_Time_First;
- end Clock_For_Interrupts;
-
- -----------
- -- Split --
- -----------
-
- procedure Split
- (T : CPU_Time;
- SC : out Ada.Real_Time.Seconds_Count;
- TS : out Ada.Real_Time.Time_Span)
- is
-
- begin
- Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
- end Split;
-
- -------------
- -- Time_Of --
- -------------
-
- function Time_Of
- (SC : Ada.Real_Time.Seconds_Count;
- TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
- return CPU_Time
- is
- begin
- return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
- end Time_Of;
-
-end Ada.Execution_Time;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X E C U T I O N _ T I M E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Darwin version of this package
+
+with Ada.Task_Identification; use Ada.Task_Identification;
+with Ada.Unchecked_Conversion;
+
+with System.Tasking;
+with System.OS_Interface; use System.OS_Interface;
+with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
+
+with Interfaces.C; use Interfaces.C;
+
+package body Ada.Execution_Time is
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) + Right);
+ end "+";
+
+ function "+"
+ (Left : Ada.Real_Time.Time_Span;
+ Right : CPU_Time) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Left + Ada.Real_Time.Time (Right));
+ end "+";
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) - Right);
+ end "-";
+
+ function "-"
+ (Left : CPU_Time;
+ Right : CPU_Time) return Ada.Real_Time.Time_Span
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
+ end "-";
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task) return CPU_Time
+ is
+ function Convert_Ids is new
+ Ada.Unchecked_Conversion (Task_Id, System.Tasking.Task_Id);
+
+ function To_CPU_Time is
+ new Ada.Unchecked_Conversion (Duration, CPU_Time);
+ -- Time is equal to Duration (although it is a private type) and
+ -- CPU_Time is equal to Time.
+
+ subtype integer_t is Interfaces.C.int;
+ subtype mach_port_t is integer_t;
+ -- Type definition for Mach.
+
+ type time_value_t is record
+ seconds : integer_t;
+ microseconds : integer_t;
+ end record;
+ pragma Convention (C, time_value_t);
+ -- Mach time_value_t
+
+ type thread_basic_info_t is record
+ user_time : time_value_t;
+ system_time : time_value_t;
+ cpu_usage : integer_t;
+ policy : integer_t;
+ run_state : integer_t;
+ flags : integer_t;
+ suspend_count : integer_t;
+ sleep_time : integer_t;
+ end record;
+ pragma Convention (C, thread_basic_info_t);
+ -- Mach structure from thread_info.h
+
+ THREAD_BASIC_INFO : constant := 3;
+ THREAD_BASIC_INFO_COUNT : constant := 10;
+ -- Flavors for basic info
+
+ function thread_info (Target : mach_port_t;
+ Flavor : integer_t;
+ Thread_Info : System.Address;
+ Count : System.Address) return integer_t;
+ pragma Import (C, thread_info);
+ -- Mach call to get info on a thread
+
+ function pthread_mach_thread_np (Thread : pthread_t) return mach_port_t;
+ pragma Import (C, pthread_mach_thread_np);
+ -- Get Mach thread from posix thread
+
+ Result : Interfaces.C.int;
+ Thread : pthread_t;
+ Port : mach_port_t;
+ Ti : thread_basic_info_t;
+ Count : integer_t;
+ begin
+ if T = Ada.Task_Identification.Null_Task_Id then
+ raise Program_Error;
+ end if;
+
+ Thread := Get_Thread_Id (Convert_Ids (T));
+ Port := pthread_mach_thread_np (Thread);
+ pragma Assert (Port > 0);
+
+ Count := THREAD_BASIC_INFO_COUNT;
+ Result := thread_info (Port, THREAD_BASIC_INFO,
+ Ti'Address, Count'Address);
+ pragma Assert (Result = 0);
+ pragma Assert (Count = THREAD_BASIC_INFO_COUNT);
+
+ return To_CPU_Time
+ (Duration (Ti.user_time.seconds + Ti.system_time.seconds)
+ + Duration (Ti.user_time.microseconds
+ + Ti.system_time.microseconds) / 1E6);
+ end Clock;
+
+ --------------------------
+ -- Clock_For_Interrupts --
+ --------------------------
+
+ function Clock_For_Interrupts return CPU_Time is
+ begin
+ -- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
+ -- is set to False the function raises Program_Error.
+
+ raise Program_Error;
+ return CPU_Time_First;
+ end Clock_For_Interrupts;
+
+ -----------
+ -- Split --
+ -----------
+
+ procedure Split
+ (T : CPU_Time;
+ SC : out Ada.Real_Time.Seconds_Count;
+ TS : out Ada.Real_Time.Time_Span)
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
+ end Split;
+
+ -------------
+ -- Time_Of --
+ -------------
+
+ function Time_Of
+ (SC : Ada.Real_Time.Seconds_Count;
+ TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
+ return CPU_Time
+ is
+ begin
+ return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
+ end Time_Of;
+
+end Ada.Execution_Time;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X E C U T I O N _ T I M E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Task_Identification;
+with Ada.Real_Time;
+
+package Ada.Execution_Time with
+ SPARK_Mode
+is
+
+ type CPU_Time is private;
+
+ CPU_Time_First : constant CPU_Time;
+ CPU_Time_Last : constant CPU_Time;
+ CPU_Time_Unit : constant := Ada.Real_Time.Time_Unit;
+ CPU_Tick : constant Ada.Real_Time.Time_Span;
+
+ use type Ada.Task_Identification.Task_Id;
+
+ function Clock
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task)
+ return CPU_Time
+ with
+ Volatile_Function,
+ Global => Ada.Real_Time.Clock_Time,
+ Pre => T /= Ada.Task_Identification.Null_Task_Id;
+
+ function "+"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ with
+ Global => null;
+
+ function "+"
+ (Left : Ada.Real_Time.Time_Span;
+ Right : CPU_Time) return CPU_Time
+ with
+ Global => null;
+
+ function "-"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ with
+ Global => null;
+
+ function "-"
+ (Left : CPU_Time;
+ Right : CPU_Time) return Ada.Real_Time.Time_Span
+ with
+ Global => null;
+
+ function "<" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+ function "<=" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+ function ">" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+ function ">=" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+
+ procedure Split
+ (T : CPU_Time;
+ SC : out Ada.Real_Time.Seconds_Count;
+ TS : out Ada.Real_Time.Time_Span)
+ with
+ Global => null;
+
+ function Time_Of
+ (SC : Ada.Real_Time.Seconds_Count;
+ TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
+ return CPU_Time
+ with
+ Global => null;
+
+ Interrupt_Clocks_Supported : constant Boolean := False;
+ Separate_Interrupt_Clocks_Supported : constant Boolean := False;
+
+ pragma Warnings (Off, "check will fail at run time");
+ function Clock_For_Interrupts return CPU_Time with
+ Volatile_Function,
+ Global => Ada.Real_Time.Clock_Time,
+ Pre => Interrupt_Clocks_Supported;
+ pragma Warnings (On, "check will fail at run time");
+
+private
+ pragma SPARK_Mode (Off);
+
+ type CPU_Time is new Ada.Real_Time.Time;
+
+ CPU_Time_First : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_First);
+ CPU_Time_Last : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_Last);
+
+ CPU_Tick : constant Ada.Real_Time.Time_Span := Ada.Real_Time.Tick;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+
+end Ada.Execution_Time;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X E C U T I O N _ T I M E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Windows native version of this package
+
+with Ada.Task_Identification; use Ada.Task_Identification;
+with Ada.Unchecked_Conversion;
+
+with System.OS_Interface; use System.OS_Interface;
+with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
+with System.Tasking; use System.Tasking;
+with System.Win32; use System.Win32;
+
+package body Ada.Execution_Time with
+ SPARK_Mode => Off
+is
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) + Right);
+ end "+";
+
+ function "+"
+ (Left : Ada.Real_Time.Time_Span;
+ Right : CPU_Time) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Left + Ada.Real_Time.Time (Right));
+ end "+";
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) - Right);
+ end "-";
+
+ function "-"
+ (Left : CPU_Time;
+ Right : CPU_Time) return Ada.Real_Time.Time_Span
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
+ end "-";
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task) return CPU_Time
+ is
+ Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7;
+
+ function To_Time is new Ada.Unchecked_Conversion
+ (Duration, Ada.Real_Time.Time);
+
+ function To_Task_Id is new Ada.Unchecked_Conversion
+ (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id);
+
+ C_Time : aliased Long_Long_Integer;
+ E_Time : aliased Long_Long_Integer;
+ K_Time : aliased Long_Long_Integer;
+ U_Time : aliased Long_Long_Integer;
+ Res : BOOL;
+
+ begin
+ if T = Ada.Task_Identification.Null_Task_Id then
+ raise Program_Error;
+ end if;
+
+ Res :=
+ GetThreadTimes
+ (HANDLE (Get_Thread_Id (To_Task_Id (T))),
+ C_Time'Access, E_Time'Access, K_Time'Access, U_Time'Access);
+
+ if Res = System.Win32.FALSE then
+ raise Program_Error;
+ end if;
+
+ return
+ CPU_Time
+ (To_Time
+ (Duration
+ ((Long_Long_Float (K_Time) / Hundreds_Nano_In_Sec)
+ + (Long_Long_Float (U_Time) / Hundreds_Nano_In_Sec))));
+ end Clock;
+
+ --------------------------
+ -- Clock_For_Interrupts --
+ --------------------------
+
+ function Clock_For_Interrupts return CPU_Time is
+ begin
+ -- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
+ -- is set to False the function raises Program_Error.
+
+ raise Program_Error;
+ return CPU_Time_First;
+ end Clock_For_Interrupts;
+
+ -----------
+ -- Split --
+ -----------
+
+ procedure Split
+ (T : CPU_Time;
+ SC : out Ada.Real_Time.Seconds_Count;
+ TS : out Ada.Real_Time.Time_Span)
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
+ end Split;
+
+ -------------
+ -- Time_Of --
+ -------------
+
+ function Time_Of
+ (SC : Ada.Real_Time.Seconds_Count;
+ TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
+ return CPU_Time
+ is
+ begin
+ return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
+ end Time_Of;
+
+end Ada.Execution_Time;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X E C U T I O N _ T I M E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2009-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Windows native version of this package
+
+with Ada.Task_Identification;
+with Ada.Real_Time;
+
+package Ada.Execution_Time with
+ SPARK_Mode
+is
+ type CPU_Time is private;
+
+ CPU_Time_First : constant CPU_Time;
+ CPU_Time_Last : constant CPU_Time;
+ CPU_Time_Unit : constant := 0.000001;
+ CPU_Tick : constant Ada.Real_Time.Time_Span;
+
+ use type Ada.Task_Identification.Task_Id;
+
+ function Clock
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task)
+ return CPU_Time
+ with
+ Volatile_Function,
+ Global => Ada.Real_Time.Clock_Time,
+ Pre => T /= Ada.Task_Identification.Null_Task_Id;
+
+ function "+"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ with
+ Global => null;
+
+ function "+"
+ (Left : Ada.Real_Time.Time_Span;
+ Right : CPU_Time) return CPU_Time
+ with
+ Global => null;
+
+ function "-"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ with
+ Global => null;
+
+ function "-"
+ (Left : CPU_Time;
+ Right : CPU_Time) return Ada.Real_Time.Time_Span
+ with
+ Global => null;
+
+ function "<" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+ function "<=" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+ function ">" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+ function ">=" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+
+ procedure Split
+ (T : CPU_Time;
+ SC : out Ada.Real_Time.Seconds_Count;
+ TS : out Ada.Real_Time.Time_Span)
+ with
+ Global => null;
+
+ function Time_Of
+ (SC : Ada.Real_Time.Seconds_Count;
+ TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
+ return CPU_Time
+ with
+ Global => null;
+
+ Interrupt_Clocks_Supported : constant Boolean := False;
+ Separate_Interrupt_Clocks_Supported : constant Boolean := False;
+
+ pragma Warnings (Off, "check will fail at run time");
+ function Clock_For_Interrupts return CPU_Time with
+ Volatile_Function,
+ Global => Ada.Real_Time.Clock_Time,
+ Pre => Interrupt_Clocks_Supported;
+ pragma Warnings (On, "check will fail at run time");
+
+private
+ pragma SPARK_Mode (Off);
+
+ type CPU_Time is new Ada.Real_Time.Time;
+
+ CPU_Time_First : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_First);
+ CPU_Time_Last : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_Last);
+
+ CPU_Tick : constant Ada.Real_Time.Time_Span := Ada.Real_Time.Tick;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+
+end Ada.Execution_Time;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X E C U T I O N _ T I M E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the POSIX (Realtime Extension) version of this package
+
+with Ada.Task_Identification; use Ada.Task_Identification;
+with Ada.Unchecked_Conversion;
+
+with System.Tasking;
+with System.OS_Interface; use System.OS_Interface;
+with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
+
+with Interfaces.C; use Interfaces.C;
+
+package body Ada.Execution_Time is
+
+ pragma Linker_Options ("-lrt");
+ -- POSIX.1b Realtime Extensions library. Needed to have access to function
+ -- clock_gettime.
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) + Right);
+ end "+";
+
+ function "+"
+ (Left : Ada.Real_Time.Time_Span;
+ Right : CPU_Time) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Left + Ada.Real_Time.Time (Right));
+ end "+";
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) - Right);
+ end "-";
+
+ function "-"
+ (Left : CPU_Time;
+ Right : CPU_Time) return Ada.Real_Time.Time_Span
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
+ end "-";
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task) return CPU_Time
+ is
+ TS : aliased timespec;
+ Clock_Id : aliased Interfaces.C.int;
+ Result : Interfaces.C.int;
+
+ function To_CPU_Time is
+ new Ada.Unchecked_Conversion (Duration, CPU_Time);
+ -- Time is equal to Duration (although it is a private type) and
+ -- CPU_Time is equal to Time.
+
+ function Convert_Ids is new
+ Ada.Unchecked_Conversion (Task_Id, System.Tasking.Task_Id);
+
+ function clock_gettime
+ (clock_id : Interfaces.C.int;
+ tp : access timespec)
+ return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+ -- Function from the POSIX.1b Realtime Extensions library
+
+ function pthread_getcpuclockid
+ (tid : Thread_Id;
+ clock_id : access Interfaces.C.int)
+ return int;
+ pragma Import (C, pthread_getcpuclockid, "pthread_getcpuclockid");
+ -- Function from the Thread CPU-Time Clocks option
+
+ begin
+ if T = Ada.Task_Identification.Null_Task_Id then
+ raise Program_Error;
+ else
+ -- Get the CPU clock for the task passed as parameter
+
+ Result := pthread_getcpuclockid
+ (Get_Thread_Id (Convert_Ids (T)), Clock_Id'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := clock_gettime
+ (clock_id => Clock_Id, tp => TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ return To_CPU_Time (To_Duration (TS));
+ end Clock;
+
+ --------------------------
+ -- Clock_For_Interrupts --
+ --------------------------
+
+ function Clock_For_Interrupts return CPU_Time is
+ begin
+ -- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
+ -- is set to False the function raises Program_Error.
+
+ raise Program_Error;
+ return CPU_Time_First;
+ end Clock_For_Interrupts;
+
+ -----------
+ -- Split --
+ -----------
+
+ procedure Split
+ (T : CPU_Time;
+ SC : out Ada.Real_Time.Seconds_Count;
+ TS : out Ada.Real_Time.Time_Span)
+ is
+
+ begin
+ Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
+ end Split;
+
+ -------------
+ -- Time_Of --
+ -------------
+
+ function Time_Of
+ (SC : Ada.Real_Time.Seconds_Count;
+ TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
+ return CPU_Time
+ is
+ begin
+ return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
+ end Time_Of;
+
+end Ada.Execution_Time;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <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 a AIX version of this package
-
--- The following signals are reserved by the run time (native threads):
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGEMT
--- SIGSTOP, SIGKILL
-
--- The following signals are reserved by the run time (FSU threads):
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGALRM,
--- SIGWAITING, SIGSTOP, SIGKILL
-
--- 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
-
- 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
-
- 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
-
- SIGPWR : constant Interrupt_ID :=
- System.OS_Interface.SIGPWR; -- power-fail restart
-
- 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
-
- SIGMSG : constant Interrupt_ID :=
- System.OS_Interface.SIGMSG; -- input data is in the ring buffer
-
- SIGDANGER : constant Interrupt_ID :=
- System.OS_Interface.SIGDANGER; -- system crash imminent;
-
- SIGMIGRATE : constant Interrupt_ID :=
- System.OS_Interface.SIGMIGRATE; -- migrate process
-
- SIGPRE : constant Interrupt_ID :=
- System.OS_Interface.SIGPRE; -- programming exception
-
- SIGVIRT : constant Interrupt_ID :=
- System.OS_Interface.SIGVIRT; -- AIX virtual time alarm
-
- SIGALRM1 : constant Interrupt_ID :=
- System.OS_Interface.SIGALRM1; -- m:n condition variables
-
- SIGWAITING : constant Interrupt_ID :=
- System.OS_Interface.SIGWAITING; -- m:n scheduling
-
- SIGKAP : constant Interrupt_ID :=
- System.OS_Interface.SIGKAP; -- keep alive poll from native keyboard
-
- SIGGRANT : constant Interrupt_ID :=
- System.OS_Interface.SIGGRANT; -- monitor mode granted
-
- SIGRETRACT : constant Interrupt_ID :=
- System.OS_Interface.SIGRETRACT; -- monitor mode should be relinquished
-
- SIGSOUND : constant Interrupt_ID :=
- System.OS_Interface.SIGSOUND; -- sound control has completed
-
- SIGSAK : constant Interrupt_ID :=
- System.OS_Interface.SIGSAK; -- secure attention key
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <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 Darwin version of this package
-
--- The following signals are reserved by the run time:
-
--- SIGSTOP, SIGKILL
-
--- 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
-
- 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
-
- SIGURG : constant Interrupt_ID :=
- System.OS_Interface.SIGURG; -- urgent condition on IO channel
-
- 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
-
- SIGCHLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
-
- SIGTTIN : constant Interrupt_ID :=
- System.OS_Interface.SIGTTIN; -- background tty read attempted
-
- SIGTTOU : constant Interrupt_ID :=
- System.OS_Interface.SIGTTOU; -- background tty write attempted
-
- SIGIO : constant Interrupt_ID := -- input/output possible,
- System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
-
- SIGXCPU : constant Interrupt_ID :=
- System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
-
- SIGXFSZ : constant Interrupt_ID :=
- System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
-
- SIGVTALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGVTALRM; -- virtual timer expired
-
- SIGPROF : constant Interrupt_ID :=
- System.OS_Interface.SIGPROF; -- profiling timer expired
-
- SIGWINCH : constant Interrupt_ID :=
- System.OS_Interface.SIGWINCH; -- window size change
-
- SIGINFO : constant Interrupt_ID :=
- System.OS_Interface.SIGINFO; -- information request
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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-2015, 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 DragonFly BSD THREADS version of this package
-
-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
-
- SIGURG : constant Interrupt_ID :=
- System.OS_Interface.SIGURG; -- urgent condition on IO channel
-
- 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
-
- SIGCHLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
-
- SIGCLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCLD; -- child status change
-
- SIGTTIN : constant Interrupt_ID :=
- System.OS_Interface.SIGTTIN; -- background tty read attempted
-
- SIGTTOU : constant Interrupt_ID :=
- System.OS_Interface.SIGTTOU; -- background tty write attempted
-
- SIGIO : constant Interrupt_ID := -- input/output possible,
- System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
-
- SIGXCPU : constant Interrupt_ID :=
- System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
-
- SIGXFSZ : constant Interrupt_ID :=
- System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
-
- SIGVTALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGVTALRM; -- virtual timer expired
-
- SIGPROF : constant Interrupt_ID :=
- System.OS_Interface.SIGPROF; -- profiling timer expired
-
- SIGWINCH : constant Interrupt_ID :=
- System.OS_Interface.SIGWINCH; -- window size change
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- (No Tasking Version) --
--- --
--- 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 --
--- <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. --
--- --
-------------------------------------------------------------------------------
-
--- The standard implementation of this spec contains only dummy interrupt
--- names. These dummy entries permit checking out code for correctness of
--- semantics, even if interrupts are not supported.
-
--- For specific implementations that fully support interrupts, this package
--- spec is replaced by an implementation dependent version that defines the
--- interrupts available on the system.
-
-package Ada.Interrupts.Names is
-
- -- All identifiers in this unit are implementation defined
-
- pragma Implementation_Defined;
-
- DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1;
- DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2;
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <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 FreeBSD THREADS version of this package
-
-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
-
- SIGURG : constant Interrupt_ID :=
- System.OS_Interface.SIGURG; -- urgent condition on IO channel
-
- 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
-
- SIGCHLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
-
- SIGCLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCLD; -- child status change
-
- SIGTTIN : constant Interrupt_ID :=
- System.OS_Interface.SIGTTIN; -- background tty read attempted
-
- SIGTTOU : constant Interrupt_ID :=
- System.OS_Interface.SIGTTOU; -- background tty write attempted
-
- SIGIO : constant Interrupt_ID := -- input/output possible,
- System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
-
- SIGXCPU : constant Interrupt_ID :=
- System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
-
- SIGXFSZ : constant Interrupt_ID :=
- System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
-
- SIGVTALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGVTALRM; -- virtual timer expired
-
- SIGPROF : constant Interrupt_ID :=
- System.OS_Interface.SIGPROF; -- profiling timer expired
-
- SIGWINCH : constant Interrupt_ID :=
- System.OS_Interface.SIGWINCH; -- window size change
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <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 a HP-UX version of this package
-
--- The following signals are reserved by the run time:
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT,
--- SIGALRM, SIGSTOP, SIGKILL
-
--- 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
-
- 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
-
- 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
-
- 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
-
- SIGPWR : constant Interrupt_ID :=
- System.OS_Interface.SIGPWR; -- power-fail restart
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <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 a GNU/Linux version of this package
-
--- The following signals are reserved by the run time:
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
--- SIGUSR1, SIGUSR2, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL
-
--- 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
-
- SIGUNUSED : constant Interrupt_ID :=
- System.OS_Interface.SIGUNUSED; -- unused signal
-
- SIGSTKFLT : constant Interrupt_ID :=
- System.OS_Interface.SIGSTKFLT; -- stack fault on coprocessor
-
- SIGLOST : constant Interrupt_ID :=
- System.OS_Interface.SIGLOST; -- Linux alias for SIGIO
-
- SIGPWR : constant Interrupt_ID :=
- System.OS_Interface.SIGPWR; -- Power failure
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <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 a LynxOS version of this package
-
--- The following signals are reserved by the run time:
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
--- SIGWAITING, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGSTOP, SIGKILL
-
--- The pragma Unreserve_All_Interrupts affects the following signal(s):
-
--- SIGINT: made available for Ada handler
-
-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.
-
- 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)
-
- SIGBRK : constant Interrupt_ID :=
- System.OS_Interface.SIGBRK; -- break
-
- 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
-
- SIGCORE : constant Interrupt_ID :=
- System.OS_Interface.SIGCORE; -- kill with core dump
-
- 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
-
- SIGURG : constant Interrupt_ID :=
- System.OS_Interface.SIGURG; -- urgent condition on IO channel
-
- 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
-
- 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
-
- SIGTTIN : constant Interrupt_ID :=
- System.OS_Interface.SIGTTIN; -- background tty read attempted
-
- SIGTTOU : constant Interrupt_ID :=
- System.OS_Interface.SIGTTOU; -- background tty write attempted
-
- 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)
-
- SIGXCPU : constant Interrupt_ID :=
- System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
-
- SIGXFSZ : constant Interrupt_ID :=
- System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
-
- SIGVTALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGVTALRM; -- virtual timer expired
-
- SIGPROF : constant Interrupt_ID :=
- System.OS_Interface.SIGPROF; -- profiling timer expired
-
- SIGWINCH : constant Interrupt_ID :=
- System.OS_Interface.SIGWINCH; -- window size change
-
- SIGLOST : constant Interrupt_ID :=
- System.OS_Interface.SIGLOST; -- SUN 4.1 compatibility
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
- SIGPRIO : constant Interrupt_ID :=
- System.OS_Interface.SIGPRIO;
- -- sent to a process with its priority
- -- or group is changed
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1997-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 --
--- <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 a NT (native) version of this package
-
--- 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.
-
- SIGINT : constant Interrupt_ID := -- interrupt (rubout)
- System.OS_Interface.SIGINT;
-
- SIGILL : constant Interrupt_ID := -- illegal instruction (not reset)
- System.OS_Interface.SIGILL;
-
- SIGABRT : constant Interrupt_ID := -- used by abort (use SIGIOT in future)
- System.OS_Interface.SIGABRT;
-
- SIGFPE : constant Interrupt_ID := -- floating point exception
- System.OS_Interface.SIGFPE;
-
- SIGSEGV : constant Interrupt_ID := -- segmentation violation
- System.OS_Interface.SIGSEGV;
-
- SIGTERM : constant Interrupt_ID := -- software termination signal from kill
- System.OS_Interface.SIGTERM;
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA 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-2009 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. --
--- --
--- The GNARL files that were developed for RTEMS are maintained by On-Line --
--- Applications Research Corporation (http://www.oarcorp.com) in coopera- --
--- tion with Ada Core Technologies Inc. and Florida State University. --
--- --
-------------------------------------------------------------------------------
-
--- 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
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <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 a Solaris version of this package
-
--- The following signals are reserved by the run time (native threads):
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
--- SIGLWP, SIGWAITING, SIGCANCEL, SIGSTOP, SIGKILL
-
--- The following signals are reserved by the run time (FSU threads):
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT,
--- SIGLWP, SIGALRM, SIGVTALRM, SIGWAITING, SIGSTOP, SIGKILL
-
--- The pragma Unreserve_All_Interrupts affects the following signal(s):
-
--- SIGINT: made available for Ada handlers
-
-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
-
- 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
-
- 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
-
- SIGPWR : constant Interrupt_ID :=
- System.OS_Interface.SIGPWR; -- power-fail restart
-
- SIGWAITING : constant Interrupt_ID :=
- System.OS_Interface.SIGWAITING; -- process's lwps blocked (Solaris)
-
- SIGLWP : constant Interrupt_ID :=
- System.OS_Interface.SIGLWP; -- used by thread library (Solaris)
-
- SIGFREEZE : constant Interrupt_ID :=
- System.OS_Interface.SIGFREEZE; -- used by CPR (Solaris)
-
--- what is CPR????
-
- SIGTHAW : constant Interrupt_ID :=
- System.OS_Interface.SIGTHAW; -- used by CPR (Solaris)
-
- SIGCANCEL : constant Interrupt_ID :=
- System.OS_Interface.SIGCANCEL; -- used for thread cancel (Solaris)
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1998-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 --
--- <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 VxWorks version of this package
-
-with System.OS_Interface;
-
-package Ada.Interrupts.Names is
-
- -- All identifiers in this unit are implementation defined
-
- pragma Implementation_Defined;
-
- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <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 a AIX version of this package
+
+-- The following signals are reserved by the run time (native threads):
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGEMT
+-- SIGSTOP, SIGKILL
+
+-- The following signals are reserved by the run time (FSU threads):
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGALRM,
+-- SIGWAITING, SIGSTOP, SIGKILL
+
+-- 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
+
+ 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
+
+ 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
+
+ SIGPWR : constant Interrupt_ID :=
+ System.OS_Interface.SIGPWR; -- power-fail restart
+
+ 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
+
+ SIGMSG : constant Interrupt_ID :=
+ System.OS_Interface.SIGMSG; -- input data is in the ring buffer
+
+ SIGDANGER : constant Interrupt_ID :=
+ System.OS_Interface.SIGDANGER; -- system crash imminent;
+
+ SIGMIGRATE : constant Interrupt_ID :=
+ System.OS_Interface.SIGMIGRATE; -- migrate process
+
+ SIGPRE : constant Interrupt_ID :=
+ System.OS_Interface.SIGPRE; -- programming exception
+
+ SIGVIRT : constant Interrupt_ID :=
+ System.OS_Interface.SIGVIRT; -- AIX virtual time alarm
+
+ SIGALRM1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGALRM1; -- m:n condition variables
+
+ SIGWAITING : constant Interrupt_ID :=
+ System.OS_Interface.SIGWAITING; -- m:n scheduling
+
+ SIGKAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGKAP; -- keep alive poll from native keyboard
+
+ SIGGRANT : constant Interrupt_ID :=
+ System.OS_Interface.SIGGRANT; -- monitor mode granted
+
+ SIGRETRACT : constant Interrupt_ID :=
+ System.OS_Interface.SIGRETRACT; -- monitor mode should be relinquished
+
+ SIGSOUND : constant Interrupt_ID :=
+ System.OS_Interface.SIGSOUND; -- sound control has completed
+
+ SIGSAK : constant Interrupt_ID :=
+ System.OS_Interface.SIGSAK; -- secure attention key
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <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 Darwin version of this package
+
+-- The following signals are reserved by the run time:
+
+-- SIGSTOP, SIGKILL
+
+-- 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
+
+ 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
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ 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
+
+ SIGCHLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
+
+ SIGTTIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTIN; -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTOU; -- background tty write attempted
+
+ SIGIO : constant Interrupt_ID := -- input/output possible,
+ System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
+
+ SIGXCPU : constant Interrupt_ID :=
+ System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
+
+ SIGXFSZ : constant Interrupt_ID :=
+ System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
+
+ SIGVTALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGVTALRM; -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID :=
+ System.OS_Interface.SIGPROF; -- profiling timer expired
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGINFO : constant Interrupt_ID :=
+ System.OS_Interface.SIGINFO; -- information request
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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-2015, 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 DragonFly BSD THREADS version of this package
+
+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
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ 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
+
+ SIGCHLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
+
+ SIGCLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCLD; -- child status change
+
+ SIGTTIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTIN; -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTOU; -- background tty write attempted
+
+ SIGIO : constant Interrupt_ID := -- input/output possible,
+ System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
+
+ SIGXCPU : constant Interrupt_ID :=
+ System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
+
+ SIGXFSZ : constant Interrupt_ID :=
+ System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
+
+ SIGVTALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGVTALRM; -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID :=
+ System.OS_Interface.SIGPROF; -- profiling timer expired
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- (No Tasking Version) --
+-- --
+-- 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 --
+-- <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. --
+-- --
+------------------------------------------------------------------------------
+
+-- The standard implementation of this spec contains only dummy interrupt
+-- names. These dummy entries permit checking out code for correctness of
+-- semantics, even if interrupts are not supported.
+
+-- For specific implementations that fully support interrupts, this package
+-- spec is replaced by an implementation dependent version that defines the
+-- interrupts available on the system.
+
+package Ada.Interrupts.Names is
+
+ -- All identifiers in this unit are implementation defined
+
+ pragma Implementation_Defined;
+
+ DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1;
+ DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2;
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <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 FreeBSD THREADS version of this package
+
+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
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ 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
+
+ SIGCHLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
+
+ SIGCLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCLD; -- child status change
+
+ SIGTTIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTIN; -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTOU; -- background tty write attempted
+
+ SIGIO : constant Interrupt_ID := -- input/output possible,
+ System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
+
+ SIGXCPU : constant Interrupt_ID :=
+ System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
+
+ SIGXFSZ : constant Interrupt_ID :=
+ System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
+
+ SIGVTALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGVTALRM; -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID :=
+ System.OS_Interface.SIGPROF; -- profiling timer expired
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <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 a HP-UX version of this package
+
+-- The following signals are reserved by the run time:
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT,
+-- SIGALRM, SIGSTOP, SIGKILL
+
+-- 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
+
+ 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
+
+ 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
+
+ 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
+
+ SIGPWR : constant Interrupt_ID :=
+ System.OS_Interface.SIGPWR; -- power-fail restart
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <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 a GNU/Linux version of this package
+
+-- The following signals are reserved by the run time:
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGUSR1, SIGUSR2, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL
+
+-- 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
+
+ SIGUNUSED : constant Interrupt_ID :=
+ System.OS_Interface.SIGUNUSED; -- unused signal
+
+ SIGSTKFLT : constant Interrupt_ID :=
+ System.OS_Interface.SIGSTKFLT; -- stack fault on coprocessor
+
+ SIGLOST : constant Interrupt_ID :=
+ System.OS_Interface.SIGLOST; -- Linux alias for SIGIO
+
+ SIGPWR : constant Interrupt_ID :=
+ System.OS_Interface.SIGPWR; -- Power failure
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <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 a LynxOS version of this package
+
+-- The following signals are reserved by the run time:
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGWAITING, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGSTOP, SIGKILL
+
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+
+-- SIGINT: made available for Ada handler
+
+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.
+
+ 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)
+
+ SIGBRK : constant Interrupt_ID :=
+ System.OS_Interface.SIGBRK; -- break
+
+ 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
+
+ SIGCORE : constant Interrupt_ID :=
+ System.OS_Interface.SIGCORE; -- kill with core dump
+
+ 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
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ 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
+
+ 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
+
+ SIGTTIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTIN; -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTOU; -- background tty write attempted
+
+ 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)
+
+ SIGXCPU : constant Interrupt_ID :=
+ System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
+
+ SIGXFSZ : constant Interrupt_ID :=
+ System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
+
+ SIGVTALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGVTALRM; -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID :=
+ System.OS_Interface.SIGPROF; -- profiling timer expired
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGLOST : constant Interrupt_ID :=
+ System.OS_Interface.SIGLOST; -- SUN 4.1 compatibility
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+ SIGPRIO : constant Interrupt_ID :=
+ System.OS_Interface.SIGPRIO;
+ -- sent to a process with its priority
+ -- or group is changed
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1997-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 --
+-- <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 a NT (native) version of this package
+
+-- 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.
+
+ SIGINT : constant Interrupt_ID := -- interrupt (rubout)
+ System.OS_Interface.SIGINT;
+
+ SIGILL : constant Interrupt_ID := -- illegal instruction (not reset)
+ System.OS_Interface.SIGILL;
+
+ SIGABRT : constant Interrupt_ID := -- used by abort (use SIGIOT in future)
+ System.OS_Interface.SIGABRT;
+
+ SIGFPE : constant Interrupt_ID := -- floating point exception
+ System.OS_Interface.SIGFPE;
+
+ SIGSEGV : constant Interrupt_ID := -- segmentation violation
+ System.OS_Interface.SIGSEGV;
+
+ SIGTERM : constant Interrupt_ID := -- software termination signal from kill
+ System.OS_Interface.SIGTERM;
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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-2009 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. --
+-- --
+-- The GNARL files that were developed for RTEMS are maintained by On-Line --
+-- Applications Research Corporation (http://www.oarcorp.com) in coopera- --
+-- tion with Ada Core Technologies Inc. and Florida State University. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <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 a Solaris version of this package
+
+-- The following signals are reserved by the run time (native threads):
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGLWP, SIGWAITING, SIGCANCEL, SIGSTOP, SIGKILL
+
+-- The following signals are reserved by the run time (FSU threads):
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT,
+-- SIGLWP, SIGALRM, SIGVTALRM, SIGWAITING, SIGSTOP, SIGKILL
+
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+
+-- SIGINT: made available for Ada handlers
+
+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
+
+ 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
+
+ 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
+
+ SIGPWR : constant Interrupt_ID :=
+ System.OS_Interface.SIGPWR; -- power-fail restart
+
+ SIGWAITING : constant Interrupt_ID :=
+ System.OS_Interface.SIGWAITING; -- process's lwps blocked (Solaris)
+
+ SIGLWP : constant Interrupt_ID :=
+ System.OS_Interface.SIGLWP; -- used by thread library (Solaris)
+
+ SIGFREEZE : constant Interrupt_ID :=
+ System.OS_Interface.SIGFREEZE; -- used by CPR (Solaris)
+
+-- what is CPR????
+
+ SIGTHAW : constant Interrupt_ID :=
+ System.OS_Interface.SIGTHAW; -- used by CPR (Solaris)
+
+ SIGCANCEL : constant Interrupt_ID :=
+ System.OS_Interface.SIGCANCEL; -- used for thread cancel (Solaris)
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1998-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 --
+-- <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 VxWorks version of this package
+
+with System.OS_Interface;
+
+package Ada.Interrupts.Names is
+
+ -- All identifiers in this unit are implementation defined
+
+ pragma Implementation_Defined;
+
+ 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S Y N C H R O N O U S _ B A R R I E R S --
--- --
--- B o d y --
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the body of this package using POSIX barriers
-
-with Interfaces.C; use Interfaces.C;
-
-package body Ada.Synchronous_Barriers is
-
- --------------------
- -- POSIX barriers --
- --------------------
-
- function pthread_barrier_init
- (barrier : not null access pthread_barrier_t;
- attr : System.Address := System.Null_Address;
- count : unsigned) return int;
- pragma Import (C, pthread_barrier_init, "pthread_barrier_init");
- -- Initialize barrier with the attributes in attr. The barrier is opened
- -- when count waiters arrived. If attr is null the default barrier
- -- attributes are used.
-
- function pthread_barrier_destroy
- (barrier : not null access pthread_barrier_t) return int;
- pragma Import (C, pthread_barrier_destroy, "pthread_barrier_destroy");
- -- Destroy a previously dynamically initialized barrier
-
- function pthread_barrier_wait
- (barrier : not null access pthread_barrier_t) return int;
- pragma Import (C, pthread_barrier_wait, "pthread_barrier_wait");
- -- Wait on barrier
-
- --------------
- -- Finalize --
- --------------
-
- overriding procedure Finalize (Barrier : in out Synchronous_Barrier) is
- Result : int;
- begin
- Result := pthread_barrier_destroy (Barrier.POSIX_Barrier'Access);
- pragma Assert (Result = 0);
- end Finalize;
-
- overriding procedure Initialize (Barrier : in out Synchronous_Barrier) is
- Result : int;
- begin
- Result :=
- pthread_barrier_init
- (barrier => Barrier.POSIX_Barrier'Access,
- attr => System.Null_Address,
- count => unsigned (Barrier.Release_Threshold));
- pragma Assert (Result = 0);
- end Initialize;
-
- ----------------------
- -- Wait_For_Release --
- ----------------------
-
- procedure Wait_For_Release
- (The_Barrier : in out Synchronous_Barrier;
- Notified : out Boolean)
- is
- Result : int;
-
- PTHREAD_BARRIER_SERIAL_THREAD : constant := -1;
- -- Value used to indicate the task which receives the notification for
- -- the barrier open.
-
- begin
- Result :=
- pthread_barrier_wait
- (barrier => The_Barrier.POSIX_Barrier'Access);
- pragma Assert
- (Result = 0 or else Result = PTHREAD_BARRIER_SERIAL_THREAD);
-
- Notified := (Result = PTHREAD_BARRIER_SERIAL_THREAD);
- end Wait_For_Release;
-
-end Ada.Synchronous_Barriers;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S Y N C H R O N O U S _ B A R R I E R S --
--- --
--- S p e c --
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the spec of this package using POSIX barriers
-
-with System;
-private with Ada.Finalization;
-private with Interfaces.C;
-
-package Ada.Synchronous_Barriers is
- pragma Preelaborate (Synchronous_Barriers);
-
- subtype Barrier_Limit is Positive range 1 .. Positive'Last;
-
- type Synchronous_Barrier (Release_Threshold : Barrier_Limit) is
- limited private;
-
- procedure Wait_For_Release
- (The_Barrier : in out Synchronous_Barrier;
- Notified : out Boolean);
-
-private
- -- POSIX barrier data type
-
- SIZEOF_PTHREAD_BARRIER_T : constant :=
- (if System.Word_Size = 64 then 32 else 20);
- -- Value defined according to the linux definition in pthreadtypes.h. On
- -- other system, e.g. MIPS IRIX, the object is smaller, so it works
- -- correctly although we are wasting some space.
-
- type pthread_barrier_t_view is (size_based, align_based);
-
- type pthread_barrier_t (Kind : pthread_barrier_t_view := size_based) is
- record
- case Kind is
- when size_based =>
- size : Interfaces.C.char_array (1 .. SIZEOF_PTHREAD_BARRIER_T);
- when align_based =>
- align : Interfaces.C.long;
- end case;
- end record;
- pragma Unchecked_Union (pthread_barrier_t);
-
- type Synchronous_Barrier (Release_Threshold : Barrier_Limit) is
- new Ada.Finalization.Limited_Controlled with
- record
- POSIX_Barrier : aliased pthread_barrier_t;
- end record;
-
- overriding procedure Initialize (Barrier : in out Synchronous_Barrier);
- overriding procedure Finalize (Barrier : in out Synchronous_Barrier);
-end Ada.Synchronous_Barriers;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S Y N C H R O N O U S _ B A R R I E R S --
+-- --
+-- B o d y --
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the body of this package using POSIX barriers
+
+with Interfaces.C; use Interfaces.C;
+
+package body Ada.Synchronous_Barriers is
+
+ --------------------
+ -- POSIX barriers --
+ --------------------
+
+ function pthread_barrier_init
+ (barrier : not null access pthread_barrier_t;
+ attr : System.Address := System.Null_Address;
+ count : unsigned) return int;
+ pragma Import (C, pthread_barrier_init, "pthread_barrier_init");
+ -- Initialize barrier with the attributes in attr. The barrier is opened
+ -- when count waiters arrived. If attr is null the default barrier
+ -- attributes are used.
+
+ function pthread_barrier_destroy
+ (barrier : not null access pthread_barrier_t) return int;
+ pragma Import (C, pthread_barrier_destroy, "pthread_barrier_destroy");
+ -- Destroy a previously dynamically initialized barrier
+
+ function pthread_barrier_wait
+ (barrier : not null access pthread_barrier_t) return int;
+ pragma Import (C, pthread_barrier_wait, "pthread_barrier_wait");
+ -- Wait on barrier
+
+ --------------
+ -- Finalize --
+ --------------
+
+ overriding procedure Finalize (Barrier : in out Synchronous_Barrier) is
+ Result : int;
+ begin
+ Result := pthread_barrier_destroy (Barrier.POSIX_Barrier'Access);
+ pragma Assert (Result = 0);
+ end Finalize;
+
+ overriding procedure Initialize (Barrier : in out Synchronous_Barrier) is
+ Result : int;
+ begin
+ Result :=
+ pthread_barrier_init
+ (barrier => Barrier.POSIX_Barrier'Access,
+ attr => System.Null_Address,
+ count => unsigned (Barrier.Release_Threshold));
+ pragma Assert (Result = 0);
+ end Initialize;
+
+ ----------------------
+ -- Wait_For_Release --
+ ----------------------
+
+ procedure Wait_For_Release
+ (The_Barrier : in out Synchronous_Barrier;
+ Notified : out Boolean)
+ is
+ Result : int;
+
+ PTHREAD_BARRIER_SERIAL_THREAD : constant := -1;
+ -- Value used to indicate the task which receives the notification for
+ -- the barrier open.
+
+ begin
+ Result :=
+ pthread_barrier_wait
+ (barrier => The_Barrier.POSIX_Barrier'Access);
+ pragma Assert
+ (Result = 0 or else Result = PTHREAD_BARRIER_SERIAL_THREAD);
+
+ Notified := (Result = PTHREAD_BARRIER_SERIAL_THREAD);
+ end Wait_For_Release;
+
+end Ada.Synchronous_Barriers;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S Y N C H R O N O U S _ B A R R I E R S --
+-- --
+-- S p e c --
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the spec of this package using POSIX barriers
+
+with System;
+private with Ada.Finalization;
+private with Interfaces.C;
+
+package Ada.Synchronous_Barriers is
+ pragma Preelaborate (Synchronous_Barriers);
+
+ subtype Barrier_Limit is Positive range 1 .. Positive'Last;
+
+ type Synchronous_Barrier (Release_Threshold : Barrier_Limit) is
+ limited private;
+
+ procedure Wait_For_Release
+ (The_Barrier : in out Synchronous_Barrier;
+ Notified : out Boolean);
+
+private
+ -- POSIX barrier data type
+
+ SIZEOF_PTHREAD_BARRIER_T : constant :=
+ (if System.Word_Size = 64 then 32 else 20);
+ -- Value defined according to the linux definition in pthreadtypes.h. On
+ -- other system, e.g. MIPS IRIX, the object is smaller, so it works
+ -- correctly although we are wasting some space.
+
+ type pthread_barrier_t_view is (size_based, align_based);
+
+ type pthread_barrier_t (Kind : pthread_barrier_t_view := size_based) is
+ record
+ case Kind is
+ when size_based =>
+ size : Interfaces.C.char_array (1 .. SIZEOF_PTHREAD_BARRIER_T);
+ when align_based =>
+ align : Interfaces.C.long;
+ end case;
+ end record;
+ pragma Unchecked_Union (pthread_barrier_t);
+
+ type Synchronous_Barrier (Release_Threshold : Barrier_Limit) is
+ new Ada.Finalization.Limited_Controlled with
+ record
+ POSIX_Barrier : aliased pthread_barrier_t;
+ end record;
+
+ overriding procedure Initialize (Barrier : in out Synchronous_Barrier);
+ overriding procedure Finalize (Barrier : in out Synchronous_Barrier);
+end Ada.Synchronous_Barriers;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
--- --
--- 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 --
--- <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 a NO tasking version of this package
-
-package body System.Interrupt_Management.Operations is
-
- -- Turn off warnings since many unused formals
-
- pragma Warnings (Off);
-
- ----------------------------
- -- Thread_Block_Interrupt --
- ----------------------------
-
- procedure Thread_Block_Interrupt
- (Interrupt : Interrupt_ID)
- is
- begin
- null;
- end Thread_Block_Interrupt;
-
- ------------------------------
- -- Thread_Unblock_Interrupt --
- ------------------------------
-
- procedure Thread_Unblock_Interrupt
- (Interrupt : Interrupt_ID)
- is
- begin
- null;
- end Thread_Unblock_Interrupt;
-
- ------------------------
- -- Set_Interrupt_Mask --
- ------------------------
-
- procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
- begin
- null;
- end Set_Interrupt_Mask;
-
- procedure Set_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- OMask : access Interrupt_Mask) is
- begin
- null;
- end Set_Interrupt_Mask;
-
- ------------------------
- -- Get_Interrupt_Mask --
- ------------------------
-
- procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
- begin
- null;
- end Get_Interrupt_Mask;
-
- --------------------
- -- Interrupt_Wait --
- --------------------
-
- function Interrupt_Wait
- (Mask : access Interrupt_Mask)
- return Interrupt_ID
- is
- begin
- return 0;
- end Interrupt_Wait;
-
- ----------------------------
- -- Install_Default_Action --
- ----------------------------
-
- procedure Install_Default_Action (Interrupt : Interrupt_ID) is
- begin
- null;
- end Install_Default_Action;
-
- ---------------------------
- -- Install_Ignore_Action --
- ---------------------------
-
- procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
- begin
- null;
- end Install_Ignore_Action;
-
- -------------------------
- -- Fill_Interrupt_Mask --
- -------------------------
-
- procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
- begin
- null;
- end Fill_Interrupt_Mask;
-
- --------------------------
- -- Empty_Interrupt_Mask --
- --------------------------
-
- procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
- begin
- null;
- end Empty_Interrupt_Mask;
-
- ---------------------------
- -- Add_To_Interrupt_Mask --
- ---------------------------
-
- procedure Add_To_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID)
- is
- begin
- null;
- end Add_To_Interrupt_Mask;
-
- --------------------------------
- -- Delete_From_Interrupt_Mask --
- --------------------------------
-
- procedure Delete_From_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID)
- is
- begin
- null;
- end Delete_From_Interrupt_Mask;
-
- ---------------
- -- Is_Member --
- ---------------
-
- function Is_Member
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID) return Boolean
- is
- begin
- return False;
- end Is_Member;
-
- -------------------------
- -- Copy_Interrupt_Mask --
- -------------------------
-
- procedure Copy_Interrupt_Mask
- (X : out Interrupt_Mask;
- Y : Interrupt_Mask)
- is
- begin
- X := Y;
- end Copy_Interrupt_Mask;
-
- -------------------------
- -- Interrupt_Self_Process --
- -------------------------
-
- procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
- begin
- null;
- end Interrupt_Self_Process;
-
- --------------------------
- -- Setup_Interrupt_Mask --
- --------------------------
-
- procedure Setup_Interrupt_Mask is
- begin
- null;
- end Setup_Interrupt_Mask;
-
-end System.Interrupt_Management.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-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- --
--- 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 a POSIX-like version of this package
-
--- Note: this file can only be used for POSIX compliant systems
-
-with Interfaces.C;
-
-with System.OS_Interface;
-with System.Storage_Elements;
-
-package body System.Interrupt_Management.Operations is
-
- use Interfaces.C;
- use System.OS_Interface;
-
- ---------------------
- -- Local Variables --
- ---------------------
-
- Initial_Action : array (Signal) of aliased struct_sigaction;
-
- Default_Action : aliased struct_sigaction;
- pragma Warnings (Off, Default_Action);
-
- Ignore_Action : aliased struct_sigaction;
-
- ----------------------------
- -- Thread_Block_Interrupt --
- ----------------------------
-
- procedure Thread_Block_Interrupt
- (Interrupt : Interrupt_ID)
- is
- Result : Interfaces.C.int;
- Mask : aliased sigset_t;
- begin
- Result := sigemptyset (Mask'Access);
- pragma Assert (Result = 0);
- Result := sigaddset (Mask'Access, Signal (Interrupt));
- pragma Assert (Result = 0);
- Result := pthread_sigmask (SIG_BLOCK, Mask'Access, null);
- pragma Assert (Result = 0);
- end Thread_Block_Interrupt;
-
- ------------------------------
- -- Thread_Unblock_Interrupt --
- ------------------------------
-
- procedure Thread_Unblock_Interrupt
- (Interrupt : Interrupt_ID)
- is
- Mask : aliased sigset_t;
- Result : Interfaces.C.int;
- begin
- Result := sigemptyset (Mask'Access);
- pragma Assert (Result = 0);
- Result := sigaddset (Mask'Access, Signal (Interrupt));
- pragma Assert (Result = 0);
- Result := pthread_sigmask (SIG_UNBLOCK, Mask'Access, null);
- pragma Assert (Result = 0);
- end Thread_Unblock_Interrupt;
-
- ------------------------
- -- Set_Interrupt_Mask --
- ------------------------
-
- procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_sigmask (SIG_SETMASK, Mask, null);
- pragma Assert (Result = 0);
- end Set_Interrupt_Mask;
-
- procedure Set_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- OMask : access Interrupt_Mask)
- is
- Result : Interfaces.C.int;
- begin
- Result := pthread_sigmask (SIG_SETMASK, Mask, OMask);
- pragma Assert (Result = 0);
- end Set_Interrupt_Mask;
-
- ------------------------
- -- Get_Interrupt_Mask --
- ------------------------
-
- procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_sigmask (SIG_SETMASK, null, Mask);
- pragma Assert (Result = 0);
- end Get_Interrupt_Mask;
-
- --------------------
- -- Interrupt_Wait --
- --------------------
-
- function Interrupt_Wait
- (Mask : access Interrupt_Mask) return Interrupt_ID
- is
- Result : Interfaces.C.int;
- Sig : aliased Signal;
-
- begin
- Result := sigwait (Mask, Sig'Access);
-
- if Result /= 0 then
- return 0;
- end if;
-
- return Interrupt_ID (Sig);
- end Interrupt_Wait;
-
- ----------------------------
- -- Install_Default_Action --
- ----------------------------
-
- procedure Install_Default_Action (Interrupt : Interrupt_ID) is
- Result : Interfaces.C.int;
- begin
- Result := sigaction
- (Signal (Interrupt),
- Initial_Action (Signal (Interrupt))'Access, null);
- pragma Assert (Result = 0);
- end Install_Default_Action;
-
- ---------------------------
- -- Install_Ignore_Action --
- ---------------------------
-
- procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
- Result : Interfaces.C.int;
- begin
- Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
- pragma Assert (Result = 0);
- end Install_Ignore_Action;
-
- -------------------------
- -- Fill_Interrupt_Mask --
- -------------------------
-
- procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
- Result : Interfaces.C.int;
- begin
- Result := sigfillset (Mask);
- pragma Assert (Result = 0);
- end Fill_Interrupt_Mask;
-
- --------------------------
- -- Empty_Interrupt_Mask --
- --------------------------
-
- procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
- Result : Interfaces.C.int;
- begin
- Result := sigemptyset (Mask);
- pragma Assert (Result = 0);
- end Empty_Interrupt_Mask;
-
- ---------------------------
- -- Add_To_Interrupt_Mask --
- ---------------------------
-
- procedure Add_To_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID)
- is
- Result : Interfaces.C.int;
- begin
- Result := sigaddset (Mask, Signal (Interrupt));
- pragma Assert (Result = 0);
- end Add_To_Interrupt_Mask;
-
- --------------------------------
- -- Delete_From_Interrupt_Mask --
- --------------------------------
-
- procedure Delete_From_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID)
- is
- Result : Interfaces.C.int;
- begin
- Result := sigdelset (Mask, Signal (Interrupt));
- pragma Assert (Result = 0);
- end Delete_From_Interrupt_Mask;
-
- ---------------
- -- Is_Member --
- ---------------
-
- function Is_Member
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID) return Boolean
- is
- Result : Interfaces.C.int;
- begin
- Result := sigismember (Mask, Signal (Interrupt));
- pragma Assert (Result = 0 or else Result = 1);
- return Result = 1;
- end Is_Member;
-
- -------------------------
- -- Copy_Interrupt_Mask --
- -------------------------
-
- procedure Copy_Interrupt_Mask
- (X : out Interrupt_Mask;
- Y : Interrupt_Mask) is
- begin
- X := Y;
- end Copy_Interrupt_Mask;
-
- ----------------------------
- -- Interrupt_Self_Process --
- ----------------------------
-
- procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
- Result : Interfaces.C.int;
- begin
- Result := kill (getpid, Signal (Interrupt));
- pragma Assert (Result = 0);
- end Interrupt_Self_Process;
-
- --------------------------
- -- Setup_Interrupt_Mask --
- --------------------------
-
- procedure Setup_Interrupt_Mask is
- begin
- -- Mask task for all signals. The original mask of the Environment task
- -- will be recovered by Interrupt_Manager task during the elaboration
- -- of s-interr.adb.
-
- Set_Interrupt_Mask (All_Tasks_Mask'Access);
- end Setup_Interrupt_Mask;
-
-begin
- declare
- mask : aliased sigset_t;
- allmask : aliased sigset_t;
- Result : Interfaces.C.int;
-
- begin
- Interrupt_Management.Initialize;
-
- for Sig in 1 .. Signal'Last loop
- Result := sigaction
- (Sig, null, Initial_Action (Sig)'Access);
-
- -- ??? [assert 1]
- -- we can't check Result here since sigaction will fail on
- -- SIGKILL, SIGSTOP, and possibly other signals
- -- pragma Assert (Result = 0);
-
- end loop;
-
- -- Setup the masks to be exported
-
- Result := sigemptyset (mask'Access);
- pragma Assert (Result = 0);
-
- Result := sigfillset (allmask'Access);
- pragma Assert (Result = 0);
-
- Default_Action.sa_flags := 0;
- Default_Action.sa_mask := mask;
- Default_Action.sa_handler :=
- Storage_Elements.To_Address
- (Storage_Elements.Integer_Address (SIG_DFL));
-
- Ignore_Action.sa_flags := 0;
- Ignore_Action.sa_mask := mask;
- Ignore_Action.sa_handler :=
- Storage_Elements.To_Address
- (Storage_Elements.Integer_Address (SIG_IGN));
-
- for J in Interrupt_ID loop
- if Keep_Unmasked (J) then
- Result := sigaddset (mask'Access, Signal (J));
- pragma Assert (Result = 0);
- Result := sigdelset (allmask'Access, Signal (J));
- pragma Assert (Result = 0);
- end if;
- end loop;
-
- -- The Keep_Unmasked signals should be unmasked for Environment task
-
- Result := pthread_sigmask (SIG_UNBLOCK, mask'Access, null);
- pragma Assert (Result = 0);
-
- -- Get the signal mask of the Environment Task
-
- Result := pthread_sigmask (SIG_SETMASK, null, mask'Access);
- pragma Assert (Result = 0);
-
- -- Setup the constants exported
-
- Environment_Mask := Interrupt_Mask (mask);
-
- All_Tasks_Mask := Interrupt_Mask (allmask);
- end;
-
-end System.Interrupt_Management.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-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- --
--- 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 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.
-
-with Ada.Exceptions;
-
-with Interfaces.C;
-
-with System.OS_Interface;
-
-package body System.Interrupt_Management.Operations is
-
- use Ada.Exceptions;
- use Interfaces.C;
- use System.OS_Interface;
-
- ----------------------------
- -- Thread_Block_Interrupt --
- ----------------------------
-
- procedure Thread_Block_Interrupt
- (Interrupt : Interrupt_ID)
- is
- pragma Unreferenced (Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Thread_Block_Interrupt unimplemented");
- end Thread_Block_Interrupt;
-
- ------------------------------
- -- Thread_Unblock_Interrupt --
- ------------------------------
-
- procedure Thread_Unblock_Interrupt
- (Interrupt : Interrupt_ID)
- is
- pragma Unreferenced (Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Thread_Unblock_Interrupt unimplemented");
- end Thread_Unblock_Interrupt;
-
- ------------------------
- -- Set_Interrupt_Mask --
- ------------------------
-
- procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
- pragma Unreferenced (Mask);
- begin
- null;
- end Set_Interrupt_Mask;
-
- procedure Set_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- OMask : access Interrupt_Mask)
- is
- pragma Unreferenced (Mask, OMask);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Set_Interrupt_Mask unimplemented");
- end Set_Interrupt_Mask;
-
- ------------------------
- -- Get_Interrupt_Mask --
- ------------------------
-
- procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
- pragma Unreferenced (Mask);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Get_Interrupt_Mask unimplemented");
- end Get_Interrupt_Mask;
-
- --------------------
- -- Interrupt_Wait --
- --------------------
-
- function Interrupt_Wait
- (Mask : access Interrupt_Mask) return Interrupt_ID
- is
- pragma Unreferenced (Mask);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Interrupt_Wait unimplemented");
- return 0;
- end Interrupt_Wait;
-
- ----------------------------
- -- Install_Default_Action --
- ----------------------------
-
- procedure Install_Default_Action (Interrupt : Interrupt_ID) is
- pragma Unreferenced (Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Install_Default_Action unimplemented");
- end Install_Default_Action;
-
- ---------------------------
- -- Install_Ignore_Action --
- ---------------------------
-
- procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
- pragma Unreferenced (Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Install_Ignore_Action unimplemented");
- end Install_Ignore_Action;
-
- -------------------------
- -- Fill_Interrupt_Mask --
- -------------------------
-
- procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
- pragma Unreferenced (Mask);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Fill_Interrupt_Mask unimplemented");
- end Fill_Interrupt_Mask;
-
- --------------------------
- -- Empty_Interrupt_Mask --
- --------------------------
-
- procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
- pragma Unreferenced (Mask);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Empty_Interrupt_Mask unimplemented");
- end Empty_Interrupt_Mask;
-
- ---------------------------
- -- Add_To_Interrupt_Mask --
- ---------------------------
-
- procedure Add_To_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID)
- is
- pragma Unreferenced (Mask, Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Add_To_Interrupt_Mask unimplemented");
- end Add_To_Interrupt_Mask;
-
- --------------------------------
- -- Delete_From_Interrupt_Mask --
- --------------------------------
-
- procedure Delete_From_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID)
- is
- pragma Unreferenced (Mask, Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Delete_From_Interrupt_Mask unimplemented");
- end Delete_From_Interrupt_Mask;
-
- ---------------
- -- Is_Member --
- ---------------
-
- function Is_Member
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID) return Boolean
- is
- pragma Unreferenced (Mask, Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Is_Member unimplemented");
- return False;
- end Is_Member;
-
- -------------------------
- -- Copy_Interrupt_Mask --
- -------------------------
-
- procedure Copy_Interrupt_Mask
- (X : out Interrupt_Mask;
- Y : Interrupt_Mask) is
- pragma Unreferenced (X, Y);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Copy_Interrupt_Mask unimplemented");
- end Copy_Interrupt_Mask;
-
- ----------------------------
- -- Interrupt_Self_Process --
- ----------------------------
-
- procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
- Result : Interfaces.C.int;
- begin
- Result := kill (getpid, Signal (Interrupt));
- pragma Assert (Result = 0);
- end Interrupt_Self_Process;
-
- --------------------------
- -- Setup_Interrupt_Mask --
- --------------------------
-
- procedure Setup_Interrupt_Mask is
- begin
- -- Nothing to be done. Ada interrupt facilities on VxWorks do not use
- -- signals but hardware interrupts. Therefore, interrupt management does
- -- not need anything related to signal masking. Note that this procedure
- -- cannot raise an exception (as some others in this package) because
- -- the generic implementation of the Timer_Server and timing events make
- -- explicit calls to this routine to make ensure proper signal masking
- -- on targets needed that.
-
- null;
- end Setup_Interrupt_Mask;
-
-end System.Interrupt_Management.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
+-- --
+-- 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 --
+-- <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 a NO tasking version of this package
+
+package body System.Interrupt_Management.Operations is
+
+ -- Turn off warnings since many unused formals
+
+ pragma Warnings (Off);
+
+ ----------------------------
+ -- Thread_Block_Interrupt --
+ ----------------------------
+
+ procedure Thread_Block_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ begin
+ null;
+ end Thread_Block_Interrupt;
+
+ ------------------------------
+ -- Thread_Unblock_Interrupt --
+ ------------------------------
+
+ procedure Thread_Unblock_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ begin
+ null;
+ end Thread_Unblock_Interrupt;
+
+ ------------------------
+ -- Set_Interrupt_Mask --
+ ------------------------
+
+ procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Set_Interrupt_Mask;
+
+ procedure Set_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ OMask : access Interrupt_Mask) is
+ begin
+ null;
+ end Set_Interrupt_Mask;
+
+ ------------------------
+ -- Get_Interrupt_Mask --
+ ------------------------
+
+ procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Get_Interrupt_Mask;
+
+ --------------------
+ -- Interrupt_Wait --
+ --------------------
+
+ function Interrupt_Wait
+ (Mask : access Interrupt_Mask)
+ return Interrupt_ID
+ is
+ begin
+ return 0;
+ end Interrupt_Wait;
+
+ ----------------------------
+ -- Install_Default_Action --
+ ----------------------------
+
+ procedure Install_Default_Action (Interrupt : Interrupt_ID) is
+ begin
+ null;
+ end Install_Default_Action;
+
+ ---------------------------
+ -- Install_Ignore_Action --
+ ---------------------------
+
+ procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
+ begin
+ null;
+ end Install_Ignore_Action;
+
+ -------------------------
+ -- Fill_Interrupt_Mask --
+ -------------------------
+
+ procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Fill_Interrupt_Mask;
+
+ --------------------------
+ -- Empty_Interrupt_Mask --
+ --------------------------
+
+ procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Empty_Interrupt_Mask;
+
+ ---------------------------
+ -- Add_To_Interrupt_Mask --
+ ---------------------------
+
+ procedure Add_To_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ begin
+ null;
+ end Add_To_Interrupt_Mask;
+
+ --------------------------------
+ -- Delete_From_Interrupt_Mask --
+ --------------------------------
+
+ procedure Delete_From_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ begin
+ null;
+ end Delete_From_Interrupt_Mask;
+
+ ---------------
+ -- Is_Member --
+ ---------------
+
+ function Is_Member
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID) return Boolean
+ is
+ begin
+ return False;
+ end Is_Member;
+
+ -------------------------
+ -- Copy_Interrupt_Mask --
+ -------------------------
+
+ procedure Copy_Interrupt_Mask
+ (X : out Interrupt_Mask;
+ Y : Interrupt_Mask)
+ is
+ begin
+ X := Y;
+ end Copy_Interrupt_Mask;
+
+ -------------------------
+ -- Interrupt_Self_Process --
+ -------------------------
+
+ procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
+ begin
+ null;
+ end Interrupt_Self_Process;
+
+ --------------------------
+ -- Setup_Interrupt_Mask --
+ --------------------------
+
+ procedure Setup_Interrupt_Mask is
+ begin
+ null;
+ end Setup_Interrupt_Mask;
+
+end System.Interrupt_Management.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-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- --
+-- 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 a POSIX-like version of this package
+
+-- Note: this file can only be used for POSIX compliant systems
+
+with Interfaces.C;
+
+with System.OS_Interface;
+with System.Storage_Elements;
+
+package body System.Interrupt_Management.Operations is
+
+ use Interfaces.C;
+ use System.OS_Interface;
+
+ ---------------------
+ -- Local Variables --
+ ---------------------
+
+ Initial_Action : array (Signal) of aliased struct_sigaction;
+
+ Default_Action : aliased struct_sigaction;
+ pragma Warnings (Off, Default_Action);
+
+ Ignore_Action : aliased struct_sigaction;
+
+ ----------------------------
+ -- Thread_Block_Interrupt --
+ ----------------------------
+
+ procedure Thread_Block_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ Result : Interfaces.C.int;
+ Mask : aliased sigset_t;
+ begin
+ Result := sigemptyset (Mask'Access);
+ pragma Assert (Result = 0);
+ Result := sigaddset (Mask'Access, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ Result := pthread_sigmask (SIG_BLOCK, Mask'Access, null);
+ pragma Assert (Result = 0);
+ end Thread_Block_Interrupt;
+
+ ------------------------------
+ -- Thread_Unblock_Interrupt --
+ ------------------------------
+
+ procedure Thread_Unblock_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ Mask : aliased sigset_t;
+ Result : Interfaces.C.int;
+ begin
+ Result := sigemptyset (Mask'Access);
+ pragma Assert (Result = 0);
+ Result := sigaddset (Mask'Access, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ Result := pthread_sigmask (SIG_UNBLOCK, Mask'Access, null);
+ pragma Assert (Result = 0);
+ end Thread_Unblock_Interrupt;
+
+ ------------------------
+ -- Set_Interrupt_Mask --
+ ------------------------
+
+ procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_sigmask (SIG_SETMASK, Mask, null);
+ pragma Assert (Result = 0);
+ end Set_Interrupt_Mask;
+
+ procedure Set_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ OMask : access Interrupt_Mask)
+ is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_sigmask (SIG_SETMASK, Mask, OMask);
+ pragma Assert (Result = 0);
+ end Set_Interrupt_Mask;
+
+ ------------------------
+ -- Get_Interrupt_Mask --
+ ------------------------
+
+ procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_sigmask (SIG_SETMASK, null, Mask);
+ pragma Assert (Result = 0);
+ end Get_Interrupt_Mask;
+
+ --------------------
+ -- Interrupt_Wait --
+ --------------------
+
+ function Interrupt_Wait
+ (Mask : access Interrupt_Mask) return Interrupt_ID
+ is
+ Result : Interfaces.C.int;
+ Sig : aliased Signal;
+
+ begin
+ Result := sigwait (Mask, Sig'Access);
+
+ if Result /= 0 then
+ return 0;
+ end if;
+
+ return Interrupt_ID (Sig);
+ end Interrupt_Wait;
+
+ ----------------------------
+ -- Install_Default_Action --
+ ----------------------------
+
+ procedure Install_Default_Action (Interrupt : Interrupt_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigaction
+ (Signal (Interrupt),
+ Initial_Action (Signal (Interrupt))'Access, null);
+ pragma Assert (Result = 0);
+ end Install_Default_Action;
+
+ ---------------------------
+ -- Install_Ignore_Action --
+ ---------------------------
+
+ procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
+ pragma Assert (Result = 0);
+ end Install_Ignore_Action;
+
+ -------------------------
+ -- Fill_Interrupt_Mask --
+ -------------------------
+
+ procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigfillset (Mask);
+ pragma Assert (Result = 0);
+ end Fill_Interrupt_Mask;
+
+ --------------------------
+ -- Empty_Interrupt_Mask --
+ --------------------------
+
+ procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigemptyset (Mask);
+ pragma Assert (Result = 0);
+ end Empty_Interrupt_Mask;
+
+ ---------------------------
+ -- Add_To_Interrupt_Mask --
+ ---------------------------
+
+ procedure Add_To_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigaddset (Mask, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ end Add_To_Interrupt_Mask;
+
+ --------------------------------
+ -- Delete_From_Interrupt_Mask --
+ --------------------------------
+
+ procedure Delete_From_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigdelset (Mask, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ end Delete_From_Interrupt_Mask;
+
+ ---------------
+ -- Is_Member --
+ ---------------
+
+ function Is_Member
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID) return Boolean
+ is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigismember (Mask, Signal (Interrupt));
+ pragma Assert (Result = 0 or else Result = 1);
+ return Result = 1;
+ end Is_Member;
+
+ -------------------------
+ -- Copy_Interrupt_Mask --
+ -------------------------
+
+ procedure Copy_Interrupt_Mask
+ (X : out Interrupt_Mask;
+ Y : Interrupt_Mask) is
+ begin
+ X := Y;
+ end Copy_Interrupt_Mask;
+
+ ----------------------------
+ -- Interrupt_Self_Process --
+ ----------------------------
+
+ procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := kill (getpid, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ end Interrupt_Self_Process;
+
+ --------------------------
+ -- Setup_Interrupt_Mask --
+ --------------------------
+
+ procedure Setup_Interrupt_Mask is
+ begin
+ -- Mask task for all signals. The original mask of the Environment task
+ -- will be recovered by Interrupt_Manager task during the elaboration
+ -- of s-interr.adb.
+
+ Set_Interrupt_Mask (All_Tasks_Mask'Access);
+ end Setup_Interrupt_Mask;
+
+begin
+ declare
+ mask : aliased sigset_t;
+ allmask : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ begin
+ Interrupt_Management.Initialize;
+
+ for Sig in 1 .. Signal'Last loop
+ Result := sigaction
+ (Sig, null, Initial_Action (Sig)'Access);
+
+ -- ??? [assert 1]
+ -- we can't check Result here since sigaction will fail on
+ -- SIGKILL, SIGSTOP, and possibly other signals
+ -- pragma Assert (Result = 0);
+
+ end loop;
+
+ -- Setup the masks to be exported
+
+ Result := sigemptyset (mask'Access);
+ pragma Assert (Result = 0);
+
+ Result := sigfillset (allmask'Access);
+ pragma Assert (Result = 0);
+
+ Default_Action.sa_flags := 0;
+ Default_Action.sa_mask := mask;
+ Default_Action.sa_handler :=
+ Storage_Elements.To_Address
+ (Storage_Elements.Integer_Address (SIG_DFL));
+
+ Ignore_Action.sa_flags := 0;
+ Ignore_Action.sa_mask := mask;
+ Ignore_Action.sa_handler :=
+ Storage_Elements.To_Address
+ (Storage_Elements.Integer_Address (SIG_IGN));
+
+ for J in Interrupt_ID loop
+ if Keep_Unmasked (J) then
+ Result := sigaddset (mask'Access, Signal (J));
+ pragma Assert (Result = 0);
+ Result := sigdelset (allmask'Access, Signal (J));
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ -- The Keep_Unmasked signals should be unmasked for Environment task
+
+ Result := pthread_sigmask (SIG_UNBLOCK, mask'Access, null);
+ pragma Assert (Result = 0);
+
+ -- Get the signal mask of the Environment Task
+
+ Result := pthread_sigmask (SIG_SETMASK, null, mask'Access);
+ pragma Assert (Result = 0);
+
+ -- Setup the constants exported
+
+ Environment_Mask := Interrupt_Mask (mask);
+
+ All_Tasks_Mask := Interrupt_Mask (allmask);
+ end;
+
+end System.Interrupt_Management.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-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- --
+-- 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 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.
+
+with Ada.Exceptions;
+
+with Interfaces.C;
+
+with System.OS_Interface;
+
+package body System.Interrupt_Management.Operations is
+
+ use Ada.Exceptions;
+ use Interfaces.C;
+ use System.OS_Interface;
+
+ ----------------------------
+ -- Thread_Block_Interrupt --
+ ----------------------------
+
+ procedure Thread_Block_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ pragma Unreferenced (Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Thread_Block_Interrupt unimplemented");
+ end Thread_Block_Interrupt;
+
+ ------------------------------
+ -- Thread_Unblock_Interrupt --
+ ------------------------------
+
+ procedure Thread_Unblock_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ pragma Unreferenced (Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Thread_Unblock_Interrupt unimplemented");
+ end Thread_Unblock_Interrupt;
+
+ ------------------------
+ -- Set_Interrupt_Mask --
+ ------------------------
+
+ procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ pragma Unreferenced (Mask);
+ begin
+ null;
+ end Set_Interrupt_Mask;
+
+ procedure Set_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ OMask : access Interrupt_Mask)
+ is
+ pragma Unreferenced (Mask, OMask);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Set_Interrupt_Mask unimplemented");
+ end Set_Interrupt_Mask;
+
+ ------------------------
+ -- Get_Interrupt_Mask --
+ ------------------------
+
+ procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ pragma Unreferenced (Mask);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Get_Interrupt_Mask unimplemented");
+ end Get_Interrupt_Mask;
+
+ --------------------
+ -- Interrupt_Wait --
+ --------------------
+
+ function Interrupt_Wait
+ (Mask : access Interrupt_Mask) return Interrupt_ID
+ is
+ pragma Unreferenced (Mask);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Interrupt_Wait unimplemented");
+ return 0;
+ end Interrupt_Wait;
+
+ ----------------------------
+ -- Install_Default_Action --
+ ----------------------------
+
+ procedure Install_Default_Action (Interrupt : Interrupt_ID) is
+ pragma Unreferenced (Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Install_Default_Action unimplemented");
+ end Install_Default_Action;
+
+ ---------------------------
+ -- Install_Ignore_Action --
+ ---------------------------
+
+ procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
+ pragma Unreferenced (Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Install_Ignore_Action unimplemented");
+ end Install_Ignore_Action;
+
+ -------------------------
+ -- Fill_Interrupt_Mask --
+ -------------------------
+
+ procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ pragma Unreferenced (Mask);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Fill_Interrupt_Mask unimplemented");
+ end Fill_Interrupt_Mask;
+
+ --------------------------
+ -- Empty_Interrupt_Mask --
+ --------------------------
+
+ procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ pragma Unreferenced (Mask);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Empty_Interrupt_Mask unimplemented");
+ end Empty_Interrupt_Mask;
+
+ ---------------------------
+ -- Add_To_Interrupt_Mask --
+ ---------------------------
+
+ procedure Add_To_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ pragma Unreferenced (Mask, Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Add_To_Interrupt_Mask unimplemented");
+ end Add_To_Interrupt_Mask;
+
+ --------------------------------
+ -- Delete_From_Interrupt_Mask --
+ --------------------------------
+
+ procedure Delete_From_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ pragma Unreferenced (Mask, Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Delete_From_Interrupt_Mask unimplemented");
+ end Delete_From_Interrupt_Mask;
+
+ ---------------
+ -- Is_Member --
+ ---------------
+
+ function Is_Member
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID) return Boolean
+ is
+ pragma Unreferenced (Mask, Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Is_Member unimplemented");
+ return False;
+ end Is_Member;
+
+ -------------------------
+ -- Copy_Interrupt_Mask --
+ -------------------------
+
+ procedure Copy_Interrupt_Mask
+ (X : out Interrupt_Mask;
+ Y : Interrupt_Mask) is
+ pragma Unreferenced (X, Y);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Copy_Interrupt_Mask unimplemented");
+ end Copy_Interrupt_Mask;
+
+ ----------------------------
+ -- Interrupt_Self_Process --
+ ----------------------------
+
+ procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := kill (getpid, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ end Interrupt_Self_Process;
+
+ --------------------------
+ -- Setup_Interrupt_Mask --
+ --------------------------
+
+ procedure Setup_Interrupt_Mask is
+ begin
+ -- Nothing to be done. Ada interrupt facilities on VxWorks do not use
+ -- signals but hardware interrupts. Therefore, interrupt management does
+ -- not need anything related to signal masking. Note that this procedure
+ -- cannot raise an exception (as some others in this package) because
+ -- the generic implementation of the Timer_Server and timing events make
+ -- explicit calls to this routine to make ensure proper signal masking
+ -- on targets needed that.
+
+ null;
+ end Setup_Interrupt_Mask;
+
+end System.Interrupt_Management.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-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- --
--- 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 version is for systems that do not support interrupts (or signals)
-
-package body System.Interrupts is
-
- pragma Warnings (Off); -- kill warnings on unreferenced formals
-
- use System.Tasking;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Unimplemented;
- -- This procedure raises a Program_Error with an appropriate message
- -- indicating that an unimplemented feature has been used.
-
- --------------------
- -- Attach_Handler --
- --------------------
-
- procedure Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Unimplemented;
- end Attach_Handler;
-
- -----------------------------
- -- Bind_Interrupt_To_Entry --
- -----------------------------
-
- procedure Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Int_Ref : System.Address)
- is
- begin
- Unimplemented;
- end Bind_Interrupt_To_Entry;
-
- ---------------------
- -- Block_Interrupt --
- ---------------------
-
- procedure Block_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented;
- end Block_Interrupt;
-
- ---------------------
- -- Current_Handler --
- ---------------------
-
- function Current_Handler
- (Interrupt : Interrupt_ID) return Parameterless_Handler
- is
- begin
- Unimplemented;
- return null;
- end Current_Handler;
-
- --------------------
- -- Detach_Handler --
- --------------------
-
- procedure Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Unimplemented;
- end Detach_Handler;
-
- ------------------------------
- -- Detach_Interrupt_Entries --
- ------------------------------
-
- procedure Detach_Interrupt_Entries (T : Task_Id) is
- begin
- Unimplemented;
- end Detach_Interrupt_Entries;
-
- ----------------------
- -- Exchange_Handler --
- ----------------------
-
- procedure Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Old_Handler := null;
- Unimplemented;
- end Exchange_Handler;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Object : in out Static_Interrupt_Protection) is
- begin
- Unimplemented;
- end Finalize;
-
- -------------------------------------
- -- Has_Interrupt_Or_Attach_Handler --
- -------------------------------------
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection)
- return Boolean
- is
- pragma Warnings (Off, Object);
- begin
- Unimplemented;
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection)
- return Boolean
- is
- pragma Warnings (Off, Object);
- begin
- Unimplemented;
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- ----------------------
- -- Ignore_Interrupt --
- ----------------------
-
- procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented;
- end Ignore_Interrupt;
-
- ----------------------
- -- Install_Handlers --
- ----------------------
-
- procedure Install_Handlers
- (Object : access Static_Interrupt_Protection;
- New_Handlers : New_Handler_Array)
- is
- begin
- Unimplemented;
- end Install_Handlers;
-
- ---------------------------------
- -- Install_Restricted_Handlers --
- ---------------------------------
-
- procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
- Handlers : New_Handler_Array)
- is
- begin
- Unimplemented;
- end Install_Restricted_Handlers;
-
- ----------------
- -- Is_Blocked --
- ----------------
-
- function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented;
- return True;
- end Is_Blocked;
-
- -----------------------
- -- Is_Entry_Attached --
- -----------------------
-
- function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented;
- return True;
- end Is_Entry_Attached;
-
- -------------------------
- -- Is_Handler_Attached --
- -------------------------
-
- function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented;
- return True;
- end Is_Handler_Attached;
-
- ----------------
- -- Is_Ignored --
- ----------------
-
- function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented;
- return True;
- end Is_Ignored;
-
- -----------------
- -- Is_Reserved --
- -----------------
-
- function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented;
- return True;
- end Is_Reserved;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference (Interrupt : Interrupt_ID) return System.Address is
- begin
- Unimplemented;
- return Interrupt'Address;
- end Reference;
-
- --------------------------------
- -- Register_Interrupt_Handler --
- --------------------------------
-
- procedure Register_Interrupt_Handler
- (Handler_Addr : System.Address)
- is
- begin
- Unimplemented;
- end Register_Interrupt_Handler;
-
- -----------------------
- -- Unblock_Interrupt --
- -----------------------
-
- procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented;
- end Unblock_Interrupt;
-
- ------------------
- -- Unblocked_By --
- ------------------
-
- function Unblocked_By (Interrupt : Interrupt_ID)
- return System.Tasking.Task_Id is
- begin
- Unimplemented;
- return null;
- end Unblocked_By;
-
- ------------------------
- -- Unignore_Interrupt --
- ------------------------
-
- procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented;
- end Unignore_Interrupt;
-
- -------------------
- -- Unimplemented; --
- -------------------
-
- procedure Unimplemented is
- begin
- raise Program_Error with "interrupts/signals not implemented";
- end Unimplemented;
-
-end System.Interrupts;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2014, 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. --
--- --
-------------------------------------------------------------------------------
-
--- 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.
-
--- 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).
-
--- 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.
-
--- 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,
--- we use the per-task lock of the Server_Task instead so that we protect the
--- 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;
-
-with Interfaces.C; use Interfaces.C;
-with System.OS_Interface; use System.OS_Interface;
-with System.Interrupt_Management;
-with System.Task_Primitives.Operations;
-with System.Storage_Elements;
-with System.Tasking.Utilities;
-
-with System.Tasking.Rendezvous;
-pragma Elaborate_All (System.Tasking.Rendezvous);
-
-package body System.Interrupts is
-
- use Tasking;
-
- package POP renames System.Task_Primitives.Operations;
-
- function To_Ada is new Ada.Unchecked_Conversion
- (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id);
-
- function To_System is new Ada.Unchecked_Conversion
- (Ada.Task_Identification.Task_Id, Task_Id);
-
- -----------------
- -- Local Tasks --
- -----------------
-
- -- WARNING: System.Tasking.Stages performs calls to this task with low-
- -- level constructs. Do not change this spec without synchronizing it.
-
- task Interrupt_Manager is
- entry Detach_Interrupt_Entries (T : Task_Id);
-
- entry Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False);
-
- entry Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean);
-
- entry Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean);
-
- entry Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Interrupt : Interrupt_ID);
-
- pragma Interrupt_Priority (System.Interrupt_Priority'First);
- end Interrupt_Manager;
-
- task type Interrupt_Server_Task
- (Interrupt : Interrupt_ID;
- Int_Sema : Binary_Semaphore_Id)
- is
- -- Server task for vectored hardware interrupt handling
-
- pragma Interrupt_Priority (System.Interrupt_Priority'First + 2);
- end Interrupt_Server_Task;
-
- type Interrupt_Task_Access is access Interrupt_Server_Task;
-
- -------------------------------
- -- Local Types and Variables --
- -------------------------------
-
- type Entry_Assoc is record
- T : Task_Id;
- E : Task_Entry_Index;
- end record;
-
- type Handler_Assoc is record
- H : Parameterless_Handler;
- Static : Boolean; -- Indicates static binding;
- end record;
-
- User_Handler : array (Interrupt_ID) of Handler_Assoc :=
- (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
- -- 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
-
- -- Type and Head, Tail of the list containing Registered Interrupt
- -- Handlers. These definitions are used to register the handlers
- -- specified by the pragma Interrupt_Handler.
-
- type Registered_Handler;
- type R_Link is access all Registered_Handler;
-
- type Registered_Handler is record
- H : System.Address := System.Null_Address;
- Next : R_Link := null;
- end record;
-
- Registered_Handler_Head : R_Link := null;
- Registered_Handler_Tail : R_Link := null;
-
- Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id :=
- (others => System.Tasking.Null_Task);
- pragma Atomic_Components (Server_ID);
- -- Holds the Task_Id of the Server_Task for each interrupt / signal.
- -- Task_Id is needed to accomplish locking per interrupt base. Also
- -- is needed to determine whether to create a new Server_Task.
-
- Semaphore_ID_Map : array
- (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) of
- Binary_Semaphore_Id := (others => 0);
- -- Array of binary semaphores associated with vectored interrupts. Note
- -- that the last bound should be Max_HW_Interrupt, but this will raise
- -- Storage_Error if Num_HW_Interrupts is null so use extra 4 bytes instead.
-
- Interrupt_Access_Hold : Interrupt_Task_Access;
- -- Variable for allocating an Interrupt_Server_Task
-
- Handler_Installed : array (HW_Interrupt) of Boolean := (others => False);
- -- True if Notify_Interrupt was connected to the interrupt. Handlers can
- -- be connected but disconnection is not possible on VxWorks. Therefore
- -- we ensure Notify_Installed is connected at most once.
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID);
- -- Check if Id is a reserved interrupt, and if so raise Program_Error
- -- with an appropriate message, otherwise return.
-
- procedure Finalize_Interrupt_Servers;
- -- Unbind the handlers for hardware interrupt server tasks at program
- -- termination.
-
- function Is_Registered (Handler : Parameterless_Handler) return Boolean;
- -- See if Handler has been "pragma"ed using Interrupt_Handler.
- -- Always consider a null handler as registered.
-
- procedure Notify_Interrupt (Param : System.Address);
- pragma Convention (C, Notify_Interrupt);
- -- Umbrella handler for vectored interrupts (not signals)
-
- procedure Install_Umbrella_Handler
- (Interrupt : HW_Interrupt;
- Handler : System.OS_Interface.Interrupt_Handler);
- -- Install the runtime umbrella handler for a vectored hardware
- -- interrupt
-
- procedure Unimplemented (Feature : String);
- pragma No_Return (Unimplemented);
- -- Used to mark a call to an unimplemented function. Raises Program_Error
- -- with an appropriate message noting that Feature is unimplemented.
-
- --------------------
- -- Attach_Handler --
- --------------------
-
- -- Calling this procedure with New_Handler = null and Static = True
- -- means we want to detach the current handler regardless of the previous
- -- handler's binding status (i.e. do not care if it is a dynamic or static
- -- handler).
-
- -- This option is needed so that during the finalization of a PO, we can
- -- detach handlers attached through pragma Attach_Handler.
-
- procedure Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False) is
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
- end Attach_Handler;
-
- -----------------------------
- -- Bind_Interrupt_To_Entry --
- -----------------------------
-
- -- This procedure raises a Program_Error if it tries to
- -- bind an interrupt to which an Entry or a Procedure is
- -- already bound.
-
- procedure Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Int_Ref : System.Address)
- is
- Interrupt : constant Interrupt_ID :=
- Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
- end Bind_Interrupt_To_Entry;
-
- ---------------------
- -- Block_Interrupt --
- ---------------------
-
- procedure Block_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Block_Interrupt");
- end Block_Interrupt;
-
- ------------------------------
- -- Check_Reserved_Interrupt --
- ------------------------------
-
- procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error with
- "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
- else
- return;
- end if;
- end Check_Reserved_Interrupt;
-
- ---------------------
- -- Current_Handler --
- ---------------------
-
- function Current_Handler
- (Interrupt : Interrupt_ID) return Parameterless_Handler
- is
- begin
- Check_Reserved_Interrupt (Interrupt);
-
- -- ??? Since Parameterless_Handler is not Atomic, the current
- -- implementation is wrong. We need a new service in Interrupt_Manager
- -- to ensure atomicity.
-
- return User_Handler (Interrupt).H;
- end Current_Handler;
-
- --------------------
- -- Detach_Handler --
- --------------------
-
- -- Calling this procedure with Static = True means we want to Detach the
- -- current handler regardless of the previous handler's binding status
- -- (i.e. do not care if it is a dynamic or static handler).
-
- -- This option is needed so that during the finalization of a PO, we can
- -- detach handlers attached through pragma Attach_Handler.
-
- procedure Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Detach_Handler (Interrupt, Static);
- end Detach_Handler;
-
- ------------------------------
- -- Detach_Interrupt_Entries --
- ------------------------------
-
- procedure Detach_Interrupt_Entries (T : Task_Id) is
- begin
- Interrupt_Manager.Detach_Interrupt_Entries (T);
- end Detach_Interrupt_Entries;
-
- ----------------------
- -- Exchange_Handler --
- ----------------------
-
- -- Calling this procedure with New_Handler = null and Static = True
- -- means we want to detach the current handler regardless of the previous
- -- handler's binding status (i.e. we do not care if it is a dynamic or
- -- static handler).
-
- -- This option is needed so that during the finalization of a PO, we can
- -- detach handlers attached through pragma Attach_Handler.
-
- procedure Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Exchange_Handler
- (Old_Handler, New_Handler, Interrupt, Static);
- end Exchange_Handler;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Object : in out Static_Interrupt_Protection) is
- begin
- -- ??? loop to be executed only when we're not doing library level
- -- finalization, since in this case all interrupt / signal tasks are
- -- gone.
-
- if not Interrupt_Manager'Terminated then
- for N in reverse Object.Previous_Handlers'Range loop
- Interrupt_Manager.Attach_Handler
- (New_Handler => Object.Previous_Handlers (N).Handler,
- Interrupt => Object.Previous_Handlers (N).Interrupt,
- Static => Object.Previous_Handlers (N).Static,
- Restoration => True);
- end loop;
- end if;
-
- Tasking.Protected_Objects.Entries.Finalize
- (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
- end Finalize;
-
- --------------------------------
- -- Finalize_Interrupt_Servers --
- --------------------------------
-
- -- Restore default handlers for interrupt servers
-
- -- This is called by the Interrupt_Manager task when it receives the abort
- -- signal during program finalization.
-
- procedure Finalize_Interrupt_Servers is
- HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
- begin
- if HW_Interrupts then
- for Int in HW_Interrupt loop
- if Server_ID (Interrupt_ID (Int)) /= null
- and then
- not Ada.Task_Identification.Is_Terminated
- (To_Ada (Server_ID (Interrupt_ID (Int))))
- then
- Interrupt_Manager.Attach_Handler
- (New_Handler => null,
- Interrupt => Interrupt_ID (Int),
- Static => True,
- Restoration => True);
- end if;
- end loop;
- end if;
- end Finalize_Interrupt_Servers;
-
- -------------------------------------
- -- Has_Interrupt_Or_Attach_Handler --
- -------------------------------------
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection)
- return Boolean
- is
- pragma Unreferenced (Object);
- begin
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection)
- return Boolean
- is
- pragma Unreferenced (Object);
- begin
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- ----------------------
- -- Ignore_Interrupt --
- ----------------------
-
- procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Ignore_Interrupt");
- end Ignore_Interrupt;
-
- ----------------------
- -- Install_Handlers --
- ----------------------
-
- procedure Install_Handlers
- (Object : access Static_Interrupt_Protection;
- New_Handlers : New_Handler_Array)
- is
- begin
- for N in New_Handlers'Range loop
-
- -- We need a lock around this ???
-
- Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
- Object.Previous_Handlers (N).Static := User_Handler
- (New_Handlers (N).Interrupt).Static;
-
- -- We call Exchange_Handler and not directly Interrupt_Manager.
- -- Exchange_Handler so we get the Is_Reserved check.
-
- Exchange_Handler
- (Old_Handler => Object.Previous_Handlers (N).Handler,
- New_Handler => New_Handlers (N).Handler,
- Interrupt => New_Handlers (N).Interrupt,
- Static => True);
- end loop;
- end Install_Handlers;
-
- ---------------------------------
- -- Install_Restricted_Handlers --
- ---------------------------------
-
- procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
- Handlers : New_Handler_Array)
- is
- pragma Unreferenced (Prio);
- begin
- for N in Handlers'Range loop
- Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
- end loop;
- end Install_Restricted_Handlers;
-
- ------------------------------
- -- Install_Umbrella_Handler --
- ------------------------------
-
- procedure Install_Umbrella_Handler
- (Interrupt : HW_Interrupt;
- Handler : System.OS_Interface.Interrupt_Handler)
- is
- Vec : constant Interrupt_Vector :=
- Interrupt_Number_To_Vector (int (Interrupt));
-
- Status : int;
-
- begin
- -- Only install umbrella handler when no Ada handler has already been
- -- installed. Note that the interrupt number is passed as a parameter
- -- when an interrupt occurs, so the umbrella handler has a different
- -- wrapper generated by intConnect for each interrupt number.
-
- if not Handler_Installed (Interrupt) then
- Status :=
- Interrupt_Connect (Vec, Handler, System.Address (Interrupt));
- pragma Assert (Status = 0);
-
- Handler_Installed (Interrupt) := True;
- end if;
- end Install_Umbrella_Handler;
-
- ----------------
- -- Is_Blocked --
- ----------------
-
- function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented ("Is_Blocked");
- return False;
- end Is_Blocked;
-
- -----------------------
- -- Is_Entry_Attached --
- -----------------------
-
- function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- Check_Reserved_Interrupt (Interrupt);
- return User_Entry (Interrupt).T /= Null_Task;
- end Is_Entry_Attached;
-
- -------------------------
- -- Is_Handler_Attached --
- -------------------------
-
- function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- Check_Reserved_Interrupt (Interrupt);
- return User_Handler (Interrupt).H /= null;
- end Is_Handler_Attached;
-
- ----------------
- -- Is_Ignored --
- ----------------
-
- function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented ("Is_Ignored");
- return False;
- end Is_Ignored;
-
- -------------------
- -- Is_Registered --
- -------------------
-
- function Is_Registered (Handler : Parameterless_Handler) return Boolean is
- type Fat_Ptr is record
- Object_Addr : System.Address;
- Handler_Addr : System.Address;
- end record;
-
- function To_Fat_Ptr is new Ada.Unchecked_Conversion
- (Parameterless_Handler, Fat_Ptr);
-
- Ptr : R_Link;
- Fat : Fat_Ptr;
-
- begin
- if Handler = null then
- return True;
- end if;
-
- Fat := To_Fat_Ptr (Handler);
-
- Ptr := Registered_Handler_Head;
- while Ptr /= null loop
- if Ptr.H = Fat.Handler_Addr then
- return True;
- end if;
-
- Ptr := Ptr.Next;
- end loop;
-
- return False;
- end Is_Registered;
-
- -----------------
- -- Is_Reserved --
- -----------------
-
- function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
- use System.Interrupt_Management;
- begin
- return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt));
- end Is_Reserved;
-
- ----------------------
- -- Notify_Interrupt --
- ----------------------
-
- -- Umbrella handler for vectored hardware interrupts (as opposed to signals
- -- and exceptions). As opposed to the signal implementation, this handler
- -- is installed in the vector table when the first Ada handler is attached
- -- to the interrupt. However because VxWorks don't support disconnecting
- -- handlers, this subprogram always test whether or not an Ada handler is
- -- effectively attached.
-
- -- Otherwise, the handler that existed prior to program startup is in the
- -- vector table. This ensures that handlers installed by the BSP are active
- -- unless explicitly replaced in the program text.
-
- -- Each Interrupt_Server_Task has an associated binary semaphore on which
- -- it pends once it's been started. This routine determines The appropriate
- -- semaphore and issues a semGive call, waking the server task. When
- -- a handler is unbound, System.Interrupts.Unbind_Handler issues a
- -- Binary_Semaphore_Flush, and the server task deletes its semaphore
- -- and terminates.
-
- procedure Notify_Interrupt (Param : System.Address) is
- Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
- Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt);
- Status : int;
- begin
- if Id /= 0 then
- Status := Binary_Semaphore_Release (Id);
- pragma Assert (Status = 0);
- end if;
- end Notify_Interrupt;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference (Interrupt : Interrupt_ID) return System.Address is
- begin
- Check_Reserved_Interrupt (Interrupt);
- return Storage_Elements.To_Address
- (Storage_Elements.Integer_Address (Interrupt));
- end Reference;
-
- --------------------------------
- -- Register_Interrupt_Handler --
- --------------------------------
-
- procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
- New_Node_Ptr : R_Link;
-
- begin
- -- This routine registers a handler as usable for dynamic interrupt
- -- handler association. Routines attaching and detaching handlers
- -- dynamically should determine whether the handler is registered.
- -- Program_Error should be raised if it is not registered.
-
- -- Pragma Interrupt_Handler can only appear in a library level PO
- -- definition and instantiation. Therefore, we do not need to implement
- -- an unregister operation. Nor do we need to protect the queue
- -- structure with a lock.
-
- pragma Assert (Handler_Addr /= System.Null_Address);
-
- New_Node_Ptr := new Registered_Handler;
- New_Node_Ptr.H := Handler_Addr;
-
- if Registered_Handler_Head = null then
- Registered_Handler_Head := New_Node_Ptr;
- Registered_Handler_Tail := New_Node_Ptr;
- else
- Registered_Handler_Tail.Next := New_Node_Ptr;
- Registered_Handler_Tail := New_Node_Ptr;
- end if;
- end Register_Interrupt_Handler;
-
- -----------------------
- -- Unblock_Interrupt --
- -----------------------
-
- procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Unblock_Interrupt");
- end Unblock_Interrupt;
-
- ------------------
- -- Unblocked_By --
- ------------------
-
- function Unblocked_By
- (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
- is
- begin
- Unimplemented ("Unblocked_By");
- return Null_Task;
- end Unblocked_By;
-
- ------------------------
- -- Unignore_Interrupt --
- ------------------------
-
- procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Unignore_Interrupt");
- end Unignore_Interrupt;
-
- -------------------
- -- Unimplemented --
- -------------------
-
- procedure Unimplemented (Feature : String) is
- begin
- raise Program_Error with Feature & " not implemented on VxWorks";
- end Unimplemented;
-
- -----------------------
- -- Interrupt_Manager --
- -----------------------
-
- task body Interrupt_Manager is
- -- By making this task independent of any master, when the process goes
- -- away, the Interrupt_Manager will terminate gracefully.
-
- Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
- pragma Unreferenced (Ignore);
-
- --------------------
- -- Local Routines --
- --------------------
-
- procedure Bind_Handler (Interrupt : Interrupt_ID);
- -- This procedure does not do anything if a signal is blocked.
- -- Otherwise, we have to interrupt Server_Task for status change
- -- through a wakeup signal.
-
- procedure Unbind_Handler (Interrupt : Interrupt_ID);
- -- This procedure does not do anything if a signal is blocked.
- -- Otherwise, we have to interrupt Server_Task for status change
- -- through an abort signal.
-
- procedure Unprotected_Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False);
-
- procedure Unprotected_Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean);
-
- ------------------
- -- Bind_Handler --
- ------------------
-
- procedure Bind_Handler (Interrupt : Interrupt_ID) is
- begin
- Install_Umbrella_Handler
- (HW_Interrupt (Interrupt), Notify_Interrupt'Access);
- end Bind_Handler;
-
- --------------------
- -- Unbind_Handler --
- --------------------
-
- procedure Unbind_Handler (Interrupt : Interrupt_ID) is
- Status : int;
-
- begin
- -- Flush server task off semaphore, allowing it to terminate
-
- Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt));
- pragma Assert (Status = 0);
- end Unbind_Handler;
-
- --------------------------------
- -- Unprotected_Detach_Handler --
- --------------------------------
-
- procedure Unprotected_Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean)
- is
- Old_Handler : Parameterless_Handler;
- begin
- if User_Entry (Interrupt).T /= Null_Task then
-
- -- If an interrupt entry is installed raise Program_Error
- -- (propagate it to the caller).
-
- raise Program_Error with
- "an interrupt entry is already installed";
- end if;
-
- -- Note : Static = True will pass the following check. This is the
- -- case when we want to detach a handler regardless of the static
- -- status of the Current_Handler.
-
- if not Static and then User_Handler (Interrupt).Static then
-
- -- Trying to detach a static Interrupt Handler, raise
- -- Program_Error.
-
- raise Program_Error with
- "trying to detach a static Interrupt Handler";
- end if;
-
- Old_Handler := User_Handler (Interrupt).H;
-
- -- The new handler
-
- User_Handler (Interrupt).H := null;
- User_Handler (Interrupt).Static := False;
-
- if Old_Handler /= null then
- Unbind_Handler (Interrupt);
- end if;
- end Unprotected_Detach_Handler;
-
- ----------------------------------
- -- Unprotected_Exchange_Handler --
- ----------------------------------
-
- procedure Unprotected_Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False)
- is
- begin
- if User_Entry (Interrupt).T /= Null_Task then
-
- -- If an interrupt entry is already installed, raise
- -- Program_Error (propagate it to the caller).
-
- raise Program_Error with "an interrupt is already installed";
- end if;
-
- -- Note : A null handler with Static = True will pass the following
- -- check. This is the case when we want to detach a handler
- -- regardless of the Static status of Current_Handler.
-
- -- We don't check anything if Restoration is True, since we may be
- -- detaching a static handler to restore a dynamic one.
-
- if not Restoration and then not Static
- and then (User_Handler (Interrupt).Static
-
- -- Trying to overwrite a static Interrupt Handler with a dynamic
- -- Handler
-
- -- The new handler is not specified as an Interrupt Handler by a
- -- pragma.
-
- or else not Is_Registered (New_Handler))
- then
- raise Program_Error with
- "trying to overwrite a static interrupt handler with a "
- & "dynamic handler";
- end if;
-
- -- Save the old handler
-
- Old_Handler := User_Handler (Interrupt).H;
-
- -- The new handler
-
- User_Handler (Interrupt).H := New_Handler;
-
- if New_Handler = null then
-
- -- The null handler means we are detaching the handler
-
- User_Handler (Interrupt).Static := False;
-
- else
- User_Handler (Interrupt).Static := Static;
- end if;
-
- -- Invoke a corresponding Server_Task if not yet created. Place
- -- Task_Id info in Server_ID array.
-
- if New_Handler /= null
- and then
- (Server_ID (Interrupt) = Null_Task
- or else
- Ada.Task_Identification.Is_Terminated
- (To_Ada (Server_ID (Interrupt))))
- then
- Interrupt_Access_Hold :=
- new Interrupt_Server_Task (Interrupt, Binary_Semaphore_Create);
- Server_ID (Interrupt) :=
- To_System (Interrupt_Access_Hold.all'Identity);
- end if;
-
- if (New_Handler = null) and then Old_Handler /= null then
-
- -- Restore default handler
-
- Unbind_Handler (Interrupt);
-
- elsif Old_Handler = null then
-
- -- Save default handler
-
- Bind_Handler (Interrupt);
- end if;
- end Unprotected_Exchange_Handler;
-
- -- Start of processing for Interrupt_Manager
-
- begin
- loop
- -- A block is needed to absorb Program_Error exception
-
- declare
- Old_Handler : Parameterless_Handler;
-
- begin
- select
- accept Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False)
- do
- Unprotected_Exchange_Handler
- (Old_Handler, New_Handler, Interrupt, Static, Restoration);
- end Attach_Handler;
-
- or
- accept Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean)
- do
- Unprotected_Exchange_Handler
- (Old_Handler, New_Handler, Interrupt, Static);
- end Exchange_Handler;
-
- or
- accept Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean)
- do
- Unprotected_Detach_Handler (Interrupt, Static);
- end Detach_Handler;
-
- or
- accept Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Interrupt : Interrupt_ID)
- do
- -- If there is a binding already (either a procedure or an
- -- entry), raise Program_Error (propagate it to the caller).
-
- if User_Handler (Interrupt).H /= null
- or else User_Entry (Interrupt).T /= Null_Task
- then
- raise Program_Error with
- "a binding for this interrupt is already present";
- end if;
-
- User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
-
- -- Indicate the attachment of interrupt entry in the ATCB.
- -- This is needed so when an interrupt entry task terminates
- -- the binding can be cleaned. The call to unbinding must be
- -- make by the task before it terminates.
-
- T.Interrupt_Entry := True;
-
- -- Invoke a corresponding Server_Task if not yet created.
- -- Place Task_Id info in Server_ID array.
-
- if Server_ID (Interrupt) = Null_Task
- or else
- Ada.Task_Identification.Is_Terminated
- (To_Ada (Server_ID (Interrupt)))
- then
- Interrupt_Access_Hold := new Interrupt_Server_Task
- (Interrupt, Binary_Semaphore_Create);
- Server_ID (Interrupt) :=
- To_System (Interrupt_Access_Hold.all'Identity);
- end if;
-
- Bind_Handler (Interrupt);
- end Bind_Interrupt_To_Entry;
-
- or
- accept Detach_Interrupt_Entries (T : Task_Id) do
- for Int in Interrupt_ID'Range loop
- if not Is_Reserved (Int) then
- if User_Entry (Int).T = T then
- User_Entry (Int) :=
- Entry_Assoc'
- (T => Null_Task, E => Null_Task_Entry);
- Unbind_Handler (Int);
- end if;
- end if;
- end loop;
-
- -- Indicate in ATCB that no interrupt entries are attached
-
- T.Interrupt_Entry := False;
- end Detach_Interrupt_Entries;
- end select;
-
- exception
- -- If there is a Program_Error we just want to propagate it to
- -- the caller and do not want to stop this task.
-
- when Program_Error =>
- null;
-
- when others =>
- pragma Assert (False);
- null;
- end;
- end loop;
-
- exception
- when Standard'Abort_Signal =>
-
- -- Flush interrupt server semaphores, so they can terminate
-
- Finalize_Interrupt_Servers;
- raise;
- end Interrupt_Manager;
-
- ---------------------------
- -- Interrupt_Server_Task --
- ---------------------------
-
- -- Server task for vectored hardware interrupt handling
-
- task body Interrupt_Server_Task is
- Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
-
- Self_Id : constant Task_Id := Self;
- Tmp_Handler : Parameterless_Handler;
- Tmp_ID : Task_Id;
- Tmp_Entry_Index : Task_Entry_Index;
- Status : int;
-
- begin
- Semaphore_ID_Map (Interrupt) := Int_Sema;
-
- loop
- -- Pend on semaphore that will be triggered by the umbrella handler
- -- when the associated interrupt comes in.
-
- Status := Binary_Semaphore_Obtain (Int_Sema);
- pragma Assert (Status = 0);
-
- if User_Handler (Interrupt).H /= null then
-
- -- Protected procedure handler
-
- Tmp_Handler := User_Handler (Interrupt).H;
- Tmp_Handler.all;
-
- elsif User_Entry (Interrupt).T /= Null_Task then
-
- -- Interrupt entry handler
-
- Tmp_ID := User_Entry (Interrupt).T;
- Tmp_Entry_Index := User_Entry (Interrupt).E;
- System.Tasking.Rendezvous.Call_Simple
- (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
-
- else
- -- Semaphore has been flushed by an unbind operation in the
- -- Interrupt_Manager. Terminate the server task.
-
- -- Wait for the Interrupt_Manager to complete its work
-
- POP.Write_Lock (Self_Id);
-
- -- Unassociate the interrupt handler
-
- Semaphore_ID_Map (Interrupt) := 0;
-
- -- Delete the associated semaphore
-
- Status := Binary_Semaphore_Delete (Int_Sema);
-
- pragma Assert (Status = 0);
-
- -- Set status for the Interrupt_Manager
-
- Server_ID (Interrupt) := Null_Task;
- POP.Unlock (Self_Id);
-
- exit;
- end if;
- end loop;
- end Interrupt_Server_Task;
-
-begin
- -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
-
- Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
-end System.Interrupts;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-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 --
--- <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 NT version of this package
-
-with Ada.Task_Identification;
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-with System.Storage_Elements;
-with System.Task_Primitives.Operations;
-with System.Tasking.Utilities;
-with System.Tasking.Rendezvous;
-with System.Tasking.Initialization;
-with System.Interrupt_Management;
-with System.Parameters;
-
-package body System.Interrupts is
-
- use Parameters;
- use Tasking;
- use System.OS_Interface;
- use Interfaces.C;
-
- package STPO renames System.Task_Primitives.Operations;
- package IMNG renames System.Interrupt_Management;
-
- subtype int is Interfaces.C.int;
-
- function To_System is new Ada.Unchecked_Conversion
- (Ada.Task_Identification.Task_Id, Task_Id);
-
- type Handler_Kind is (Unknown, Task_Entry, Protected_Procedure);
-
- type Handler_Desc is record
- Kind : Handler_Kind := Unknown;
- T : Task_Id;
- E : Task_Entry_Index;
- H : Parameterless_Handler;
- Static : Boolean := False;
- end record;
-
- task type Server_Task (Interrupt : Interrupt_ID) is
- pragma Interrupt_Priority (System.Interrupt_Priority'Last);
- end Server_Task;
-
- type Server_Task_Access is access Server_Task;
-
- Handlers : array (Interrupt_ID) of Task_Id;
- Descriptors : array (Interrupt_ID) of Handler_Desc;
- Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0);
-
- pragma Volatile_Components (Interrupt_Count);
-
- procedure Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean);
- -- This internal procedure is needed to finalize protected objects that
- -- contain interrupt handlers.
-
- procedure Signal_Handler (Sig : Interrupt_ID);
- pragma Convention (C, Signal_Handler);
- -- This procedure is used to handle all the signals
-
- -- Type and Head, Tail of the list containing Registered Interrupt
- -- Handlers. These definitions are used to register the handlers
- -- specified by the pragma Interrupt_Handler.
-
- --------------------------
- -- Handler Registration --
- --------------------------
-
- type Registered_Handler;
- type R_Link is access all Registered_Handler;
-
- type Registered_Handler is record
- H : System.Address := System.Null_Address;
- Next : R_Link := null;
- end record;
-
- Registered_Handlers : R_Link := null;
-
- function Is_Registered (Handler : Parameterless_Handler) return Boolean;
- -- See if the Handler has been "pragma"ed using Interrupt_Handler.
- -- Always consider a null handler as registered.
-
- type Handler_Ptr is access procedure (Sig : Interrupt_ID);
- pragma Convention (C, Handler_Ptr);
-
- function TISR is new Ada.Unchecked_Conversion (Handler_Ptr, isr_address);
-
- --------------------
- -- Signal_Handler --
- --------------------
-
- procedure Signal_Handler (Sig : Interrupt_ID) is
- Handler : Task_Id renames Handlers (Sig);
-
- begin
- if Intr_Attach_Reset and then
- intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR
- then
- raise Program_Error;
- end if;
-
- if Handler /= null then
- Interrupt_Count (Sig) := Interrupt_Count (Sig) + 1;
- STPO.Wakeup (Handler, Interrupt_Server_Idle_Sleep);
- end if;
- end Signal_Handler;
-
- -----------------
- -- Is_Reserved --
- -----------------
-
- function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
- begin
- return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
- end Is_Reserved;
-
- -----------------------
- -- Is_Entry_Attached --
- -----------------------
-
- function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error with
- "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
- end if;
-
- return Descriptors (Interrupt).T /= Null_Task;
- end Is_Entry_Attached;
-
- -------------------------
- -- Is_Handler_Attached --
- -------------------------
-
- function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error with
- "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
- else
- return Descriptors (Interrupt).Kind /= Unknown;
- end if;
- end Is_Handler_Attached;
-
- ----------------
- -- Is_Ignored --
- ----------------
-
- function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
- begin
- raise Program_Error;
- return False;
- end Is_Ignored;
-
- ------------------
- -- Unblocked_By --
- ------------------
-
- function Unblocked_By (Interrupt : Interrupt_ID) return Task_Id is
- begin
- raise Program_Error;
- return Null_Task;
- end Unblocked_By;
-
- ----------------------
- -- Ignore_Interrupt --
- ----------------------
-
- procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- raise Program_Error;
- end Ignore_Interrupt;
-
- ------------------------
- -- Unignore_Interrupt --
- ------------------------
-
- procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- raise Program_Error;
- end Unignore_Interrupt;
-
- -------------------------------------
- -- Has_Interrupt_Or_Attach_Handler --
- -------------------------------------
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection) return Boolean
- is
- pragma Unreferenced (Object);
- begin
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Object : in out Static_Interrupt_Protection) is
- begin
- -- ??? loop to be executed only when we're not doing library level
- -- finalization, since in this case all interrupt tasks are gone.
-
- for N in reverse Object.Previous_Handlers'Range loop
- Attach_Handler
- (New_Handler => Object.Previous_Handlers (N).Handler,
- Interrupt => Object.Previous_Handlers (N).Interrupt,
- Static => Object.Previous_Handlers (N).Static,
- Restoration => True);
- end loop;
-
- Tasking.Protected_Objects.Entries.Finalize
- (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
- end Finalize;
-
- -------------------------------------
- -- Has_Interrupt_Or_Attach_Handler --
- -------------------------------------
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection) return Boolean
- is
- pragma Unreferenced (Object);
- begin
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- ----------------------
- -- Install_Handlers --
- ----------------------
-
- procedure Install_Handlers
- (Object : access Static_Interrupt_Protection;
- New_Handlers : New_Handler_Array)
- is
- begin
- for N in New_Handlers'Range loop
-
- -- We need a lock around this ???
-
- Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
- Object.Previous_Handlers (N).Static := Descriptors
- (New_Handlers (N).Interrupt).Static;
-
- -- We call Exchange_Handler and not directly Interrupt_Manager.
- -- Exchange_Handler so we get the Is_Reserved check.
-
- Exchange_Handler
- (Old_Handler => Object.Previous_Handlers (N).Handler,
- New_Handler => New_Handlers (N).Handler,
- Interrupt => New_Handlers (N).Interrupt,
- Static => True);
- end loop;
- end Install_Handlers;
-
- ---------------------------------
- -- Install_Restricted_Handlers --
- ---------------------------------
-
- procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
- Handlers : New_Handler_Array)
- is
- pragma Unreferenced (Prio);
- begin
- for N in Handlers'Range loop
- Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
- end loop;
- end Install_Restricted_Handlers;
-
- ---------------------
- -- Current_Handler --
- ---------------------
-
- function Current_Handler
- (Interrupt : Interrupt_ID) return Parameterless_Handler
- is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error;
- end if;
-
- if Descriptors (Interrupt).Kind = Protected_Procedure then
- return Descriptors (Interrupt).H;
- else
- return null;
- end if;
- end Current_Handler;
-
- --------------------
- -- Attach_Handler --
- --------------------
-
- procedure Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Attach_Handler (New_Handler, Interrupt, Static, False);
- end Attach_Handler;
-
- procedure Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean)
- is
- New_Task : Server_Task_Access;
-
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error;
- end if;
-
- if not Restoration and then not Static
-
- -- Tries to overwrite a static Interrupt Handler with dynamic handle
-
- and then
- (Descriptors (Interrupt).Static
-
- -- New handler not specified as an Interrupt Handler by a pragma
-
- or else not Is_Registered (New_Handler))
- then
- raise Program_Error with
- "trying to overwrite a static interrupt handler with a " &
- "dynamic handler";
- end if;
-
- if Handlers (Interrupt) = null then
- New_Task := new Server_Task (Interrupt);
- Handlers (Interrupt) := To_System (New_Task.all'Identity);
- end if;
-
- if intr_attach (int (Interrupt),
- TISR (Signal_Handler'Access)) = FUNC_ERR
- then
- raise Program_Error;
- end if;
-
- if New_Handler = null then
-
- -- The null handler means we are detaching the handler
-
- Descriptors (Interrupt) :=
- (Kind => Unknown, T => null, E => 0, H => null, Static => False);
-
- else
- Descriptors (Interrupt).Kind := Protected_Procedure;
- Descriptors (Interrupt).H := New_Handler;
- Descriptors (Interrupt).Static := Static;
- end if;
- end Attach_Handler;
-
- ----------------------
- -- Exchange_Handler --
- ----------------------
-
- procedure Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error;
- end if;
-
- if Descriptors (Interrupt).Kind = Task_Entry then
-
- -- In case we have an Interrupt Entry already installed, raise a
- -- program error (propagate it to the caller).
-
- raise Program_Error with "an interrupt is already installed";
-
- else
- Old_Handler := Current_Handler (Interrupt);
- Attach_Handler (New_Handler, Interrupt, Static);
- end if;
- end Exchange_Handler;
-
- --------------------
- -- Detach_Handler --
- --------------------
-
- procedure Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error;
- end if;
-
- if Descriptors (Interrupt).Kind = Task_Entry then
- raise Program_Error with "trying to detach an interrupt entry";
- end if;
-
- if not Static and then Descriptors (Interrupt).Static then
- raise Program_Error with
- "trying to detach a static interrupt handler";
- end if;
-
- Descriptors (Interrupt) :=
- (Kind => Unknown, T => null, E => 0, H => null, Static => False);
-
- if intr_attach (int (Interrupt), null) = FUNC_ERR then
- raise Program_Error;
- end if;
- end Detach_Handler;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference (Interrupt : Interrupt_ID) return System.Address is
- Signal : constant System.Address :=
- System.Storage_Elements.To_Address
- (System.Storage_Elements.Integer_Address (Interrupt));
-
- begin
- if Is_Reserved (Interrupt) then
-
- -- Only usable Interrupts can be used for binding it to an Entry
-
- raise Program_Error;
- end if;
-
- return Signal;
- end Reference;
-
- --------------------------------
- -- Register_Interrupt_Handler --
- --------------------------------
-
- procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
- begin
- Registered_Handlers :=
- new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers);
- end Register_Interrupt_Handler;
-
- -------------------
- -- Is_Registered --
- -------------------
-
- -- See if the Handler has been "pragma"ed using Interrupt_Handler.
- -- Always consider a null handler as registered.
-
- function Is_Registered (Handler : Parameterless_Handler) return Boolean is
- Ptr : R_Link := Registered_Handlers;
-
- type Fat_Ptr is record
- Object_Addr : System.Address;
- Handler_Addr : System.Address;
- end record;
-
- function To_Fat_Ptr is new Ada.Unchecked_Conversion
- (Parameterless_Handler, Fat_Ptr);
-
- Fat : Fat_Ptr;
-
- begin
- if Handler = null then
- return True;
- end if;
-
- Fat := To_Fat_Ptr (Handler);
-
- while Ptr /= null loop
- if Ptr.H = Fat.Handler_Addr then
- return True;
- end if;
-
- Ptr := Ptr.Next;
- end loop;
-
- return False;
- end Is_Registered;
-
- -----------------------------
- -- Bind_Interrupt_To_Entry --
- -----------------------------
-
- procedure Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Int_Ref : System.Address)
- is
- Interrupt : constant Interrupt_ID :=
- Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
-
- New_Task : Server_Task_Access;
-
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error;
- end if;
-
- if Descriptors (Interrupt).Kind /= Unknown then
- raise Program_Error with
- "a binding for this interrupt is already present";
- end if;
-
- if Handlers (Interrupt) = null then
- New_Task := new Server_Task (Interrupt);
- Handlers (Interrupt) := To_System (New_Task.all'Identity);
- end if;
-
- if intr_attach (int (Interrupt),
- TISR (Signal_Handler'Access)) = FUNC_ERR
- then
- raise Program_Error;
- end if;
-
- Descriptors (Interrupt).Kind := Task_Entry;
- Descriptors (Interrupt).T := T;
- Descriptors (Interrupt).E := E;
-
- -- Indicate the attachment of Interrupt Entry in ATCB. This is needed so
- -- that when an Interrupt Entry task terminates the binding can be
- -- cleaned up. The call to unbinding must be make by the task before it
- -- terminates.
-
- T.Interrupt_Entry := True;
- end Bind_Interrupt_To_Entry;
-
- ------------------------------
- -- Detach_Interrupt_Entries --
- ------------------------------
-
- procedure Detach_Interrupt_Entries (T : Task_Id) is
- begin
- for J in Interrupt_ID loop
- if not Is_Reserved (J) then
- if Descriptors (J).Kind = Task_Entry
- and then Descriptors (J).T = T
- then
- Descriptors (J).Kind := Unknown;
-
- if intr_attach (int (J), null) = FUNC_ERR then
- raise Program_Error;
- end if;
- end if;
- end if;
- end loop;
-
- -- Indicate in ATCB that no Interrupt Entries are attached
-
- T.Interrupt_Entry := True;
- end Detach_Interrupt_Entries;
-
- ---------------------
- -- Block_Interrupt --
- ---------------------
-
- procedure Block_Interrupt (Interrupt : Interrupt_ID) is
- begin
- raise Program_Error;
- end Block_Interrupt;
-
- -----------------------
- -- Unblock_Interrupt --
- -----------------------
-
- procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
- begin
- raise Program_Error;
- end Unblock_Interrupt;
-
- ----------------
- -- Is_Blocked --
- ----------------
-
- function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
- begin
- raise Program_Error;
- return False;
- end Is_Blocked;
-
- task body Server_Task is
- Ignore : constant Boolean := Utilities.Make_Independent;
-
- Desc : Handler_Desc renames Descriptors (Interrupt);
- Self_Id : constant Task_Id := STPO.Self;
- Temp : Parameterless_Handler;
-
- begin
- loop
- while Interrupt_Count (Interrupt) > 0 loop
- Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1;
- begin
- case Desc.Kind is
- when Unknown =>
- null;
- when Task_Entry =>
- Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address);
- when Protected_Procedure =>
- Temp := Desc.H;
- Temp.all;
- end case;
- exception
- when others => null;
- end;
- end loop;
-
- Initialization.Defer_Abort (Self_Id);
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
- STPO.Write_Lock (Self_Id);
- Self_Id.Common.State := Interrupt_Server_Idle_Sleep;
- STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep);
- Self_Id.Common.State := Runnable;
- STPO.Unlock (Self_Id);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
- Initialization.Undefer_Abort (Self_Id);
-
- -- Undefer abort here to allow a window for this task to be aborted
- -- at the time of system shutdown.
-
- end loop;
- end Server_Task;
-
-end System.Interrupts;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T 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 --
--- <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. --
--- --
-------------------------------------------------------------------------------
-
--- 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.
-
--- 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).
-
--- 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.
-
--- 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,
--- we use the per-task lock of the Server_Task instead so that we protect the
--- 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;
-
-with Interfaces.C; use Interfaces.C;
-with System.OS_Interface; use System.OS_Interface;
-with System.Interrupt_Management;
-with System.Task_Primitives.Operations;
-with System.Storage_Elements;
-with System.Tasking.Utilities;
-
-with System.Tasking.Rendezvous;
-pragma Elaborate_All (System.Tasking.Rendezvous);
-
-package body System.Interrupts is
-
- use Tasking;
-
- package POP renames System.Task_Primitives.Operations;
-
- function To_Ada is new Ada.Unchecked_Conversion
- (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id);
-
- function To_System is new Ada.Unchecked_Conversion
- (Ada.Task_Identification.Task_Id, Task_Id);
-
- -----------------
- -- Local Tasks --
- -----------------
-
- -- WARNING: System.Tasking.Stages performs calls to this task with low-
- -- level constructs. Do not change this spec without synchronizing it.
-
- task Interrupt_Manager is
- entry Detach_Interrupt_Entries (T : Task_Id);
-
- entry Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False);
-
- entry Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean);
-
- entry Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean);
-
- entry Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Interrupt : Interrupt_ID);
-
- pragma Interrupt_Priority (System.Interrupt_Priority'First);
- end Interrupt_Manager;
-
- task type Interrupt_Server_Task
- (Interrupt : Interrupt_ID;
- Int_Sema : Binary_Semaphore_Id)
- is
- -- Server task for vectored hardware interrupt handling
-
- pragma Interrupt_Priority (System.Interrupt_Priority'First + 2);
- end Interrupt_Server_Task;
-
- type Interrupt_Task_Access is access Interrupt_Server_Task;
-
- -------------------------------
- -- Local Types and Variables --
- -------------------------------
-
- type Entry_Assoc is record
- T : Task_Id;
- E : Task_Entry_Index;
- end record;
-
- type Handler_Assoc is record
- H : Parameterless_Handler;
- Static : Boolean; -- Indicates static binding;
- end record;
-
- User_Handler : array (Interrupt_ID) of Handler_Assoc :=
- (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
- -- 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
-
- -- Type and Head, Tail of the list containing Registered Interrupt
- -- Handlers. These definitions are used to register the handlers
- -- specified by the pragma Interrupt_Handler.
-
- type Registered_Handler;
- type R_Link is access all Registered_Handler;
-
- type Registered_Handler is record
- H : System.Address := System.Null_Address;
- Next : R_Link := null;
- end record;
-
- Registered_Handler_Head : R_Link := null;
- Registered_Handler_Tail : R_Link := null;
-
- Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id :=
- (others => System.Tasking.Null_Task);
- pragma Atomic_Components (Server_ID);
- -- Holds the Task_Id of the Server_Task for each interrupt / signal.
- -- Task_Id is needed to accomplish locking per interrupt base. Also
- -- is needed to determine whether to create a new Server_Task.
-
- Semaphore_ID_Map : array
- (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) of
- Binary_Semaphore_Id := (others => 0);
- -- Array of binary semaphores associated with vectored interrupts. Note
- -- that the last bound should be Max_HW_Interrupt, but this will raise
- -- Storage_Error if Num_HW_Interrupts is null so use extra 4 bytes instead.
-
- Interrupt_Access_Hold : Interrupt_Task_Access;
- -- Variable for allocating an Interrupt_Server_Task
-
- Handler_Installed : array (HW_Interrupt) of Boolean := (others => False);
- -- True if Notify_Interrupt was connected to the interrupt. Handlers can
- -- be connected but disconnection is not possible on VxWorks. Therefore
- -- we ensure Notify_Installed is connected at most once.
-
- type Interrupt_Connector is access function
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler;
- Parameter : System.Address := System.Null_Address) return int;
- -- Profile must match VxWorks intConnect()
-
- Interrupt_Connect : Interrupt_Connector :=
- System.OS_Interface.Interrupt_Connect'Access;
- pragma Export (C, Interrupt_Connect, "__gnat_user_int_connect");
- -- Allow user alternatives to the OS implementation of
- -- System.OS_Interface.Interrupt_Connect. This allows the user to
- -- associate a handler with an interrupt source when an alternate routine
- -- is needed to do so. The association is performed in
- -- Interfaces.VxWorks.Interrupt_Connections. Defaults to the standard OS
- -- connection routine.
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID);
- -- Check if Id is a reserved interrupt, and if so raise Program_Error
- -- with an appropriate message, otherwise return.
-
- procedure Finalize_Interrupt_Servers;
- -- Unbind the handlers for hardware interrupt server tasks at program
- -- termination.
-
- function Is_Registered (Handler : Parameterless_Handler) return Boolean;
- -- See if Handler has been "pragma"ed using Interrupt_Handler.
- -- Always consider a null handler as registered.
-
- procedure Notify_Interrupt (Param : System.Address);
- pragma Convention (C, Notify_Interrupt);
- -- Umbrella handler for vectored interrupts (not signals)
-
- procedure Install_Umbrella_Handler
- (Interrupt : HW_Interrupt;
- Handler : System.OS_Interface.Interrupt_Handler);
- -- Install the runtime umbrella handler for a vectored hardware
- -- interrupt
-
- procedure Unimplemented (Feature : String);
- pragma No_Return (Unimplemented);
- -- Used to mark a call to an unimplemented function. Raises Program_Error
- -- with an appropriate message noting that Feature is unimplemented.
-
- --------------------
- -- Attach_Handler --
- --------------------
-
- -- Calling this procedure with New_Handler = null and Static = True
- -- means we want to detach the current handler regardless of the previous
- -- handler's binding status (i.e. do not care if it is a dynamic or static
- -- handler).
-
- -- This option is needed so that during the finalization of a PO, we can
- -- detach handlers attached through pragma Attach_Handler.
-
- procedure Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False) is
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
- end Attach_Handler;
-
- -----------------------------
- -- Bind_Interrupt_To_Entry --
- -----------------------------
-
- -- This procedure raises a Program_Error if it tries to
- -- bind an interrupt to which an Entry or a Procedure is
- -- already bound.
-
- procedure Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Int_Ref : System.Address)
- is
- Interrupt : constant Interrupt_ID :=
- Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
- end Bind_Interrupt_To_Entry;
-
- ---------------------
- -- Block_Interrupt --
- ---------------------
-
- procedure Block_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Block_Interrupt");
- end Block_Interrupt;
-
- ------------------------------
- -- Check_Reserved_Interrupt --
- ------------------------------
-
- procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error with
- "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
- else
- return;
- end if;
- end Check_Reserved_Interrupt;
-
- ---------------------
- -- Current_Handler --
- ---------------------
-
- function Current_Handler
- (Interrupt : Interrupt_ID) return Parameterless_Handler
- is
- begin
- Check_Reserved_Interrupt (Interrupt);
-
- -- ??? Since Parameterless_Handler is not Atomic, the current
- -- implementation is wrong. We need a new service in Interrupt_Manager
- -- to ensure atomicity.
-
- return User_Handler (Interrupt).H;
- end Current_Handler;
-
- --------------------
- -- Detach_Handler --
- --------------------
-
- -- Calling this procedure with Static = True means we want to Detach the
- -- current handler regardless of the previous handler's binding status
- -- (i.e. do not care if it is a dynamic or static handler).
-
- -- This option is needed so that during the finalization of a PO, we can
- -- detach handlers attached through pragma Attach_Handler.
-
- procedure Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Detach_Handler (Interrupt, Static);
- end Detach_Handler;
-
- ------------------------------
- -- Detach_Interrupt_Entries --
- ------------------------------
-
- procedure Detach_Interrupt_Entries (T : Task_Id) is
- begin
- Interrupt_Manager.Detach_Interrupt_Entries (T);
- end Detach_Interrupt_Entries;
-
- ----------------------
- -- Exchange_Handler --
- ----------------------
-
- -- Calling this procedure with New_Handler = null and Static = True
- -- means we want to detach the current handler regardless of the previous
- -- handler's binding status (i.e. we do not care if it is a dynamic or
- -- static handler).
-
- -- This option is needed so that during the finalization of a PO, we can
- -- detach handlers attached through pragma Attach_Handler.
-
- procedure Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Exchange_Handler
- (Old_Handler, New_Handler, Interrupt, Static);
- end Exchange_Handler;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Object : in out Static_Interrupt_Protection) is
- begin
- -- ??? loop to be executed only when we're not doing library level
- -- finalization, since in this case all interrupt / signal tasks are
- -- gone.
-
- if not Interrupt_Manager'Terminated then
- for N in reverse Object.Previous_Handlers'Range loop
- Interrupt_Manager.Attach_Handler
- (New_Handler => Object.Previous_Handlers (N).Handler,
- Interrupt => Object.Previous_Handlers (N).Interrupt,
- Static => Object.Previous_Handlers (N).Static,
- Restoration => True);
- end loop;
- end if;
-
- Tasking.Protected_Objects.Entries.Finalize
- (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
- end Finalize;
-
- --------------------------------
- -- Finalize_Interrupt_Servers --
- --------------------------------
-
- -- Restore default handlers for interrupt servers
-
- -- This is called by the Interrupt_Manager task when it receives the abort
- -- signal during program finalization.
-
- procedure Finalize_Interrupt_Servers is
- HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
- begin
- if HW_Interrupts then
- for Int in HW_Interrupt loop
- if Server_ID (Interrupt_ID (Int)) /= null
- and then
- not Ada.Task_Identification.Is_Terminated
- (To_Ada (Server_ID (Interrupt_ID (Int))))
- then
- Interrupt_Manager.Attach_Handler
- (New_Handler => null,
- Interrupt => Interrupt_ID (Int),
- Static => True,
- Restoration => True);
- end if;
- end loop;
- end if;
- end Finalize_Interrupt_Servers;
-
- -------------------------------------
- -- Has_Interrupt_Or_Attach_Handler --
- -------------------------------------
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection)
- return Boolean
- is
- pragma Unreferenced (Object);
- begin
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection)
- return Boolean
- is
- pragma Unreferenced (Object);
- begin
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- ----------------------
- -- Ignore_Interrupt --
- ----------------------
-
- procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Ignore_Interrupt");
- end Ignore_Interrupt;
-
- ----------------------
- -- Install_Handlers --
- ----------------------
-
- procedure Install_Handlers
- (Object : access Static_Interrupt_Protection;
- New_Handlers : New_Handler_Array)
- is
- begin
- for N in New_Handlers'Range loop
-
- -- We need a lock around this ???
-
- Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
- Object.Previous_Handlers (N).Static := User_Handler
- (New_Handlers (N).Interrupt).Static;
-
- -- We call Exchange_Handler and not directly Interrupt_Manager.
- -- Exchange_Handler so we get the Is_Reserved check.
-
- Exchange_Handler
- (Old_Handler => Object.Previous_Handlers (N).Handler,
- New_Handler => New_Handlers (N).Handler,
- Interrupt => New_Handlers (N).Interrupt,
- Static => True);
- end loop;
- end Install_Handlers;
-
- ---------------------------------
- -- Install_Restricted_Handlers --
- ---------------------------------
-
- procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
- Handlers : New_Handler_Array)
- is
- pragma Unreferenced (Prio);
- begin
- for N in Handlers'Range loop
- Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
- end loop;
- end Install_Restricted_Handlers;
-
- ------------------------------
- -- Install_Umbrella_Handler --
- ------------------------------
-
- procedure Install_Umbrella_Handler
- (Interrupt : HW_Interrupt;
- Handler : System.OS_Interface.Interrupt_Handler)
- is
- Vec : constant Interrupt_Vector :=
- Interrupt_Number_To_Vector (int (Interrupt));
-
- Status : int;
-
- begin
- -- Only install umbrella handler when no Ada handler has already been
- -- installed. Note that the interrupt number is passed as a parameter
- -- when an interrupt occurs, so the umbrella handler has a different
- -- wrapper generated by the connector routine for each interrupt
- -- number.
-
- if not Handler_Installed (Interrupt) then
- Status :=
- Interrupt_Connect.all (Vec, Handler, System.Address (Interrupt));
- pragma Assert (Status = 0);
-
- Handler_Installed (Interrupt) := True;
- end if;
- end Install_Umbrella_Handler;
-
- ----------------
- -- Is_Blocked --
- ----------------
-
- function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented ("Is_Blocked");
- return False;
- end Is_Blocked;
-
- -----------------------
- -- Is_Entry_Attached --
- -----------------------
-
- function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- Check_Reserved_Interrupt (Interrupt);
- return User_Entry (Interrupt).T /= Null_Task;
- end Is_Entry_Attached;
-
- -------------------------
- -- Is_Handler_Attached --
- -------------------------
-
- function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- Check_Reserved_Interrupt (Interrupt);
- return User_Handler (Interrupt).H /= null;
- end Is_Handler_Attached;
-
- ----------------
- -- Is_Ignored --
- ----------------
-
- function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented ("Is_Ignored");
- return False;
- end Is_Ignored;
-
- -------------------
- -- Is_Registered --
- -------------------
-
- function Is_Registered (Handler : Parameterless_Handler) return Boolean is
- type Fat_Ptr is record
- Object_Addr : System.Address;
- Handler_Addr : System.Address;
- end record;
-
- function To_Fat_Ptr is new Ada.Unchecked_Conversion
- (Parameterless_Handler, Fat_Ptr);
-
- Ptr : R_Link;
- Fat : Fat_Ptr;
-
- begin
- if Handler = null then
- return True;
- end if;
-
- Fat := To_Fat_Ptr (Handler);
-
- Ptr := Registered_Handler_Head;
- while Ptr /= null loop
- if Ptr.H = Fat.Handler_Addr then
- return True;
- end if;
-
- Ptr := Ptr.Next;
- end loop;
-
- return False;
- end Is_Registered;
-
- -----------------
- -- Is_Reserved --
- -----------------
-
- function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
- use System.Interrupt_Management;
- begin
- return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt));
- end Is_Reserved;
-
- ----------------------
- -- Notify_Interrupt --
- ----------------------
-
- -- Umbrella handler for vectored hardware interrupts (as opposed to signals
- -- and exceptions). As opposed to the signal implementation, this handler
- -- is installed in the vector table when the first Ada handler is attached
- -- to the interrupt. However because VxWorks don't support disconnecting
- -- handlers, this subprogram always test whether or not an Ada handler is
- -- effectively attached.
-
- -- Otherwise, the handler that existed prior to program startup is in the
- -- vector table. This ensures that handlers installed by the BSP are active
- -- unless explicitly replaced in the program text.
-
- -- Each Interrupt_Server_Task has an associated binary semaphore on which
- -- it pends once it's been started. This routine determines The appropriate
- -- semaphore and issues a semGive call, waking the server task. When
- -- a handler is unbound, System.Interrupts.Unbind_Handler issues a
- -- Binary_Semaphore_Flush, and the server task deletes its semaphore
- -- and terminates.
-
- procedure Notify_Interrupt (Param : System.Address) is
- Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
- Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt);
- Status : int;
- begin
- if Id /= 0 then
- Status := Binary_Semaphore_Release (Id);
- pragma Assert (Status = 0);
- end if;
- end Notify_Interrupt;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference (Interrupt : Interrupt_ID) return System.Address is
- begin
- Check_Reserved_Interrupt (Interrupt);
- return Storage_Elements.To_Address
- (Storage_Elements.Integer_Address (Interrupt));
- end Reference;
-
- --------------------------------
- -- Register_Interrupt_Handler --
- --------------------------------
-
- procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
- New_Node_Ptr : R_Link;
-
- begin
- -- This routine registers a handler as usable for dynamic interrupt
- -- handler association. Routines attaching and detaching handlers
- -- dynamically should determine whether the handler is registered.
- -- Program_Error should be raised if it is not registered.
-
- -- Pragma Interrupt_Handler can only appear in a library level PO
- -- definition and instantiation. Therefore, we do not need to implement
- -- an unregister operation. Nor do we need to protect the queue
- -- structure with a lock.
-
- pragma Assert (Handler_Addr /= System.Null_Address);
-
- New_Node_Ptr := new Registered_Handler;
- New_Node_Ptr.H := Handler_Addr;
-
- if Registered_Handler_Head = null then
- Registered_Handler_Head := New_Node_Ptr;
- Registered_Handler_Tail := New_Node_Ptr;
- else
- Registered_Handler_Tail.Next := New_Node_Ptr;
- Registered_Handler_Tail := New_Node_Ptr;
- end if;
- end Register_Interrupt_Handler;
-
- -----------------------
- -- Unblock_Interrupt --
- -----------------------
-
- procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Unblock_Interrupt");
- end Unblock_Interrupt;
-
- ------------------
- -- Unblocked_By --
- ------------------
-
- function Unblocked_By
- (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
- is
- begin
- Unimplemented ("Unblocked_By");
- return Null_Task;
- end Unblocked_By;
-
- ------------------------
- -- Unignore_Interrupt --
- ------------------------
-
- procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Unignore_Interrupt");
- end Unignore_Interrupt;
-
- -------------------
- -- Unimplemented --
- -------------------
-
- procedure Unimplemented (Feature : String) is
- begin
- raise Program_Error with Feature & " not implemented on VxWorks";
- end Unimplemented;
-
- -----------------------
- -- Interrupt_Manager --
- -----------------------
-
- task body Interrupt_Manager is
- -- By making this task independent of any master, when the process goes
- -- away, the Interrupt_Manager will terminate gracefully.
-
- Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
- pragma Unreferenced (Ignore);
-
- --------------------
- -- Local Routines --
- --------------------
-
- procedure Bind_Handler (Interrupt : Interrupt_ID);
- -- This procedure does not do anything if a signal is blocked.
- -- Otherwise, we have to interrupt Server_Task for status change
- -- through a wakeup signal.
-
- procedure Unbind_Handler (Interrupt : Interrupt_ID);
- -- This procedure does not do anything if a signal is blocked.
- -- Otherwise, we have to interrupt Server_Task for status change
- -- through an abort signal.
-
- procedure Unprotected_Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False);
-
- procedure Unprotected_Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean);
-
- ------------------
- -- Bind_Handler --
- ------------------
-
- procedure Bind_Handler (Interrupt : Interrupt_ID) is
- begin
- Install_Umbrella_Handler
- (HW_Interrupt (Interrupt), Notify_Interrupt'Access);
- end Bind_Handler;
-
- --------------------
- -- Unbind_Handler --
- --------------------
-
- procedure Unbind_Handler (Interrupt : Interrupt_ID) is
- Status : int;
-
- begin
- -- Flush server task off semaphore, allowing it to terminate
-
- Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt));
- pragma Assert (Status = 0);
- end Unbind_Handler;
-
- --------------------------------
- -- Unprotected_Detach_Handler --
- --------------------------------
-
- procedure Unprotected_Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean)
- is
- Old_Handler : Parameterless_Handler;
- begin
- if User_Entry (Interrupt).T /= Null_Task then
-
- -- If an interrupt entry is installed raise Program_Error
- -- (propagate it to the caller).
-
- raise Program_Error with
- "an interrupt entry is already installed";
- end if;
-
- -- Note : Static = True will pass the following check. This is the
- -- case when we want to detach a handler regardless of the static
- -- status of the Current_Handler.
-
- if not Static and then User_Handler (Interrupt).Static then
-
- -- Trying to detach a static Interrupt Handler, raise
- -- Program_Error.
-
- raise Program_Error with
- "trying to detach a static Interrupt Handler";
- end if;
-
- Old_Handler := User_Handler (Interrupt).H;
-
- -- The new handler
-
- User_Handler (Interrupt).H := null;
- User_Handler (Interrupt).Static := False;
-
- if Old_Handler /= null then
- Unbind_Handler (Interrupt);
- end if;
- end Unprotected_Detach_Handler;
-
- ----------------------------------
- -- Unprotected_Exchange_Handler --
- ----------------------------------
-
- procedure Unprotected_Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False)
- is
- begin
- if User_Entry (Interrupt).T /= Null_Task then
-
- -- If an interrupt entry is already installed, raise
- -- Program_Error (propagate it to the caller).
-
- raise Program_Error with "an interrupt is already installed";
- end if;
-
- -- Note : A null handler with Static = True will pass the following
- -- check. This is the case when we want to detach a handler
- -- regardless of the Static status of Current_Handler.
-
- -- We don't check anything if Restoration is True, since we may be
- -- detaching a static handler to restore a dynamic one.
-
- if not Restoration and then not Static
- and then (User_Handler (Interrupt).Static
-
- -- Trying to overwrite a static Interrupt Handler with a dynamic
- -- Handler
-
- -- The new handler is not specified as an Interrupt Handler by a
- -- pragma.
-
- or else not Is_Registered (New_Handler))
- then
- raise Program_Error with
- "trying to overwrite a static interrupt handler with a "
- & "dynamic handler";
- end if;
-
- -- Save the old handler
-
- Old_Handler := User_Handler (Interrupt).H;
-
- -- The new handler
-
- User_Handler (Interrupt).H := New_Handler;
-
- if New_Handler = null then
-
- -- The null handler means we are detaching the handler
-
- User_Handler (Interrupt).Static := False;
-
- else
- User_Handler (Interrupt).Static := Static;
- end if;
-
- -- Invoke a corresponding Server_Task if not yet created. Place
- -- Task_Id info in Server_ID array.
-
- if New_Handler /= null
- and then
- (Server_ID (Interrupt) = Null_Task
- or else
- Ada.Task_Identification.Is_Terminated
- (To_Ada (Server_ID (Interrupt))))
- then
- Interrupt_Access_Hold :=
- new Interrupt_Server_Task (Interrupt, Binary_Semaphore_Create);
- Server_ID (Interrupt) :=
- To_System (Interrupt_Access_Hold.all'Identity);
- end if;
-
- if (New_Handler = null) and then Old_Handler /= null then
-
- -- Restore default handler
-
- Unbind_Handler (Interrupt);
-
- elsif Old_Handler = null then
-
- -- Save default handler
-
- Bind_Handler (Interrupt);
- end if;
- end Unprotected_Exchange_Handler;
-
- -- Start of processing for Interrupt_Manager
-
- begin
- loop
- -- A block is needed to absorb Program_Error exception
-
- declare
- Old_Handler : Parameterless_Handler;
-
- begin
- select
- accept Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False)
- do
- Unprotected_Exchange_Handler
- (Old_Handler, New_Handler, Interrupt, Static, Restoration);
- end Attach_Handler;
-
- or
- accept Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean)
- do
- Unprotected_Exchange_Handler
- (Old_Handler, New_Handler, Interrupt, Static);
- end Exchange_Handler;
-
- or
- accept Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean)
- do
- Unprotected_Detach_Handler (Interrupt, Static);
- end Detach_Handler;
-
- or
- accept Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Interrupt : Interrupt_ID)
- do
- -- If there is a binding already (either a procedure or an
- -- entry), raise Program_Error (propagate it to the caller).
-
- if User_Handler (Interrupt).H /= null
- or else User_Entry (Interrupt).T /= Null_Task
- then
- raise Program_Error with
- "a binding for this interrupt is already present";
- end if;
-
- User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
-
- -- Indicate the attachment of interrupt entry in the ATCB.
- -- This is needed so when an interrupt entry task terminates
- -- the binding can be cleaned. The call to unbinding must be
- -- make by the task before it terminates.
-
- T.Interrupt_Entry := True;
-
- -- Invoke a corresponding Server_Task if not yet created.
- -- Place Task_Id info in Server_ID array.
-
- if Server_ID (Interrupt) = Null_Task
- or else
- Ada.Task_Identification.Is_Terminated
- (To_Ada (Server_ID (Interrupt)))
- then
- Interrupt_Access_Hold := new Interrupt_Server_Task
- (Interrupt, Binary_Semaphore_Create);
- Server_ID (Interrupt) :=
- To_System (Interrupt_Access_Hold.all'Identity);
- end if;
-
- Bind_Handler (Interrupt);
- end Bind_Interrupt_To_Entry;
-
- or
- accept Detach_Interrupt_Entries (T : Task_Id) do
- for Int in Interrupt_ID'Range loop
- if not Is_Reserved (Int) then
- if User_Entry (Int).T = T then
- User_Entry (Int) :=
- Entry_Assoc'
- (T => Null_Task, E => Null_Task_Entry);
- Unbind_Handler (Int);
- end if;
- end if;
- end loop;
-
- -- Indicate in ATCB that no interrupt entries are attached
-
- T.Interrupt_Entry := False;
- end Detach_Interrupt_Entries;
- end select;
-
- exception
- -- If there is a Program_Error we just want to propagate it to
- -- the caller and do not want to stop this task.
-
- when Program_Error =>
- null;
-
- when others =>
- pragma Assert (False);
- null;
- end;
- end loop;
-
- exception
- when Standard'Abort_Signal =>
-
- -- Flush interrupt server semaphores, so they can terminate
-
- Finalize_Interrupt_Servers;
- raise;
- end Interrupt_Manager;
-
- ---------------------------
- -- Interrupt_Server_Task --
- ---------------------------
-
- -- Server task for vectored hardware interrupt handling
-
- task body Interrupt_Server_Task is
- Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
-
- Self_Id : constant Task_Id := Self;
- Tmp_Handler : Parameterless_Handler;
- Tmp_ID : Task_Id;
- Tmp_Entry_Index : Task_Entry_Index;
- Status : int;
-
- begin
- Semaphore_ID_Map (Interrupt) := Int_Sema;
-
- loop
- -- Pend on semaphore that will be triggered by the umbrella handler
- -- when the associated interrupt comes in.
-
- Status := Binary_Semaphore_Obtain (Int_Sema);
- pragma Assert (Status = 0);
-
- if User_Handler (Interrupt).H /= null then
-
- -- Protected procedure handler
-
- Tmp_Handler := User_Handler (Interrupt).H;
- Tmp_Handler.all;
-
- elsif User_Entry (Interrupt).T /= Null_Task then
-
- -- Interrupt entry handler
-
- Tmp_ID := User_Entry (Interrupt).T;
- Tmp_Entry_Index := User_Entry (Interrupt).E;
- System.Tasking.Rendezvous.Call_Simple
- (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
-
- else
- -- Semaphore has been flushed by an unbind operation in the
- -- Interrupt_Manager. Terminate the server task.
-
- -- Wait for the Interrupt_Manager to complete its work
-
- POP.Write_Lock (Self_Id);
-
- -- Unassociate the interrupt handler
-
- Semaphore_ID_Map (Interrupt) := 0;
-
- -- Delete the associated semaphore
-
- Status := Binary_Semaphore_Delete (Int_Sema);
-
- pragma Assert (Status = 0);
-
- -- Set status for the Interrupt_Manager
-
- Server_ID (Interrupt) := Null_Task;
- POP.Unlock (Self_Id);
-
- exit;
- end if;
- end loop;
- end Interrupt_Server_Task;
-
-begin
- -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
-
- Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
-end System.Interrupts;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-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- --
+-- 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 version is for systems that do not support interrupts (or signals)
+
+package body System.Interrupts is
+
+ pragma Warnings (Off); -- kill warnings on unreferenced formals
+
+ use System.Tasking;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Unimplemented;
+ -- This procedure raises a Program_Error with an appropriate message
+ -- indicating that an unimplemented feature has been used.
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Unimplemented;
+ end Attach_Handler;
+
+ -----------------------------
+ -- Bind_Interrupt_To_Entry --
+ -----------------------------
+
+ procedure Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Int_Ref : System.Address)
+ is
+ begin
+ Unimplemented;
+ end Bind_Interrupt_To_Entry;
+
+ ---------------------
+ -- Block_Interrupt --
+ ---------------------
+
+ procedure Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented;
+ end Block_Interrupt;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
+ is
+ begin
+ Unimplemented;
+ return null;
+ end Current_Handler;
+
+ --------------------
+ -- Detach_Handler --
+ --------------------
+
+ procedure Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Unimplemented;
+ end Detach_Handler;
+
+ ------------------------------
+ -- Detach_Interrupt_Entries --
+ ------------------------------
+
+ procedure Detach_Interrupt_Entries (T : Task_Id) is
+ begin
+ Unimplemented;
+ end Detach_Interrupt_Entries;
+
+ ----------------------
+ -- Exchange_Handler --
+ ----------------------
+
+ procedure Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Old_Handler := null;
+ Unimplemented;
+ end Exchange_Handler;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Static_Interrupt_Protection) is
+ begin
+ Unimplemented;
+ end Finalize;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Dynamic_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Warnings (Off, Object);
+ begin
+ Unimplemented;
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Static_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Warnings (Off, Object);
+ begin
+ Unimplemented;
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------------
+ -- Ignore_Interrupt --
+ ----------------------
+
+ procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented;
+ end Ignore_Interrupt;
+
+ ----------------------
+ -- Install_Handlers --
+ ----------------------
+
+ procedure Install_Handlers
+ (Object : access Static_Interrupt_Protection;
+ New_Handlers : New_Handler_Array)
+ is
+ begin
+ Unimplemented;
+ end Install_Handlers;
+
+ ---------------------------------
+ -- Install_Restricted_Handlers --
+ ---------------------------------
+
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array)
+ is
+ begin
+ Unimplemented;
+ end Install_Restricted_Handlers;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Blocked;
+
+ -----------------------
+ -- Is_Entry_Attached --
+ -----------------------
+
+ function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Entry_Attached;
+
+ -------------------------
+ -- Is_Handler_Attached --
+ -------------------------
+
+ function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Handler_Attached;
+
+ ----------------
+ -- Is_Ignored --
+ ----------------
+
+ function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Ignored;
+
+ -----------------
+ -- Is_Reserved --
+ -----------------
+
+ function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Reserved;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ begin
+ Unimplemented;
+ return Interrupt'Address;
+ end Reference;
+
+ --------------------------------
+ -- Register_Interrupt_Handler --
+ --------------------------------
+
+ procedure Register_Interrupt_Handler
+ (Handler_Addr : System.Address)
+ is
+ begin
+ Unimplemented;
+ end Register_Interrupt_Handler;
+
+ -----------------------
+ -- Unblock_Interrupt --
+ -----------------------
+
+ procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented;
+ end Unblock_Interrupt;
+
+ ------------------
+ -- Unblocked_By --
+ ------------------
+
+ function Unblocked_By (Interrupt : Interrupt_ID)
+ return System.Tasking.Task_Id is
+ begin
+ Unimplemented;
+ return null;
+ end Unblocked_By;
+
+ ------------------------
+ -- Unignore_Interrupt --
+ ------------------------
+
+ procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented;
+ end Unignore_Interrupt;
+
+ -------------------
+ -- Unimplemented; --
+ -------------------
+
+ procedure Unimplemented is
+ begin
+ raise Program_Error with "interrupts/signals not implemented";
+ end Unimplemented;
+
+end System.Interrupts;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2014, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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.
+
+-- 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).
+
+-- 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.
+
+-- 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,
+-- we use the per-task lock of the Server_Task instead so that we protect the
+-- 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;
+
+with Interfaces.C; use Interfaces.C;
+with System.OS_Interface; use System.OS_Interface;
+with System.Interrupt_Management;
+with System.Task_Primitives.Operations;
+with System.Storage_Elements;
+with System.Tasking.Utilities;
+
+with System.Tasking.Rendezvous;
+pragma Elaborate_All (System.Tasking.Rendezvous);
+
+package body System.Interrupts is
+
+ use Tasking;
+
+ package POP renames System.Task_Primitives.Operations;
+
+ function To_Ada is new Ada.Unchecked_Conversion
+ (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id);
+
+ function To_System is new Ada.Unchecked_Conversion
+ (Ada.Task_Identification.Task_Id, Task_Id);
+
+ -----------------
+ -- Local Tasks --
+ -----------------
+
+ -- WARNING: System.Tasking.Stages performs calls to this task with low-
+ -- level constructs. Do not change this spec without synchronizing it.
+
+ task Interrupt_Manager is
+ entry Detach_Interrupt_Entries (T : Task_Id);
+
+ entry Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
+
+ entry Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ entry Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ entry Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID);
+
+ pragma Interrupt_Priority (System.Interrupt_Priority'First);
+ end Interrupt_Manager;
+
+ task type Interrupt_Server_Task
+ (Interrupt : Interrupt_ID;
+ Int_Sema : Binary_Semaphore_Id)
+ is
+ -- Server task for vectored hardware interrupt handling
+
+ pragma Interrupt_Priority (System.Interrupt_Priority'First + 2);
+ end Interrupt_Server_Task;
+
+ type Interrupt_Task_Access is access Interrupt_Server_Task;
+
+ -------------------------------
+ -- Local Types and Variables --
+ -------------------------------
+
+ type Entry_Assoc is record
+ T : Task_Id;
+ E : Task_Entry_Index;
+ end record;
+
+ type Handler_Assoc is record
+ H : Parameterless_Handler;
+ Static : Boolean; -- Indicates static binding;
+ end record;
+
+ User_Handler : array (Interrupt_ID) of Handler_Assoc :=
+ (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
+ -- 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
+
+ -- Type and Head, Tail of the list containing Registered Interrupt
+ -- Handlers. These definitions are used to register the handlers
+ -- specified by the pragma Interrupt_Handler.
+
+ type Registered_Handler;
+ type R_Link is access all Registered_Handler;
+
+ type Registered_Handler is record
+ H : System.Address := System.Null_Address;
+ Next : R_Link := null;
+ end record;
+
+ Registered_Handler_Head : R_Link := null;
+ Registered_Handler_Tail : R_Link := null;
+
+ Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id :=
+ (others => System.Tasking.Null_Task);
+ pragma Atomic_Components (Server_ID);
+ -- Holds the Task_Id of the Server_Task for each interrupt / signal.
+ -- Task_Id is needed to accomplish locking per interrupt base. Also
+ -- is needed to determine whether to create a new Server_Task.
+
+ Semaphore_ID_Map : array
+ (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) of
+ Binary_Semaphore_Id := (others => 0);
+ -- Array of binary semaphores associated with vectored interrupts. Note
+ -- that the last bound should be Max_HW_Interrupt, but this will raise
+ -- Storage_Error if Num_HW_Interrupts is null so use extra 4 bytes instead.
+
+ Interrupt_Access_Hold : Interrupt_Task_Access;
+ -- Variable for allocating an Interrupt_Server_Task
+
+ Handler_Installed : array (HW_Interrupt) of Boolean := (others => False);
+ -- True if Notify_Interrupt was connected to the interrupt. Handlers can
+ -- be connected but disconnection is not possible on VxWorks. Therefore
+ -- we ensure Notify_Installed is connected at most once.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID);
+ -- Check if Id is a reserved interrupt, and if so raise Program_Error
+ -- with an appropriate message, otherwise return.
+
+ procedure Finalize_Interrupt_Servers;
+ -- Unbind the handlers for hardware interrupt server tasks at program
+ -- termination.
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean;
+ -- See if Handler has been "pragma"ed using Interrupt_Handler.
+ -- Always consider a null handler as registered.
+
+ procedure Notify_Interrupt (Param : System.Address);
+ pragma Convention (C, Notify_Interrupt);
+ -- Umbrella handler for vectored interrupts (not signals)
+
+ procedure Install_Umbrella_Handler
+ (Interrupt : HW_Interrupt;
+ Handler : System.OS_Interface.Interrupt_Handler);
+ -- Install the runtime umbrella handler for a vectored hardware
+ -- interrupt
+
+ procedure Unimplemented (Feature : String);
+ pragma No_Return (Unimplemented);
+ -- Used to mark a call to an unimplemented function. Raises Program_Error
+ -- with an appropriate message noting that Feature is unimplemented.
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ -- Calling this procedure with New_Handler = null and Static = True
+ -- means we want to detach the current handler regardless of the previous
+ -- handler's binding status (i.e. do not care if it is a dynamic or static
+ -- handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False) is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
+ end Attach_Handler;
+
+ -----------------------------
+ -- Bind_Interrupt_To_Entry --
+ -----------------------------
+
+ -- This procedure raises a Program_Error if it tries to
+ -- bind an interrupt to which an Entry or a Procedure is
+ -- already bound.
+
+ procedure Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Int_Ref : System.Address)
+ is
+ Interrupt : constant Interrupt_ID :=
+ Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
+ end Bind_Interrupt_To_Entry;
+
+ ---------------------
+ -- Block_Interrupt --
+ ---------------------
+
+ procedure Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Block_Interrupt");
+ end Block_Interrupt;
+
+ ------------------------------
+ -- Check_Reserved_Interrupt --
+ ------------------------------
+
+ procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error with
+ "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
+ else
+ return;
+ end if;
+ end Check_Reserved_Interrupt;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+
+ -- ??? Since Parameterless_Handler is not Atomic, the current
+ -- implementation is wrong. We need a new service in Interrupt_Manager
+ -- to ensure atomicity.
+
+ return User_Handler (Interrupt).H;
+ end Current_Handler;
+
+ --------------------
+ -- Detach_Handler --
+ --------------------
+
+ -- Calling this procedure with Static = True means we want to Detach the
+ -- current handler regardless of the previous handler's binding status
+ -- (i.e. do not care if it is a dynamic or static handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Detach_Handler (Interrupt, Static);
+ end Detach_Handler;
+
+ ------------------------------
+ -- Detach_Interrupt_Entries --
+ ------------------------------
+
+ procedure Detach_Interrupt_Entries (T : Task_Id) is
+ begin
+ Interrupt_Manager.Detach_Interrupt_Entries (T);
+ end Detach_Interrupt_Entries;
+
+ ----------------------
+ -- Exchange_Handler --
+ ----------------------
+
+ -- Calling this procedure with New_Handler = null and Static = True
+ -- means we want to detach the current handler regardless of the previous
+ -- handler's binding status (i.e. we do not care if it is a dynamic or
+ -- static handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static);
+ end Exchange_Handler;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Static_Interrupt_Protection) is
+ begin
+ -- ??? loop to be executed only when we're not doing library level
+ -- finalization, since in this case all interrupt / signal tasks are
+ -- gone.
+
+ if not Interrupt_Manager'Terminated then
+ for N in reverse Object.Previous_Handlers'Range loop
+ Interrupt_Manager.Attach_Handler
+ (New_Handler => Object.Previous_Handlers (N).Handler,
+ Interrupt => Object.Previous_Handlers (N).Interrupt,
+ Static => Object.Previous_Handlers (N).Static,
+ Restoration => True);
+ end loop;
+ end if;
+
+ Tasking.Protected_Objects.Entries.Finalize
+ (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
+ end Finalize;
+
+ --------------------------------
+ -- Finalize_Interrupt_Servers --
+ --------------------------------
+
+ -- Restore default handlers for interrupt servers
+
+ -- This is called by the Interrupt_Manager task when it receives the abort
+ -- signal during program finalization.
+
+ procedure Finalize_Interrupt_Servers is
+ HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
+ begin
+ if HW_Interrupts then
+ for Int in HW_Interrupt loop
+ if Server_ID (Interrupt_ID (Int)) /= null
+ and then
+ not Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt_ID (Int))))
+ then
+ Interrupt_Manager.Attach_Handler
+ (New_Handler => null,
+ Interrupt => Interrupt_ID (Int),
+ Static => True,
+ Restoration => True);
+ end if;
+ end loop;
+ end if;
+ end Finalize_Interrupt_Servers;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Dynamic_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Unreferenced (Object);
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Static_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Unreferenced (Object);
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------------
+ -- Ignore_Interrupt --
+ ----------------------
+
+ procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Ignore_Interrupt");
+ end Ignore_Interrupt;
+
+ ----------------------
+ -- Install_Handlers --
+ ----------------------
+
+ procedure Install_Handlers
+ (Object : access Static_Interrupt_Protection;
+ New_Handlers : New_Handler_Array)
+ is
+ begin
+ for N in New_Handlers'Range loop
+
+ -- We need a lock around this ???
+
+ Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
+ Object.Previous_Handlers (N).Static := User_Handler
+ (New_Handlers (N).Interrupt).Static;
+
+ -- We call Exchange_Handler and not directly Interrupt_Manager.
+ -- Exchange_Handler so we get the Is_Reserved check.
+
+ Exchange_Handler
+ (Old_Handler => Object.Previous_Handlers (N).Handler,
+ New_Handler => New_Handlers (N).Handler,
+ Interrupt => New_Handlers (N).Interrupt,
+ Static => True);
+ end loop;
+ end Install_Handlers;
+
+ ---------------------------------
+ -- Install_Restricted_Handlers --
+ ---------------------------------
+
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array)
+ is
+ pragma Unreferenced (Prio);
+ begin
+ for N in Handlers'Range loop
+ Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
+ end loop;
+ end Install_Restricted_Handlers;
+
+ ------------------------------
+ -- Install_Umbrella_Handler --
+ ------------------------------
+
+ procedure Install_Umbrella_Handler
+ (Interrupt : HW_Interrupt;
+ Handler : System.OS_Interface.Interrupt_Handler)
+ is
+ Vec : constant Interrupt_Vector :=
+ Interrupt_Number_To_Vector (int (Interrupt));
+
+ Status : int;
+
+ begin
+ -- Only install umbrella handler when no Ada handler has already been
+ -- installed. Note that the interrupt number is passed as a parameter
+ -- when an interrupt occurs, so the umbrella handler has a different
+ -- wrapper generated by intConnect for each interrupt number.
+
+ if not Handler_Installed (Interrupt) then
+ Status :=
+ Interrupt_Connect (Vec, Handler, System.Address (Interrupt));
+ pragma Assert (Status = 0);
+
+ Handler_Installed (Interrupt) := True;
+ end if;
+ end Install_Umbrella_Handler;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented ("Is_Blocked");
+ return False;
+ end Is_Blocked;
+
+ -----------------------
+ -- Is_Entry_Attached --
+ -----------------------
+
+ function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return User_Entry (Interrupt).T /= Null_Task;
+ end Is_Entry_Attached;
+
+ -------------------------
+ -- Is_Handler_Attached --
+ -------------------------
+
+ function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return User_Handler (Interrupt).H /= null;
+ end Is_Handler_Attached;
+
+ ----------------
+ -- Is_Ignored --
+ ----------------
+
+ function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented ("Is_Ignored");
+ return False;
+ end Is_Ignored;
+
+ -------------------
+ -- Is_Registered --
+ -------------------
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean is
+ type Fat_Ptr is record
+ Object_Addr : System.Address;
+ Handler_Addr : System.Address;
+ end record;
+
+ function To_Fat_Ptr is new Ada.Unchecked_Conversion
+ (Parameterless_Handler, Fat_Ptr);
+
+ Ptr : R_Link;
+ Fat : Fat_Ptr;
+
+ begin
+ if Handler = null then
+ return True;
+ end if;
+
+ Fat := To_Fat_Ptr (Handler);
+
+ Ptr := Registered_Handler_Head;
+ while Ptr /= null loop
+ if Ptr.H = Fat.Handler_Addr then
+ return True;
+ end if;
+
+ Ptr := Ptr.Next;
+ end loop;
+
+ return False;
+ end Is_Registered;
+
+ -----------------
+ -- Is_Reserved --
+ -----------------
+
+ function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ use System.Interrupt_Management;
+ begin
+ return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt));
+ end Is_Reserved;
+
+ ----------------------
+ -- Notify_Interrupt --
+ ----------------------
+
+ -- Umbrella handler for vectored hardware interrupts (as opposed to signals
+ -- and exceptions). As opposed to the signal implementation, this handler
+ -- is installed in the vector table when the first Ada handler is attached
+ -- to the interrupt. However because VxWorks don't support disconnecting
+ -- handlers, this subprogram always test whether or not an Ada handler is
+ -- effectively attached.
+
+ -- Otherwise, the handler that existed prior to program startup is in the
+ -- vector table. This ensures that handlers installed by the BSP are active
+ -- unless explicitly replaced in the program text.
+
+ -- Each Interrupt_Server_Task has an associated binary semaphore on which
+ -- it pends once it's been started. This routine determines The appropriate
+ -- semaphore and issues a semGive call, waking the server task. When
+ -- a handler is unbound, System.Interrupts.Unbind_Handler issues a
+ -- Binary_Semaphore_Flush, and the server task deletes its semaphore
+ -- and terminates.
+
+ procedure Notify_Interrupt (Param : System.Address) is
+ Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
+ Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt);
+ Status : int;
+ begin
+ if Id /= 0 then
+ Status := Binary_Semaphore_Release (Id);
+ pragma Assert (Status = 0);
+ end if;
+ end Notify_Interrupt;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return Storage_Elements.To_Address
+ (Storage_Elements.Integer_Address (Interrupt));
+ end Reference;
+
+ --------------------------------
+ -- Register_Interrupt_Handler --
+ --------------------------------
+
+ procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
+ New_Node_Ptr : R_Link;
+
+ begin
+ -- This routine registers a handler as usable for dynamic interrupt
+ -- handler association. Routines attaching and detaching handlers
+ -- dynamically should determine whether the handler is registered.
+ -- Program_Error should be raised if it is not registered.
+
+ -- Pragma Interrupt_Handler can only appear in a library level PO
+ -- definition and instantiation. Therefore, we do not need to implement
+ -- an unregister operation. Nor do we need to protect the queue
+ -- structure with a lock.
+
+ pragma Assert (Handler_Addr /= System.Null_Address);
+
+ New_Node_Ptr := new Registered_Handler;
+ New_Node_Ptr.H := Handler_Addr;
+
+ if Registered_Handler_Head = null then
+ Registered_Handler_Head := New_Node_Ptr;
+ Registered_Handler_Tail := New_Node_Ptr;
+ else
+ Registered_Handler_Tail.Next := New_Node_Ptr;
+ Registered_Handler_Tail := New_Node_Ptr;
+ end if;
+ end Register_Interrupt_Handler;
+
+ -----------------------
+ -- Unblock_Interrupt --
+ -----------------------
+
+ procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Unblock_Interrupt");
+ end Unblock_Interrupt;
+
+ ------------------
+ -- Unblocked_By --
+ ------------------
+
+ function Unblocked_By
+ (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
+ is
+ begin
+ Unimplemented ("Unblocked_By");
+ return Null_Task;
+ end Unblocked_By;
+
+ ------------------------
+ -- Unignore_Interrupt --
+ ------------------------
+
+ procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Unignore_Interrupt");
+ end Unignore_Interrupt;
+
+ -------------------
+ -- Unimplemented --
+ -------------------
+
+ procedure Unimplemented (Feature : String) is
+ begin
+ raise Program_Error with Feature & " not implemented on VxWorks";
+ end Unimplemented;
+
+ -----------------------
+ -- Interrupt_Manager --
+ -----------------------
+
+ task body Interrupt_Manager is
+ -- By making this task independent of any master, when the process goes
+ -- away, the Interrupt_Manager will terminate gracefully.
+
+ Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
+ pragma Unreferenced (Ignore);
+
+ --------------------
+ -- Local Routines --
+ --------------------
+
+ procedure Bind_Handler (Interrupt : Interrupt_ID);
+ -- This procedure does not do anything if a signal is blocked.
+ -- Otherwise, we have to interrupt Server_Task for status change
+ -- through a wakeup signal.
+
+ procedure Unbind_Handler (Interrupt : Interrupt_ID);
+ -- This procedure does not do anything if a signal is blocked.
+ -- Otherwise, we have to interrupt Server_Task for status change
+ -- through an abort signal.
+
+ procedure Unprotected_Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
+
+ procedure Unprotected_Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ ------------------
+ -- Bind_Handler --
+ ------------------
+
+ procedure Bind_Handler (Interrupt : Interrupt_ID) is
+ begin
+ Install_Umbrella_Handler
+ (HW_Interrupt (Interrupt), Notify_Interrupt'Access);
+ end Bind_Handler;
+
+ --------------------
+ -- Unbind_Handler --
+ --------------------
+
+ procedure Unbind_Handler (Interrupt : Interrupt_ID) is
+ Status : int;
+
+ begin
+ -- Flush server task off semaphore, allowing it to terminate
+
+ Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt));
+ pragma Assert (Status = 0);
+ end Unbind_Handler;
+
+ --------------------------------
+ -- Unprotected_Detach_Handler --
+ --------------------------------
+
+ procedure Unprotected_Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
+ is
+ Old_Handler : Parameterless_Handler;
+ begin
+ if User_Entry (Interrupt).T /= Null_Task then
+
+ -- If an interrupt entry is installed raise Program_Error
+ -- (propagate it to the caller).
+
+ raise Program_Error with
+ "an interrupt entry is already installed";
+ end if;
+
+ -- Note : Static = True will pass the following check. This is the
+ -- case when we want to detach a handler regardless of the static
+ -- status of the Current_Handler.
+
+ if not Static and then User_Handler (Interrupt).Static then
+
+ -- Trying to detach a static Interrupt Handler, raise
+ -- Program_Error.
+
+ raise Program_Error with
+ "trying to detach a static Interrupt Handler";
+ end if;
+
+ Old_Handler := User_Handler (Interrupt).H;
+
+ -- The new handler
+
+ User_Handler (Interrupt).H := null;
+ User_Handler (Interrupt).Static := False;
+
+ if Old_Handler /= null then
+ Unbind_Handler (Interrupt);
+ end if;
+ end Unprotected_Detach_Handler;
+
+ ----------------------------------
+ -- Unprotected_Exchange_Handler --
+ ----------------------------------
+
+ procedure Unprotected_Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False)
+ is
+ begin
+ if User_Entry (Interrupt).T /= Null_Task then
+
+ -- If an interrupt entry is already installed, raise
+ -- Program_Error (propagate it to the caller).
+
+ raise Program_Error with "an interrupt is already installed";
+ end if;
+
+ -- Note : A null handler with Static = True will pass the following
+ -- check. This is the case when we want to detach a handler
+ -- regardless of the Static status of Current_Handler.
+
+ -- We don't check anything if Restoration is True, since we may be
+ -- detaching a static handler to restore a dynamic one.
+
+ if not Restoration and then not Static
+ and then (User_Handler (Interrupt).Static
+
+ -- Trying to overwrite a static Interrupt Handler with a dynamic
+ -- Handler
+
+ -- The new handler is not specified as an Interrupt Handler by a
+ -- pragma.
+
+ or else not Is_Registered (New_Handler))
+ then
+ raise Program_Error with
+ "trying to overwrite a static interrupt handler with a "
+ & "dynamic handler";
+ end if;
+
+ -- Save the old handler
+
+ Old_Handler := User_Handler (Interrupt).H;
+
+ -- The new handler
+
+ User_Handler (Interrupt).H := New_Handler;
+
+ if New_Handler = null then
+
+ -- The null handler means we are detaching the handler
+
+ User_Handler (Interrupt).Static := False;
+
+ else
+ User_Handler (Interrupt).Static := Static;
+ end if;
+
+ -- Invoke a corresponding Server_Task if not yet created. Place
+ -- Task_Id info in Server_ID array.
+
+ if New_Handler /= null
+ and then
+ (Server_ID (Interrupt) = Null_Task
+ or else
+ Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt))))
+ then
+ Interrupt_Access_Hold :=
+ new Interrupt_Server_Task (Interrupt, Binary_Semaphore_Create);
+ Server_ID (Interrupt) :=
+ To_System (Interrupt_Access_Hold.all'Identity);
+ end if;
+
+ if (New_Handler = null) and then Old_Handler /= null then
+
+ -- Restore default handler
+
+ Unbind_Handler (Interrupt);
+
+ elsif Old_Handler = null then
+
+ -- Save default handler
+
+ Bind_Handler (Interrupt);
+ end if;
+ end Unprotected_Exchange_Handler;
+
+ -- Start of processing for Interrupt_Manager
+
+ begin
+ loop
+ -- A block is needed to absorb Program_Error exception
+
+ declare
+ Old_Handler : Parameterless_Handler;
+
+ begin
+ select
+ accept Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False)
+ do
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static, Restoration);
+ end Attach_Handler;
+
+ or
+ accept Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean)
+ do
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static);
+ end Exchange_Handler;
+
+ or
+ accept Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
+ do
+ Unprotected_Detach_Handler (Interrupt, Static);
+ end Detach_Handler;
+
+ or
+ accept Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID)
+ do
+ -- If there is a binding already (either a procedure or an
+ -- entry), raise Program_Error (propagate it to the caller).
+
+ if User_Handler (Interrupt).H /= null
+ or else User_Entry (Interrupt).T /= Null_Task
+ then
+ raise Program_Error with
+ "a binding for this interrupt is already present";
+ end if;
+
+ User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
+
+ -- Indicate the attachment of interrupt entry in the ATCB.
+ -- This is needed so when an interrupt entry task terminates
+ -- the binding can be cleaned. The call to unbinding must be
+ -- make by the task before it terminates.
+
+ T.Interrupt_Entry := True;
+
+ -- Invoke a corresponding Server_Task if not yet created.
+ -- Place Task_Id info in Server_ID array.
+
+ if Server_ID (Interrupt) = Null_Task
+ or else
+ Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt)))
+ then
+ Interrupt_Access_Hold := new Interrupt_Server_Task
+ (Interrupt, Binary_Semaphore_Create);
+ Server_ID (Interrupt) :=
+ To_System (Interrupt_Access_Hold.all'Identity);
+ end if;
+
+ Bind_Handler (Interrupt);
+ end Bind_Interrupt_To_Entry;
+
+ or
+ accept Detach_Interrupt_Entries (T : Task_Id) do
+ for Int in Interrupt_ID'Range loop
+ if not Is_Reserved (Int) then
+ if User_Entry (Int).T = T then
+ User_Entry (Int) :=
+ Entry_Assoc'
+ (T => Null_Task, E => Null_Task_Entry);
+ Unbind_Handler (Int);
+ end if;
+ end if;
+ end loop;
+
+ -- Indicate in ATCB that no interrupt entries are attached
+
+ T.Interrupt_Entry := False;
+ end Detach_Interrupt_Entries;
+ end select;
+
+ exception
+ -- If there is a Program_Error we just want to propagate it to
+ -- the caller and do not want to stop this task.
+
+ when Program_Error =>
+ null;
+
+ when others =>
+ pragma Assert (False);
+ null;
+ end;
+ end loop;
+
+ exception
+ when Standard'Abort_Signal =>
+
+ -- Flush interrupt server semaphores, so they can terminate
+
+ Finalize_Interrupt_Servers;
+ raise;
+ end Interrupt_Manager;
+
+ ---------------------------
+ -- Interrupt_Server_Task --
+ ---------------------------
+
+ -- Server task for vectored hardware interrupt handling
+
+ task body Interrupt_Server_Task is
+ Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
+
+ Self_Id : constant Task_Id := Self;
+ Tmp_Handler : Parameterless_Handler;
+ Tmp_ID : Task_Id;
+ Tmp_Entry_Index : Task_Entry_Index;
+ Status : int;
+
+ begin
+ Semaphore_ID_Map (Interrupt) := Int_Sema;
+
+ loop
+ -- Pend on semaphore that will be triggered by the umbrella handler
+ -- when the associated interrupt comes in.
+
+ Status := Binary_Semaphore_Obtain (Int_Sema);
+ pragma Assert (Status = 0);
+
+ if User_Handler (Interrupt).H /= null then
+
+ -- Protected procedure handler
+
+ Tmp_Handler := User_Handler (Interrupt).H;
+ Tmp_Handler.all;
+
+ elsif User_Entry (Interrupt).T /= Null_Task then
+
+ -- Interrupt entry handler
+
+ Tmp_ID := User_Entry (Interrupt).T;
+ Tmp_Entry_Index := User_Entry (Interrupt).E;
+ System.Tasking.Rendezvous.Call_Simple
+ (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
+
+ else
+ -- Semaphore has been flushed by an unbind operation in the
+ -- Interrupt_Manager. Terminate the server task.
+
+ -- Wait for the Interrupt_Manager to complete its work
+
+ POP.Write_Lock (Self_Id);
+
+ -- Unassociate the interrupt handler
+
+ Semaphore_ID_Map (Interrupt) := 0;
+
+ -- Delete the associated semaphore
+
+ Status := Binary_Semaphore_Delete (Int_Sema);
+
+ pragma Assert (Status = 0);
+
+ -- Set status for the Interrupt_Manager
+
+ Server_ID (Interrupt) := Null_Task;
+ POP.Unlock (Self_Id);
+
+ exit;
+ end if;
+ end loop;
+ end Interrupt_Server_Task;
+
+begin
+ -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
+
+ Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
+end System.Interrupts;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1998-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 --
+-- <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 NT version of this package
+
+with Ada.Task_Identification;
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+with System.Storage_Elements;
+with System.Task_Primitives.Operations;
+with System.Tasking.Utilities;
+with System.Tasking.Rendezvous;
+with System.Tasking.Initialization;
+with System.Interrupt_Management;
+with System.Parameters;
+
+package body System.Interrupts is
+
+ use Parameters;
+ use Tasking;
+ use System.OS_Interface;
+ use Interfaces.C;
+
+ package STPO renames System.Task_Primitives.Operations;
+ package IMNG renames System.Interrupt_Management;
+
+ subtype int is Interfaces.C.int;
+
+ function To_System is new Ada.Unchecked_Conversion
+ (Ada.Task_Identification.Task_Id, Task_Id);
+
+ type Handler_Kind is (Unknown, Task_Entry, Protected_Procedure);
+
+ type Handler_Desc is record
+ Kind : Handler_Kind := Unknown;
+ T : Task_Id;
+ E : Task_Entry_Index;
+ H : Parameterless_Handler;
+ Static : Boolean := False;
+ end record;
+
+ task type Server_Task (Interrupt : Interrupt_ID) is
+ pragma Interrupt_Priority (System.Interrupt_Priority'Last);
+ end Server_Task;
+
+ type Server_Task_Access is access Server_Task;
+
+ Handlers : array (Interrupt_ID) of Task_Id;
+ Descriptors : array (Interrupt_ID) of Handler_Desc;
+ Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0);
+
+ pragma Volatile_Components (Interrupt_Count);
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean);
+ -- This internal procedure is needed to finalize protected objects that
+ -- contain interrupt handlers.
+
+ procedure Signal_Handler (Sig : Interrupt_ID);
+ pragma Convention (C, Signal_Handler);
+ -- This procedure is used to handle all the signals
+
+ -- Type and Head, Tail of the list containing Registered Interrupt
+ -- Handlers. These definitions are used to register the handlers
+ -- specified by the pragma Interrupt_Handler.
+
+ --------------------------
+ -- Handler Registration --
+ --------------------------
+
+ type Registered_Handler;
+ type R_Link is access all Registered_Handler;
+
+ type Registered_Handler is record
+ H : System.Address := System.Null_Address;
+ Next : R_Link := null;
+ end record;
+
+ Registered_Handlers : R_Link := null;
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean;
+ -- See if the Handler has been "pragma"ed using Interrupt_Handler.
+ -- Always consider a null handler as registered.
+
+ type Handler_Ptr is access procedure (Sig : Interrupt_ID);
+ pragma Convention (C, Handler_Ptr);
+
+ function TISR is new Ada.Unchecked_Conversion (Handler_Ptr, isr_address);
+
+ --------------------
+ -- Signal_Handler --
+ --------------------
+
+ procedure Signal_Handler (Sig : Interrupt_ID) is
+ Handler : Task_Id renames Handlers (Sig);
+
+ begin
+ if Intr_Attach_Reset and then
+ intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR
+ then
+ raise Program_Error;
+ end if;
+
+ if Handler /= null then
+ Interrupt_Count (Sig) := Interrupt_Count (Sig) + 1;
+ STPO.Wakeup (Handler, Interrupt_Server_Idle_Sleep);
+ end if;
+ end Signal_Handler;
+
+ -----------------
+ -- Is_Reserved --
+ -----------------
+
+ function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
+ end Is_Reserved;
+
+ -----------------------
+ -- Is_Entry_Attached --
+ -----------------------
+
+ function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error with
+ "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
+ end if;
+
+ return Descriptors (Interrupt).T /= Null_Task;
+ end Is_Entry_Attached;
+
+ -------------------------
+ -- Is_Handler_Attached --
+ -------------------------
+
+ function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error with
+ "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
+ else
+ return Descriptors (Interrupt).Kind /= Unknown;
+ end if;
+ end Is_Handler_Attached;
+
+ ----------------
+ -- Is_Ignored --
+ ----------------
+
+ function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ raise Program_Error;
+ return False;
+ end Is_Ignored;
+
+ ------------------
+ -- Unblocked_By --
+ ------------------
+
+ function Unblocked_By (Interrupt : Interrupt_ID) return Task_Id is
+ begin
+ raise Program_Error;
+ return Null_Task;
+ end Unblocked_By;
+
+ ----------------------
+ -- Ignore_Interrupt --
+ ----------------------
+
+ procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Ignore_Interrupt;
+
+ ------------------------
+ -- Unignore_Interrupt --
+ ------------------------
+
+ procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Unignore_Interrupt;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Dynamic_Interrupt_Protection) return Boolean
+ is
+ pragma Unreferenced (Object);
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Static_Interrupt_Protection) is
+ begin
+ -- ??? loop to be executed only when we're not doing library level
+ -- finalization, since in this case all interrupt tasks are gone.
+
+ for N in reverse Object.Previous_Handlers'Range loop
+ Attach_Handler
+ (New_Handler => Object.Previous_Handlers (N).Handler,
+ Interrupt => Object.Previous_Handlers (N).Interrupt,
+ Static => Object.Previous_Handlers (N).Static,
+ Restoration => True);
+ end loop;
+
+ Tasking.Protected_Objects.Entries.Finalize
+ (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
+ end Finalize;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Static_Interrupt_Protection) return Boolean
+ is
+ pragma Unreferenced (Object);
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------------
+ -- Install_Handlers --
+ ----------------------
+
+ procedure Install_Handlers
+ (Object : access Static_Interrupt_Protection;
+ New_Handlers : New_Handler_Array)
+ is
+ begin
+ for N in New_Handlers'Range loop
+
+ -- We need a lock around this ???
+
+ Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
+ Object.Previous_Handlers (N).Static := Descriptors
+ (New_Handlers (N).Interrupt).Static;
+
+ -- We call Exchange_Handler and not directly Interrupt_Manager.
+ -- Exchange_Handler so we get the Is_Reserved check.
+
+ Exchange_Handler
+ (Old_Handler => Object.Previous_Handlers (N).Handler,
+ New_Handler => New_Handlers (N).Handler,
+ Interrupt => New_Handlers (N).Interrupt,
+ Static => True);
+ end loop;
+ end Install_Handlers;
+
+ ---------------------------------
+ -- Install_Restricted_Handlers --
+ ---------------------------------
+
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array)
+ is
+ pragma Unreferenced (Prio);
+ begin
+ for N in Handlers'Range loop
+ Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
+ end loop;
+ end Install_Restricted_Handlers;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind = Protected_Procedure then
+ return Descriptors (Interrupt).H;
+ else
+ return null;
+ end if;
+ end Current_Handler;
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Attach_Handler (New_Handler, Interrupt, Static, False);
+ end Attach_Handler;
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean)
+ is
+ New_Task : Server_Task_Access;
+
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if not Restoration and then not Static
+
+ -- Tries to overwrite a static Interrupt Handler with dynamic handle
+
+ and then
+ (Descriptors (Interrupt).Static
+
+ -- New handler not specified as an Interrupt Handler by a pragma
+
+ or else not Is_Registered (New_Handler))
+ then
+ raise Program_Error with
+ "trying to overwrite a static interrupt handler with a " &
+ "dynamic handler";
+ end if;
+
+ if Handlers (Interrupt) = null then
+ New_Task := new Server_Task (Interrupt);
+ Handlers (Interrupt) := To_System (New_Task.all'Identity);
+ end if;
+
+ if intr_attach (int (Interrupt),
+ TISR (Signal_Handler'Access)) = FUNC_ERR
+ then
+ raise Program_Error;
+ end if;
+
+ if New_Handler = null then
+
+ -- The null handler means we are detaching the handler
+
+ Descriptors (Interrupt) :=
+ (Kind => Unknown, T => null, E => 0, H => null, Static => False);
+
+ else
+ Descriptors (Interrupt).Kind := Protected_Procedure;
+ Descriptors (Interrupt).H := New_Handler;
+ Descriptors (Interrupt).Static := Static;
+ end if;
+ end Attach_Handler;
+
+ ----------------------
+ -- Exchange_Handler --
+ ----------------------
+
+ procedure Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind = Task_Entry then
+
+ -- In case we have an Interrupt Entry already installed, raise a
+ -- program error (propagate it to the caller).
+
+ raise Program_Error with "an interrupt is already installed";
+
+ else
+ Old_Handler := Current_Handler (Interrupt);
+ Attach_Handler (New_Handler, Interrupt, Static);
+ end if;
+ end Exchange_Handler;
+
+ --------------------
+ -- Detach_Handler --
+ --------------------
+
+ procedure Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind = Task_Entry then
+ raise Program_Error with "trying to detach an interrupt entry";
+ end if;
+
+ if not Static and then Descriptors (Interrupt).Static then
+ raise Program_Error with
+ "trying to detach a static interrupt handler";
+ end if;
+
+ Descriptors (Interrupt) :=
+ (Kind => Unknown, T => null, E => 0, H => null, Static => False);
+
+ if intr_attach (int (Interrupt), null) = FUNC_ERR then
+ raise Program_Error;
+ end if;
+ end Detach_Handler;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ Signal : constant System.Address :=
+ System.Storage_Elements.To_Address
+ (System.Storage_Elements.Integer_Address (Interrupt));
+
+ begin
+ if Is_Reserved (Interrupt) then
+
+ -- Only usable Interrupts can be used for binding it to an Entry
+
+ raise Program_Error;
+ end if;
+
+ return Signal;
+ end Reference;
+
+ --------------------------------
+ -- Register_Interrupt_Handler --
+ --------------------------------
+
+ procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
+ begin
+ Registered_Handlers :=
+ new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers);
+ end Register_Interrupt_Handler;
+
+ -------------------
+ -- Is_Registered --
+ -------------------
+
+ -- See if the Handler has been "pragma"ed using Interrupt_Handler.
+ -- Always consider a null handler as registered.
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean is
+ Ptr : R_Link := Registered_Handlers;
+
+ type Fat_Ptr is record
+ Object_Addr : System.Address;
+ Handler_Addr : System.Address;
+ end record;
+
+ function To_Fat_Ptr is new Ada.Unchecked_Conversion
+ (Parameterless_Handler, Fat_Ptr);
+
+ Fat : Fat_Ptr;
+
+ begin
+ if Handler = null then
+ return True;
+ end if;
+
+ Fat := To_Fat_Ptr (Handler);
+
+ while Ptr /= null loop
+ if Ptr.H = Fat.Handler_Addr then
+ return True;
+ end if;
+
+ Ptr := Ptr.Next;
+ end loop;
+
+ return False;
+ end Is_Registered;
+
+ -----------------------------
+ -- Bind_Interrupt_To_Entry --
+ -----------------------------
+
+ procedure Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Int_Ref : System.Address)
+ is
+ Interrupt : constant Interrupt_ID :=
+ Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
+
+ New_Task : Server_Task_Access;
+
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind /= Unknown then
+ raise Program_Error with
+ "a binding for this interrupt is already present";
+ end if;
+
+ if Handlers (Interrupt) = null then
+ New_Task := new Server_Task (Interrupt);
+ Handlers (Interrupt) := To_System (New_Task.all'Identity);
+ end if;
+
+ if intr_attach (int (Interrupt),
+ TISR (Signal_Handler'Access)) = FUNC_ERR
+ then
+ raise Program_Error;
+ end if;
+
+ Descriptors (Interrupt).Kind := Task_Entry;
+ Descriptors (Interrupt).T := T;
+ Descriptors (Interrupt).E := E;
+
+ -- Indicate the attachment of Interrupt Entry in ATCB. This is needed so
+ -- that when an Interrupt Entry task terminates the binding can be
+ -- cleaned up. The call to unbinding must be make by the task before it
+ -- terminates.
+
+ T.Interrupt_Entry := True;
+ end Bind_Interrupt_To_Entry;
+
+ ------------------------------
+ -- Detach_Interrupt_Entries --
+ ------------------------------
+
+ procedure Detach_Interrupt_Entries (T : Task_Id) is
+ begin
+ for J in Interrupt_ID loop
+ if not Is_Reserved (J) then
+ if Descriptors (J).Kind = Task_Entry
+ and then Descriptors (J).T = T
+ then
+ Descriptors (J).Kind := Unknown;
+
+ if intr_attach (int (J), null) = FUNC_ERR then
+ raise Program_Error;
+ end if;
+ end if;
+ end if;
+ end loop;
+
+ -- Indicate in ATCB that no Interrupt Entries are attached
+
+ T.Interrupt_Entry := True;
+ end Detach_Interrupt_Entries;
+
+ ---------------------
+ -- Block_Interrupt --
+ ---------------------
+
+ procedure Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Block_Interrupt;
+
+ -----------------------
+ -- Unblock_Interrupt --
+ -----------------------
+
+ procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Unblock_Interrupt;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ raise Program_Error;
+ return False;
+ end Is_Blocked;
+
+ task body Server_Task is
+ Ignore : constant Boolean := Utilities.Make_Independent;
+
+ Desc : Handler_Desc renames Descriptors (Interrupt);
+ Self_Id : constant Task_Id := STPO.Self;
+ Temp : Parameterless_Handler;
+
+ begin
+ loop
+ while Interrupt_Count (Interrupt) > 0 loop
+ Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1;
+ begin
+ case Desc.Kind is
+ when Unknown =>
+ null;
+ when Task_Entry =>
+ Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address);
+ when Protected_Procedure =>
+ Temp := Desc.H;
+ Temp.all;
+ end case;
+ exception
+ when others => null;
+ end;
+ end loop;
+
+ Initialization.Defer_Abort (Self_Id);
+
+ if Single_Lock then
+ STPO.Lock_RTS;
+ end if;
+
+ STPO.Write_Lock (Self_Id);
+ Self_Id.Common.State := Interrupt_Server_Idle_Sleep;
+ STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep);
+ Self_Id.Common.State := Runnable;
+ STPO.Unlock (Self_Id);
+
+ if Single_Lock then
+ STPO.Unlock_RTS;
+ end if;
+
+ Initialization.Undefer_Abort (Self_Id);
+
+ -- Undefer abort here to allow a window for this task to be aborted
+ -- at the time of system shutdown.
+
+ end loop;
+ end Server_Task;
+
+end System.Interrupts;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T 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 --
+-- <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. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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.
+
+-- 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).
+
+-- 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.
+
+-- 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,
+-- we use the per-task lock of the Server_Task instead so that we protect the
+-- 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;
+
+with Interfaces.C; use Interfaces.C;
+with System.OS_Interface; use System.OS_Interface;
+with System.Interrupt_Management;
+with System.Task_Primitives.Operations;
+with System.Storage_Elements;
+with System.Tasking.Utilities;
+
+with System.Tasking.Rendezvous;
+pragma Elaborate_All (System.Tasking.Rendezvous);
+
+package body System.Interrupts is
+
+ use Tasking;
+
+ package POP renames System.Task_Primitives.Operations;
+
+ function To_Ada is new Ada.Unchecked_Conversion
+ (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id);
+
+ function To_System is new Ada.Unchecked_Conversion
+ (Ada.Task_Identification.Task_Id, Task_Id);
+
+ -----------------
+ -- Local Tasks --
+ -----------------
+
+ -- WARNING: System.Tasking.Stages performs calls to this task with low-
+ -- level constructs. Do not change this spec without synchronizing it.
+
+ task Interrupt_Manager is
+ entry Detach_Interrupt_Entries (T : Task_Id);
+
+ entry Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
+
+ entry Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ entry Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ entry Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID);
+
+ pragma Interrupt_Priority (System.Interrupt_Priority'First);
+ end Interrupt_Manager;
+
+ task type Interrupt_Server_Task
+ (Interrupt : Interrupt_ID;
+ Int_Sema : Binary_Semaphore_Id)
+ is
+ -- Server task for vectored hardware interrupt handling
+
+ pragma Interrupt_Priority (System.Interrupt_Priority'First + 2);
+ end Interrupt_Server_Task;
+
+ type Interrupt_Task_Access is access Interrupt_Server_Task;
+
+ -------------------------------
+ -- Local Types and Variables --
+ -------------------------------
+
+ type Entry_Assoc is record
+ T : Task_Id;
+ E : Task_Entry_Index;
+ end record;
+
+ type Handler_Assoc is record
+ H : Parameterless_Handler;
+ Static : Boolean; -- Indicates static binding;
+ end record;
+
+ User_Handler : array (Interrupt_ID) of Handler_Assoc :=
+ (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
+ -- 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
+
+ -- Type and Head, Tail of the list containing Registered Interrupt
+ -- Handlers. These definitions are used to register the handlers
+ -- specified by the pragma Interrupt_Handler.
+
+ type Registered_Handler;
+ type R_Link is access all Registered_Handler;
+
+ type Registered_Handler is record
+ H : System.Address := System.Null_Address;
+ Next : R_Link := null;
+ end record;
+
+ Registered_Handler_Head : R_Link := null;
+ Registered_Handler_Tail : R_Link := null;
+
+ Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id :=
+ (others => System.Tasking.Null_Task);
+ pragma Atomic_Components (Server_ID);
+ -- Holds the Task_Id of the Server_Task for each interrupt / signal.
+ -- Task_Id is needed to accomplish locking per interrupt base. Also
+ -- is needed to determine whether to create a new Server_Task.
+
+ Semaphore_ID_Map : array
+ (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) of
+ Binary_Semaphore_Id := (others => 0);
+ -- Array of binary semaphores associated with vectored interrupts. Note
+ -- that the last bound should be Max_HW_Interrupt, but this will raise
+ -- Storage_Error if Num_HW_Interrupts is null so use extra 4 bytes instead.
+
+ Interrupt_Access_Hold : Interrupt_Task_Access;
+ -- Variable for allocating an Interrupt_Server_Task
+
+ Handler_Installed : array (HW_Interrupt) of Boolean := (others => False);
+ -- True if Notify_Interrupt was connected to the interrupt. Handlers can
+ -- be connected but disconnection is not possible on VxWorks. Therefore
+ -- we ensure Notify_Installed is connected at most once.
+
+ type Interrupt_Connector is access function
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int;
+ -- Profile must match VxWorks intConnect()
+
+ Interrupt_Connect : Interrupt_Connector :=
+ System.OS_Interface.Interrupt_Connect'Access;
+ pragma Export (C, Interrupt_Connect, "__gnat_user_int_connect");
+ -- Allow user alternatives to the OS implementation of
+ -- System.OS_Interface.Interrupt_Connect. This allows the user to
+ -- associate a handler with an interrupt source when an alternate routine
+ -- is needed to do so. The association is performed in
+ -- Interfaces.VxWorks.Interrupt_Connections. Defaults to the standard OS
+ -- connection routine.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID);
+ -- Check if Id is a reserved interrupt, and if so raise Program_Error
+ -- with an appropriate message, otherwise return.
+
+ procedure Finalize_Interrupt_Servers;
+ -- Unbind the handlers for hardware interrupt server tasks at program
+ -- termination.
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean;
+ -- See if Handler has been "pragma"ed using Interrupt_Handler.
+ -- Always consider a null handler as registered.
+
+ procedure Notify_Interrupt (Param : System.Address);
+ pragma Convention (C, Notify_Interrupt);
+ -- Umbrella handler for vectored interrupts (not signals)
+
+ procedure Install_Umbrella_Handler
+ (Interrupt : HW_Interrupt;
+ Handler : System.OS_Interface.Interrupt_Handler);
+ -- Install the runtime umbrella handler for a vectored hardware
+ -- interrupt
+
+ procedure Unimplemented (Feature : String);
+ pragma No_Return (Unimplemented);
+ -- Used to mark a call to an unimplemented function. Raises Program_Error
+ -- with an appropriate message noting that Feature is unimplemented.
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ -- Calling this procedure with New_Handler = null and Static = True
+ -- means we want to detach the current handler regardless of the previous
+ -- handler's binding status (i.e. do not care if it is a dynamic or static
+ -- handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False) is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
+ end Attach_Handler;
+
+ -----------------------------
+ -- Bind_Interrupt_To_Entry --
+ -----------------------------
+
+ -- This procedure raises a Program_Error if it tries to
+ -- bind an interrupt to which an Entry or a Procedure is
+ -- already bound.
+
+ procedure Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Int_Ref : System.Address)
+ is
+ Interrupt : constant Interrupt_ID :=
+ Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
+ end Bind_Interrupt_To_Entry;
+
+ ---------------------
+ -- Block_Interrupt --
+ ---------------------
+
+ procedure Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Block_Interrupt");
+ end Block_Interrupt;
+
+ ------------------------------
+ -- Check_Reserved_Interrupt --
+ ------------------------------
+
+ procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error with
+ "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
+ else
+ return;
+ end if;
+ end Check_Reserved_Interrupt;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+
+ -- ??? Since Parameterless_Handler is not Atomic, the current
+ -- implementation is wrong. We need a new service in Interrupt_Manager
+ -- to ensure atomicity.
+
+ return User_Handler (Interrupt).H;
+ end Current_Handler;
+
+ --------------------
+ -- Detach_Handler --
+ --------------------
+
+ -- Calling this procedure with Static = True means we want to Detach the
+ -- current handler regardless of the previous handler's binding status
+ -- (i.e. do not care if it is a dynamic or static handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Detach_Handler (Interrupt, Static);
+ end Detach_Handler;
+
+ ------------------------------
+ -- Detach_Interrupt_Entries --
+ ------------------------------
+
+ procedure Detach_Interrupt_Entries (T : Task_Id) is
+ begin
+ Interrupt_Manager.Detach_Interrupt_Entries (T);
+ end Detach_Interrupt_Entries;
+
+ ----------------------
+ -- Exchange_Handler --
+ ----------------------
+
+ -- Calling this procedure with New_Handler = null and Static = True
+ -- means we want to detach the current handler regardless of the previous
+ -- handler's binding status (i.e. we do not care if it is a dynamic or
+ -- static handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static);
+ end Exchange_Handler;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Static_Interrupt_Protection) is
+ begin
+ -- ??? loop to be executed only when we're not doing library level
+ -- finalization, since in this case all interrupt / signal tasks are
+ -- gone.
+
+ if not Interrupt_Manager'Terminated then
+ for N in reverse Object.Previous_Handlers'Range loop
+ Interrupt_Manager.Attach_Handler
+ (New_Handler => Object.Previous_Handlers (N).Handler,
+ Interrupt => Object.Previous_Handlers (N).Interrupt,
+ Static => Object.Previous_Handlers (N).Static,
+ Restoration => True);
+ end loop;
+ end if;
+
+ Tasking.Protected_Objects.Entries.Finalize
+ (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
+ end Finalize;
+
+ --------------------------------
+ -- Finalize_Interrupt_Servers --
+ --------------------------------
+
+ -- Restore default handlers for interrupt servers
+
+ -- This is called by the Interrupt_Manager task when it receives the abort
+ -- signal during program finalization.
+
+ procedure Finalize_Interrupt_Servers is
+ HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
+ begin
+ if HW_Interrupts then
+ for Int in HW_Interrupt loop
+ if Server_ID (Interrupt_ID (Int)) /= null
+ and then
+ not Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt_ID (Int))))
+ then
+ Interrupt_Manager.Attach_Handler
+ (New_Handler => null,
+ Interrupt => Interrupt_ID (Int),
+ Static => True,
+ Restoration => True);
+ end if;
+ end loop;
+ end if;
+ end Finalize_Interrupt_Servers;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Dynamic_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Unreferenced (Object);
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Static_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Unreferenced (Object);
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------------
+ -- Ignore_Interrupt --
+ ----------------------
+
+ procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Ignore_Interrupt");
+ end Ignore_Interrupt;
+
+ ----------------------
+ -- Install_Handlers --
+ ----------------------
+
+ procedure Install_Handlers
+ (Object : access Static_Interrupt_Protection;
+ New_Handlers : New_Handler_Array)
+ is
+ begin
+ for N in New_Handlers'Range loop
+
+ -- We need a lock around this ???
+
+ Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
+ Object.Previous_Handlers (N).Static := User_Handler
+ (New_Handlers (N).Interrupt).Static;
+
+ -- We call Exchange_Handler and not directly Interrupt_Manager.
+ -- Exchange_Handler so we get the Is_Reserved check.
+
+ Exchange_Handler
+ (Old_Handler => Object.Previous_Handlers (N).Handler,
+ New_Handler => New_Handlers (N).Handler,
+ Interrupt => New_Handlers (N).Interrupt,
+ Static => True);
+ end loop;
+ end Install_Handlers;
+
+ ---------------------------------
+ -- Install_Restricted_Handlers --
+ ---------------------------------
+
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array)
+ is
+ pragma Unreferenced (Prio);
+ begin
+ for N in Handlers'Range loop
+ Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
+ end loop;
+ end Install_Restricted_Handlers;
+
+ ------------------------------
+ -- Install_Umbrella_Handler --
+ ------------------------------
+
+ procedure Install_Umbrella_Handler
+ (Interrupt : HW_Interrupt;
+ Handler : System.OS_Interface.Interrupt_Handler)
+ is
+ Vec : constant Interrupt_Vector :=
+ Interrupt_Number_To_Vector (int (Interrupt));
+
+ Status : int;
+
+ begin
+ -- Only install umbrella handler when no Ada handler has already been
+ -- installed. Note that the interrupt number is passed as a parameter
+ -- when an interrupt occurs, so the umbrella handler has a different
+ -- wrapper generated by the connector routine for each interrupt
+ -- number.
+
+ if not Handler_Installed (Interrupt) then
+ Status :=
+ Interrupt_Connect.all (Vec, Handler, System.Address (Interrupt));
+ pragma Assert (Status = 0);
+
+ Handler_Installed (Interrupt) := True;
+ end if;
+ end Install_Umbrella_Handler;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented ("Is_Blocked");
+ return False;
+ end Is_Blocked;
+
+ -----------------------
+ -- Is_Entry_Attached --
+ -----------------------
+
+ function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return User_Entry (Interrupt).T /= Null_Task;
+ end Is_Entry_Attached;
+
+ -------------------------
+ -- Is_Handler_Attached --
+ -------------------------
+
+ function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return User_Handler (Interrupt).H /= null;
+ end Is_Handler_Attached;
+
+ ----------------
+ -- Is_Ignored --
+ ----------------
+
+ function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented ("Is_Ignored");
+ return False;
+ end Is_Ignored;
+
+ -------------------
+ -- Is_Registered --
+ -------------------
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean is
+ type Fat_Ptr is record
+ Object_Addr : System.Address;
+ Handler_Addr : System.Address;
+ end record;
+
+ function To_Fat_Ptr is new Ada.Unchecked_Conversion
+ (Parameterless_Handler, Fat_Ptr);
+
+ Ptr : R_Link;
+ Fat : Fat_Ptr;
+
+ begin
+ if Handler = null then
+ return True;
+ end if;
+
+ Fat := To_Fat_Ptr (Handler);
+
+ Ptr := Registered_Handler_Head;
+ while Ptr /= null loop
+ if Ptr.H = Fat.Handler_Addr then
+ return True;
+ end if;
+
+ Ptr := Ptr.Next;
+ end loop;
+
+ return False;
+ end Is_Registered;
+
+ -----------------
+ -- Is_Reserved --
+ -----------------
+
+ function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ use System.Interrupt_Management;
+ begin
+ return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt));
+ end Is_Reserved;
+
+ ----------------------
+ -- Notify_Interrupt --
+ ----------------------
+
+ -- Umbrella handler for vectored hardware interrupts (as opposed to signals
+ -- and exceptions). As opposed to the signal implementation, this handler
+ -- is installed in the vector table when the first Ada handler is attached
+ -- to the interrupt. However because VxWorks don't support disconnecting
+ -- handlers, this subprogram always test whether or not an Ada handler is
+ -- effectively attached.
+
+ -- Otherwise, the handler that existed prior to program startup is in the
+ -- vector table. This ensures that handlers installed by the BSP are active
+ -- unless explicitly replaced in the program text.
+
+ -- Each Interrupt_Server_Task has an associated binary semaphore on which
+ -- it pends once it's been started. This routine determines The appropriate
+ -- semaphore and issues a semGive call, waking the server task. When
+ -- a handler is unbound, System.Interrupts.Unbind_Handler issues a
+ -- Binary_Semaphore_Flush, and the server task deletes its semaphore
+ -- and terminates.
+
+ procedure Notify_Interrupt (Param : System.Address) is
+ Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
+ Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt);
+ Status : int;
+ begin
+ if Id /= 0 then
+ Status := Binary_Semaphore_Release (Id);
+ pragma Assert (Status = 0);
+ end if;
+ end Notify_Interrupt;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return Storage_Elements.To_Address
+ (Storage_Elements.Integer_Address (Interrupt));
+ end Reference;
+
+ --------------------------------
+ -- Register_Interrupt_Handler --
+ --------------------------------
+
+ procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
+ New_Node_Ptr : R_Link;
+
+ begin
+ -- This routine registers a handler as usable for dynamic interrupt
+ -- handler association. Routines attaching and detaching handlers
+ -- dynamically should determine whether the handler is registered.
+ -- Program_Error should be raised if it is not registered.
+
+ -- Pragma Interrupt_Handler can only appear in a library level PO
+ -- definition and instantiation. Therefore, we do not need to implement
+ -- an unregister operation. Nor do we need to protect the queue
+ -- structure with a lock.
+
+ pragma Assert (Handler_Addr /= System.Null_Address);
+
+ New_Node_Ptr := new Registered_Handler;
+ New_Node_Ptr.H := Handler_Addr;
+
+ if Registered_Handler_Head = null then
+ Registered_Handler_Head := New_Node_Ptr;
+ Registered_Handler_Tail := New_Node_Ptr;
+ else
+ Registered_Handler_Tail.Next := New_Node_Ptr;
+ Registered_Handler_Tail := New_Node_Ptr;
+ end if;
+ end Register_Interrupt_Handler;
+
+ -----------------------
+ -- Unblock_Interrupt --
+ -----------------------
+
+ procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Unblock_Interrupt");
+ end Unblock_Interrupt;
+
+ ------------------
+ -- Unblocked_By --
+ ------------------
+
+ function Unblocked_By
+ (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
+ is
+ begin
+ Unimplemented ("Unblocked_By");
+ return Null_Task;
+ end Unblocked_By;
+
+ ------------------------
+ -- Unignore_Interrupt --
+ ------------------------
+
+ procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Unignore_Interrupt");
+ end Unignore_Interrupt;
+
+ -------------------
+ -- Unimplemented --
+ -------------------
+
+ procedure Unimplemented (Feature : String) is
+ begin
+ raise Program_Error with Feature & " not implemented on VxWorks";
+ end Unimplemented;
+
+ -----------------------
+ -- Interrupt_Manager --
+ -----------------------
+
+ task body Interrupt_Manager is
+ -- By making this task independent of any master, when the process goes
+ -- away, the Interrupt_Manager will terminate gracefully.
+
+ Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
+ pragma Unreferenced (Ignore);
+
+ --------------------
+ -- Local Routines --
+ --------------------
+
+ procedure Bind_Handler (Interrupt : Interrupt_ID);
+ -- This procedure does not do anything if a signal is blocked.
+ -- Otherwise, we have to interrupt Server_Task for status change
+ -- through a wakeup signal.
+
+ procedure Unbind_Handler (Interrupt : Interrupt_ID);
+ -- This procedure does not do anything if a signal is blocked.
+ -- Otherwise, we have to interrupt Server_Task for status change
+ -- through an abort signal.
+
+ procedure Unprotected_Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
+
+ procedure Unprotected_Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ ------------------
+ -- Bind_Handler --
+ ------------------
+
+ procedure Bind_Handler (Interrupt : Interrupt_ID) is
+ begin
+ Install_Umbrella_Handler
+ (HW_Interrupt (Interrupt), Notify_Interrupt'Access);
+ end Bind_Handler;
+
+ --------------------
+ -- Unbind_Handler --
+ --------------------
+
+ procedure Unbind_Handler (Interrupt : Interrupt_ID) is
+ Status : int;
+
+ begin
+ -- Flush server task off semaphore, allowing it to terminate
+
+ Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt));
+ pragma Assert (Status = 0);
+ end Unbind_Handler;
+
+ --------------------------------
+ -- Unprotected_Detach_Handler --
+ --------------------------------
+
+ procedure Unprotected_Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
+ is
+ Old_Handler : Parameterless_Handler;
+ begin
+ if User_Entry (Interrupt).T /= Null_Task then
+
+ -- If an interrupt entry is installed raise Program_Error
+ -- (propagate it to the caller).
+
+ raise Program_Error with
+ "an interrupt entry is already installed";
+ end if;
+
+ -- Note : Static = True will pass the following check. This is the
+ -- case when we want to detach a handler regardless of the static
+ -- status of the Current_Handler.
+
+ if not Static and then User_Handler (Interrupt).Static then
+
+ -- Trying to detach a static Interrupt Handler, raise
+ -- Program_Error.
+
+ raise Program_Error with
+ "trying to detach a static Interrupt Handler";
+ end if;
+
+ Old_Handler := User_Handler (Interrupt).H;
+
+ -- The new handler
+
+ User_Handler (Interrupt).H := null;
+ User_Handler (Interrupt).Static := False;
+
+ if Old_Handler /= null then
+ Unbind_Handler (Interrupt);
+ end if;
+ end Unprotected_Detach_Handler;
+
+ ----------------------------------
+ -- Unprotected_Exchange_Handler --
+ ----------------------------------
+
+ procedure Unprotected_Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False)
+ is
+ begin
+ if User_Entry (Interrupt).T /= Null_Task then
+
+ -- If an interrupt entry is already installed, raise
+ -- Program_Error (propagate it to the caller).
+
+ raise Program_Error with "an interrupt is already installed";
+ end if;
+
+ -- Note : A null handler with Static = True will pass the following
+ -- check. This is the case when we want to detach a handler
+ -- regardless of the Static status of Current_Handler.
+
+ -- We don't check anything if Restoration is True, since we may be
+ -- detaching a static handler to restore a dynamic one.
+
+ if not Restoration and then not Static
+ and then (User_Handler (Interrupt).Static
+
+ -- Trying to overwrite a static Interrupt Handler with a dynamic
+ -- Handler
+
+ -- The new handler is not specified as an Interrupt Handler by a
+ -- pragma.
+
+ or else not Is_Registered (New_Handler))
+ then
+ raise Program_Error with
+ "trying to overwrite a static interrupt handler with a "
+ & "dynamic handler";
+ end if;
+
+ -- Save the old handler
+
+ Old_Handler := User_Handler (Interrupt).H;
+
+ -- The new handler
+
+ User_Handler (Interrupt).H := New_Handler;
+
+ if New_Handler = null then
+
+ -- The null handler means we are detaching the handler
+
+ User_Handler (Interrupt).Static := False;
+
+ else
+ User_Handler (Interrupt).Static := Static;
+ end if;
+
+ -- Invoke a corresponding Server_Task if not yet created. Place
+ -- Task_Id info in Server_ID array.
+
+ if New_Handler /= null
+ and then
+ (Server_ID (Interrupt) = Null_Task
+ or else
+ Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt))))
+ then
+ Interrupt_Access_Hold :=
+ new Interrupt_Server_Task (Interrupt, Binary_Semaphore_Create);
+ Server_ID (Interrupt) :=
+ To_System (Interrupt_Access_Hold.all'Identity);
+ end if;
+
+ if (New_Handler = null) and then Old_Handler /= null then
+
+ -- Restore default handler
+
+ Unbind_Handler (Interrupt);
+
+ elsif Old_Handler = null then
+
+ -- Save default handler
+
+ Bind_Handler (Interrupt);
+ end if;
+ end Unprotected_Exchange_Handler;
+
+ -- Start of processing for Interrupt_Manager
+
+ begin
+ loop
+ -- A block is needed to absorb Program_Error exception
+
+ declare
+ Old_Handler : Parameterless_Handler;
+
+ begin
+ select
+ accept Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False)
+ do
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static, Restoration);
+ end Attach_Handler;
+
+ or
+ accept Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean)
+ do
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static);
+ end Exchange_Handler;
+
+ or
+ accept Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
+ do
+ Unprotected_Detach_Handler (Interrupt, Static);
+ end Detach_Handler;
+
+ or
+ accept Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID)
+ do
+ -- If there is a binding already (either a procedure or an
+ -- entry), raise Program_Error (propagate it to the caller).
+
+ if User_Handler (Interrupt).H /= null
+ or else User_Entry (Interrupt).T /= Null_Task
+ then
+ raise Program_Error with
+ "a binding for this interrupt is already present";
+ end if;
+
+ User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
+
+ -- Indicate the attachment of interrupt entry in the ATCB.
+ -- This is needed so when an interrupt entry task terminates
+ -- the binding can be cleaned. The call to unbinding must be
+ -- make by the task before it terminates.
+
+ T.Interrupt_Entry := True;
+
+ -- Invoke a corresponding Server_Task if not yet created.
+ -- Place Task_Id info in Server_ID array.
+
+ if Server_ID (Interrupt) = Null_Task
+ or else
+ Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt)))
+ then
+ Interrupt_Access_Hold := new Interrupt_Server_Task
+ (Interrupt, Binary_Semaphore_Create);
+ Server_ID (Interrupt) :=
+ To_System (Interrupt_Access_Hold.all'Identity);
+ end if;
+
+ Bind_Handler (Interrupt);
+ end Bind_Interrupt_To_Entry;
+
+ or
+ accept Detach_Interrupt_Entries (T : Task_Id) do
+ for Int in Interrupt_ID'Range loop
+ if not Is_Reserved (Int) then
+ if User_Entry (Int).T = T then
+ User_Entry (Int) :=
+ Entry_Assoc'
+ (T => Null_Task, E => Null_Task_Entry);
+ Unbind_Handler (Int);
+ end if;
+ end if;
+ end loop;
+
+ -- Indicate in ATCB that no interrupt entries are attached
+
+ T.Interrupt_Entry := False;
+ end Detach_Interrupt_Entries;
+ end select;
+
+ exception
+ -- If there is a Program_Error we just want to propagate it to
+ -- the caller and do not want to stop this task.
+
+ when Program_Error =>
+ null;
+
+ when others =>
+ pragma Assert (False);
+ null;
+ end;
+ end loop;
+
+ exception
+ when Standard'Abort_Signal =>
+
+ -- Flush interrupt server semaphores, so they can terminate
+
+ Finalize_Interrupt_Servers;
+ raise;
+ end Interrupt_Manager;
+
+ ---------------------------
+ -- Interrupt_Server_Task --
+ ---------------------------
+
+ -- Server task for vectored hardware interrupt handling
+
+ task body Interrupt_Server_Task is
+ Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
+
+ Self_Id : constant Task_Id := Self;
+ Tmp_Handler : Parameterless_Handler;
+ Tmp_ID : Task_Id;
+ Tmp_Entry_Index : Task_Entry_Index;
+ Status : int;
+
+ begin
+ Semaphore_ID_Map (Interrupt) := Int_Sema;
+
+ loop
+ -- Pend on semaphore that will be triggered by the umbrella handler
+ -- when the associated interrupt comes in.
+
+ Status := Binary_Semaphore_Obtain (Int_Sema);
+ pragma Assert (Status = 0);
+
+ if User_Handler (Interrupt).H /= null then
+
+ -- Protected procedure handler
+
+ Tmp_Handler := User_Handler (Interrupt).H;
+ Tmp_Handler.all;
+
+ elsif User_Entry (Interrupt).T /= Null_Task then
+
+ -- Interrupt entry handler
+
+ Tmp_ID := User_Entry (Interrupt).T;
+ Tmp_Entry_Index := User_Entry (Interrupt).E;
+ System.Tasking.Rendezvous.Call_Simple
+ (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
+
+ else
+ -- Semaphore has been flushed by an unbind operation in the
+ -- Interrupt_Manager. Terminate the server task.
+
+ -- Wait for the Interrupt_Manager to complete its work
+
+ POP.Write_Lock (Self_Id);
+
+ -- Unassociate the interrupt handler
+
+ Semaphore_ID_Map (Interrupt) := 0;
+
+ -- Delete the associated semaphore
+
+ Status := Binary_Semaphore_Delete (Int_Sema);
+
+ pragma Assert (Status = 0);
+
+ -- Set status for the Interrupt_Manager
+
+ Server_ID (Interrupt) := Null_Task;
+ POP.Unlock (Self_Id);
+
+ exit;
+ end if;
+ end loop;
+ end Interrupt_Server_Task;
+
+begin
+ -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
+
+ Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
+end System.Interrupts;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 2014-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. --
--- --
--- 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. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Android 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).
-
- 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:
-
- procedure Map_Signal
- (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.
-
-----------------
--- Map_Signal --
-----------------
-
- procedure Map_Signal
- (signo : Signal;
- siginfo : System.Address;
- ucontext : System.Address)
- is
- pragma Unreferenced (siginfo);
- pragma Unreferenced (ucontext);
-
- begin
- -- Check that treatment of exception propagation here is consistent with
- -- treatment of the abort signal in System.Task_Primitives.Operations.
-
- case signo is
- when SIGFPE => raise Constraint_Error;
- when SIGILL => raise Program_Error;
- when SIGSEGV => raise Storage_Error;
- when SIGBUS => raise Storage_Error;
- when others => null;
- end case;
- end Map_Signal;
-
-----------------------
--- Notify_Exception --
-----------------------
-
- 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 is the signal handler and calls a trampoline subprogram
- -- that adjusts the unwind information so the ARM unwinder can find it's
- -- way back to the context of the originating subprogram. Compare with
- -- __gnat_error_handler for non-tasking programs.
-
- ----------------------
- -- 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. ??? We don't use __builtin_longjmp
- -- anymore, so do we still need this? */
-
- Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
- pragma Assert (Result = 0);
-
- -- Perform the necessary context adjustments prior to calling the
- -- trampoline subprogram with the "real" signal handler.
-
- Adjust_Context_For_Raise (signo, ucontext);
-
- 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.
-
- -- We set SA_NODEFER to be compatible with what is done in
- -- __gnat_error_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_NODEFER + SA_RESTART + 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
-
- for J in Reserved'Range loop
- Reserve (Interrupt_ID (Reserved (J))) := True;
- end loop;
-
- -- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1997-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 --
--- <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 a NO tasking version of this package
-
-package body System.Interrupt_Management is
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- null;
- end Initialize;
-
-end System.Interrupt_Management;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <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 LynxOS 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 --
- -----------------------
-
- 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
- pragma Unreferenced (siginfo);
-
- 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.
-
- case signo is
- when SIGFPE => raise Constraint_Error;
- when SIGILL => raise Program_Error;
- when SIGSEGV => raise Storage_Error;
- when SIGBUS => raise Storage_Error;
- when others => null;
- end case;
- 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
- -- This file is identical to s-intman-posix.adb, except that we
- -- don't set the SA_SIGINFO flag in act.sa_flags, because
- -- LynxOS does not support that. If SA_SIGINFO is set, then
- -- sigaction fails, returning -1.
- act.sa_flags := 0;
-
- 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
-
- for J in Reserved'Range loop
- Reserve (Interrupt_ID (Reserved (J))) := True;
- end loop;
-
- -- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 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 --
--- <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 NT version of this package
-
-with System.OS_Interface; use System.OS_Interface;
-
-package body System.Interrupt_Management is
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- -- "Reserve" all the interrupts, except those that are explicitly
- -- defined.
-
- for J in Interrupt_ID'Range loop
- Reserve (J) := True;
- end loop;
-
- Reserve (SIGINT) := False;
- Reserve (SIGILL) := False;
- Reserve (SIGABRT) := False;
- Reserve (SIGFPE) := False;
- Reserve (SIGSEGV) := False;
- Reserve (SIGTERM) := False;
- end Initialize;
-
-end System.Interrupt_Management;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <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 POSIX 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 --
- -----------------------
-
- 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
- pragma Unreferenced (siginfo);
-
- 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.
-
- case signo is
- when SIGFPE => raise Constraint_Error;
- when SIGILL => raise Program_Error;
- when SIGSEGV => raise Storage_Error;
- when SIGBUS => raise Storage_Error;
- when others => null;
- end case;
- 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
-
- for J in Reserved'Range loop
- Reserve (Interrupt_ID (Reserved (J))) := True;
- end loop;
-
- -- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <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 a Solaris 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.
-
-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");
-
- 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)
-
- ----------------------
- -- Notify_Exception --
- ----------------------
-
- -- 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.
-
- procedure Notify_Exception
- (signo : Signal;
- info : access siginfo_t;
- context : access ucontext_t);
-
- ----------------------
- -- Notify_Exception --
- ----------------------
-
- procedure Notify_Exception
- (signo : Signal;
- info : access siginfo_t;
- context : access ucontext_t)
- is
- pragma Unreferenced (info);
-
- begin
- -- Perform the necessary context adjustments prior to a raise from a
- -- signal handler.
-
- Adjust_Context_For_Raise (signo, context.all'Address);
-
- -- Check that treatment of exception propagation here is consistent with
- -- treatment of the abort signal in System.Task_Primitives.Operations.
-
- case signo is
- when SIGFPE => raise Constraint_Error;
- when SIGILL => raise Program_Error;
- when SIGSEGV => raise Storage_Error;
- when SIGBUS => raise Storage_Error;
- when others => null;
- end case;
- end Notify_Exception;
-
- ----------------
- -- Initialize --
- ----------------
-
- Initialized : Boolean := False;
-
- procedure Initialize is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- mask : aliased sigset_t;
- Result : Interfaces.C.int;
-
- begin
- if Initialized then
- return;
- end if;
-
- Initialized := True;
-
- -- Need to call pthread_init very early because it is doing signal
- -- initializations.
-
- pthread_init;
-
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- Abort_Task_Interrupt := SIGABRT;
-
- act.sa_handler := Notify_Exception'Address;
-
- -- 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.
-
- -- In that case, this field should be changed back to 0. ??? (Dong-Ik)
-
- act.sa_flags := 16;
-
- Result := sigemptyset (mask'Access);
- pragma Assert (Result = 0);
-
- -- ??? For the same reason explained above, we can't mask these signals
- -- because otherwise we won't be able to catch more than one signal.
-
- act.sa_mask := mask;
-
- pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
- pragma Assert (Reserve = (Interrupt_ID'Range => False));
-
- 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
- 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's
- -- 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
-
- for J in Reserved'Range loop
- Reserve (Interrupt_ID (Reserved (J))) := True;
- end loop;
-
- -- 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 have Signal 0 in reality. We just use this value to
- -- identify not existing signals (see s-intnam.ads). Therefore, Signal 0
- -- should not be used in all signal related operations hence mark it as
- -- reserved.
-
- Reserve (0) := True;
- end Initialize;
-
-end System.Interrupt_Management;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <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 SuSV3 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:
-
--- 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.
-
-package body System.Interrupt_Management is
-
- use Interfaces.C;
- use System.OS_Interface;
-
- Unreserve_All_Interrupts : Interfaces.C.int;
- pragma Import
- (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
-
- -----------------------
- -- 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
- -- 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)
-
- ----------------
- -- Initialize --
- ----------------
-
- Initialized : Boolean := False;
-
- procedure Initialize is
- 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;
-
- pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
- pragma Assert (Reserve = (Interrupt_ID'Range => False));
-
- -- Process state of exception signals
-
- for J in Exception_Signals'Range loop
- declare
- Sig : constant Signal := Exception_Signals (J);
- Id : constant Interrupt_ID := Interrupt_ID (Sig);
- begin
- if State (Id) /= User then
- Keep_Unmasked (Id) := True;
- Reserve (Id) := True;
- end if;
- end;
- 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
-
- for J in Reserved'Range loop
- Reserve (Interrupt_ID (Reserved (J))) := True;
- end loop;
-
- -- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <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 VxWorks 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;
- use type Interfaces.C.int;
-
- -----------------------
- -- 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;
-
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- Abort_Task_Interrupt := SIGABRT;
-
- -- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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-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 --
--- <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 VxWorks 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_Interrupts;
- pragma Import (C, Initialize_Interrupts, "__gnat_install_handler");
- -- Under VxWorks, there is no signal inheritance between tasks.
- -- This procedure is used to initialize signal-to-exception mapping in
- -- each task.
-
- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 2014-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. --
+-- --
+-- 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. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Android 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).
+
+ 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:
+
+ procedure Map_Signal
+ (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.
+
+----------------
+-- Map_Signal --
+----------------
+
+ procedure Map_Signal
+ (signo : Signal;
+ siginfo : System.Address;
+ ucontext : System.Address)
+ is
+ pragma Unreferenced (siginfo);
+ pragma Unreferenced (ucontext);
+
+ begin
+ -- Check that treatment of exception propagation here is consistent with
+ -- treatment of the abort signal in System.Task_Primitives.Operations.
+
+ case signo is
+ when SIGFPE => raise Constraint_Error;
+ when SIGILL => raise Program_Error;
+ when SIGSEGV => raise Storage_Error;
+ when SIGBUS => raise Storage_Error;
+ when others => null;
+ end case;
+ end Map_Signal;
+
+----------------------
+-- Notify_Exception --
+----------------------
+
+ 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 is the signal handler and calls a trampoline subprogram
+ -- that adjusts the unwind information so the ARM unwinder can find it's
+ -- way back to the context of the originating subprogram. Compare with
+ -- __gnat_error_handler for non-tasking programs.
+
+ ----------------------
+ -- 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. ??? We don't use __builtin_longjmp
+ -- anymore, so do we still need this? */
+
+ Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
+ pragma Assert (Result = 0);
+
+ -- Perform the necessary context adjustments prior to calling the
+ -- trampoline subprogram with the "real" signal handler.
+
+ Adjust_Context_For_Raise (signo, ucontext);
+
+ 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.
+
+ -- We set SA_NODEFER to be compatible with what is done in
+ -- __gnat_error_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_NODEFER + SA_RESTART + 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
+
+ for J in Reserved'Range loop
+ Reserve (Interrupt_ID (Reserved (J))) := True;
+ end loop;
+
+ -- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1997-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 --
+-- <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 a NO tasking version of this package
+
+package body System.Interrupt_Management is
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <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 LynxOS 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 --
+ -----------------------
+
+ 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
+ pragma Unreferenced (siginfo);
+
+ 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.
+
+ case signo is
+ when SIGFPE => raise Constraint_Error;
+ when SIGILL => raise Program_Error;
+ when SIGSEGV => raise Storage_Error;
+ when SIGBUS => raise Storage_Error;
+ when others => null;
+ end case;
+ 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
+ -- This file is identical to s-intman-posix.adb, except that we
+ -- don't set the SA_SIGINFO flag in act.sa_flags, because
+ -- LynxOS does not support that. If SA_SIGINFO is set, then
+ -- sigaction fails, returning -1.
+ act.sa_flags := 0;
+
+ 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
+
+ for J in Reserved'Range loop
+ Reserve (Interrupt_ID (Reserved (J))) := True;
+ end loop;
+
+ -- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 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 --
+-- <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 NT version of this package
+
+with System.OS_Interface; use System.OS_Interface;
+
+package body System.Interrupt_Management is
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ -- "Reserve" all the interrupts, except those that are explicitly
+ -- defined.
+
+ for J in Interrupt_ID'Range loop
+ Reserve (J) := True;
+ end loop;
+
+ Reserve (SIGINT) := False;
+ Reserve (SIGILL) := False;
+ Reserve (SIGABRT) := False;
+ Reserve (SIGFPE) := False;
+ Reserve (SIGSEGV) := False;
+ Reserve (SIGTERM) := False;
+ end Initialize;
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <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 POSIX 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 --
+ -----------------------
+
+ 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
+ pragma Unreferenced (siginfo);
+
+ 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.
+
+ case signo is
+ when SIGFPE => raise Constraint_Error;
+ when SIGILL => raise Program_Error;
+ when SIGSEGV => raise Storage_Error;
+ when SIGBUS => raise Storage_Error;
+ when others => null;
+ end case;
+ 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
+
+ for J in Reserved'Range loop
+ Reserve (Interrupt_ID (Reserved (J))) := True;
+ end loop;
+
+ -- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <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 a Solaris 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.
+
+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");
+
+ 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)
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ -- 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.
+
+ procedure Notify_Exception
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access ucontext_t);
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ procedure Notify_Exception
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access ucontext_t)
+ is
+ pragma Unreferenced (info);
+
+ begin
+ -- Perform the necessary context adjustments prior to a raise from a
+ -- signal handler.
+
+ Adjust_Context_For_Raise (signo, context.all'Address);
+
+ -- Check that treatment of exception propagation here is consistent with
+ -- treatment of the abort signal in System.Task_Primitives.Operations.
+
+ case signo is
+ when SIGFPE => raise Constraint_Error;
+ when SIGILL => raise Program_Error;
+ when SIGSEGV => raise Storage_Error;
+ when SIGBUS => raise Storage_Error;
+ when others => null;
+ end case;
+ end Notify_Exception;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ Initialized : Boolean := False;
+
+ procedure Initialize is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ mask : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ begin
+ if Initialized then
+ return;
+ end if;
+
+ Initialized := True;
+
+ -- Need to call pthread_init very early because it is doing signal
+ -- initializations.
+
+ pthread_init;
+
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ Abort_Task_Interrupt := SIGABRT;
+
+ act.sa_handler := Notify_Exception'Address;
+
+ -- 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.
+
+ -- In that case, this field should be changed back to 0. ??? (Dong-Ik)
+
+ act.sa_flags := 16;
+
+ Result := sigemptyset (mask'Access);
+ pragma Assert (Result = 0);
+
+ -- ??? For the same reason explained above, we can't mask these signals
+ -- because otherwise we won't be able to catch more than one signal.
+
+ act.sa_mask := mask;
+
+ pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
+
+ 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
+ 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's
+ -- 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
+
+ for J in Reserved'Range loop
+ Reserve (Interrupt_ID (Reserved (J))) := True;
+ end loop;
+
+ -- 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 have Signal 0 in reality. We just use this value to
+ -- identify not existing signals (see s-intnam.ads). Therefore, Signal 0
+ -- should not be used in all signal related operations hence mark it as
+ -- reserved.
+
+ Reserve (0) := True;
+ end Initialize;
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <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 SuSV3 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:
+
+-- 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.
+
+package body System.Interrupt_Management is
+
+ use Interfaces.C;
+ use System.OS_Interface;
+
+ Unreserve_All_Interrupts : Interfaces.C.int;
+ pragma Import
+ (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
+
+ -----------------------
+ -- 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
+ -- 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)
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ Initialized : Boolean := False;
+
+ procedure Initialize is
+ 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;
+
+ pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
+
+ -- Process state of exception signals
+
+ for J in Exception_Signals'Range loop
+ declare
+ Sig : constant Signal := Exception_Signals (J);
+ Id : constant Interrupt_ID := Interrupt_ID (Sig);
+ begin
+ if State (Id) /= User then
+ Keep_Unmasked (Id) := True;
+ Reserve (Id) := True;
+ end if;
+ end;
+ 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
+
+ for J in Reserved'Range loop
+ Reserve (Interrupt_ID (Reserved (J))) := True;
+ end loop;
+
+ -- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <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 VxWorks 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;
+ use type Interfaces.C.int;
+
+ -----------------------
+ -- 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;
+
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ Abort_Task_Interrupt := SIGABRT;
+
+ -- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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-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 --
+-- <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 VxWorks 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_Interrupts;
+ pragma Import (C, Initialize_Interrupts, "__gnat_install_handler");
+ -- Under VxWorks, there is no signal inheritance between tasks.
+ -- This procedure is used to initialize signal-to-exception mapping in
+ -- each task.
+
+ 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . L I N U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 2009-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- --
-------------------------------------------------------------------------------
-
--- This is the alpha version of this package
-
--- This package encapsulates cpu specific differences between implementations
--- of GNU/Linux, in order to share s-osinte-linux.ads.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-
-package System.Linux is
- pragma Preelaborate;
-
- ----------
- -- 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 := 35;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- EPERM : constant := 1;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O now possible (4.2 BSD)
- SIGPOLL : constant := 23; -- pollable event occurred
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGPWR : constant := 29; -- power-fail restart
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- SIGUNUSED : constant := 0;
- SIGSTKFLT : constant := 0;
- SIGLOST : constant := 0;
- -- These don't exist for Linux/Alpha. The constants are present
- -- so that we can continue to use a-intnam-linux.ads.
-
- -- struct_sigaction offsets
-
- sa_handler_pos : constant := 0;
- sa_mask_pos : constant := Standard'Address_Size / 8;
- sa_flags_pos : constant := 128 + sa_mask_pos;
-
- SA_SIGINFO : constant := 16#40#;
- SA_ONSTACK : constant := 16#01#;
-
-end System.Linux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . L I N U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 2014-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. --
--- --
--- 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. --
--- --
--- --
-------------------------------------------------------------------------------
-
--- This is the Android version of this package
-
--- This package encapsulates cpu specific differences between implementations
--- of GNU/Linux, in order to share s-osinte-linux.ads.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package
-
-with Interfaces.C;
-
-package System.Linux is
- pragma Preelaborate;
-
- ----------
- -- 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
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 7; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 10; -- user defined signal 1
- SIGUSR2 : constant := 12; -- user defined signal 2
- SIGCLD : constant := 17; -- alias for SIGCHLD
- SIGCHLD : constant := 17; -- child status change
- SIGPWR : constant := 30; -- power-fail restart
- SIGWINCH : constant := 28; -- window size change
- SIGURG : constant := 23; -- urgent condition on IO channel
- SIGPOLL : constant := 29; -- pollable event occurred
- SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
- SIGLOST : constant := 29; -- File lock lost
- SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 20; -- user stop requested from tty
- SIGCONT : constant := 18; -- stopped process has been continued
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
- SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
-
- -- struct_sigaction offsets
-
- sa_handler_pos : constant := 0;
- sa_mask_pos : constant := Standard'Address_Size / 8;
- sa_flags_pos : constant := 4 + sa_mask_pos;
-
- SA_SIGINFO : constant := 16#00000004#;
- SA_ONSTACK : constant := 16#08000000#;
- SA_RESTART : constant := 16#10000000#;
- SA_NODEFER : constant := 16#40000000#;
-
-end System.Linux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . L I N U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 2008-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- --
-------------------------------------------------------------------------------
-
--- This is the hppa version of this package
-
--- This package encapsulates cpu specific differences between implementations
--- of GNU/Linux, in order to share s-osinte-linux.ads.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-
-package System.Linux 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 := 238;
-
- -------------
- -- Signals --
- -------------
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
- SIGCLD : constant := 18; -- alias for SIGCHLD
- SIGCHLD : constant := 18; -- child status change
- SIGPWR : constant := 19; -- power-fail restart
- SIGVTALRM : constant := 20; -- virtual timer expired
- SIGPROF : constant := 21; -- profiling timer expired
- SIGPOLL : constant := 22; -- pollable event occurred
- SIGIO : constant := 22; -- I/O now possible (4.2 BSD)
- SIGWINCH : constant := 23; -- window size change
- SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 25; -- user stop requested from tty
- SIGCONT : constant := 26; -- stopped process has been continued
- SIGTTIN : constant := 27; -- background tty read attempted
- SIGTTOU : constant := 28; -- background tty write attempted
- SIGURG : constant := 29; -- urgent condition on IO channel
- SIGLOST : constant := 30; -- File lock lost
- SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
- SIGXCPU : constant := 33; -- CPU time limit exceeded
- SIGXFSZ : constant := 34; -- filesize limit exceeded
- SIGSTKFLT : constant := 36; -- coprocessor stack fault (Linux)
- SIGLTHRRES : constant := 37; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 38; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 39; -- GNU/LinuxThreads debugger signal
-
- -- struct_sigaction offsets
-
- sa_handler_pos : constant := 0;
- sa_flags_pos : constant := Standard'Address_Size / 8;
- sa_mask_pos : constant := sa_flags_pos * 2;
-
- SA_SIGINFO : constant := 16#10#;
- SA_ONSTACK : constant := 16#01#;
-
-end System.Linux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . L I N U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 2009-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- This is the MIPS version of this package
-
--- This package encapsulates cpu specific differences between implementations
--- of GNU/Linux, in order to share s-osinte-linux.ads.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package
-
-with Interfaces.C;
-
-package System.Linux is
- pragma Preelaborate;
-
- ----------
- -- Time --
- ----------
-
- subtype int is Interfaces.C.int;
- 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 := 145;
-
- -------------
- -- Signals --
- -------------
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
- SIGCLD : constant := 18; -- alias for SIGCHLD
- SIGCHLD : constant := 18; -- child status change
- SIGPWR : constant := 19; -- power-fail restart
- 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
-
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
-
- -- These don't exist for Linux/MIPS. The constants are present
- -- so that we can continue to use a-intnam-linux.ads.
- SIGLOST : constant := 0; -- File lock lost
- SIGSTKFLT : constant := 0; -- coprocessor stack fault (Linux)
- SIGUNUSED : constant := 0; -- unused signal (GNU/Linux)
-
- -- struct_sigaction offsets
-
- sa_handler_pos : constant := int'Size / 8;
- sa_mask_pos : constant := int'Size / 8 +
- Standard'Address_Size / 8;
- sa_flags_pos : constant := 0;
-
- SA_SIGINFO : constant := 16#08#;
- SA_ONSTACK : constant := 16#08000000#;
-
-end System.Linux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . L I N U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 2009-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- --
-------------------------------------------------------------------------------
-
--- This is the SPARC version of this package
-
--- This package encapsulates cpu specific differences between implementations
--- of GNU/Linux, in order to share s-osinte-linux.ads.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package
-
-with Interfaces.C;
-
-package System.Linux is
- pragma Preelaborate;
-
- ----------
- -- 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)
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGIOT : constant := 6; -- IOT instruction
- SIGEMT : constant := 7; -- EMT
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCHLD : constant := 20; -- child status change
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O now possible (4.2 BSD)
- SIGPOLL : constant := 23; -- pollable event occurred
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGLOST : constant := 29; -- File lock lost
- SIGPWR : constant := 29; -- power-fail restart
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
-
- SIGUNUSED : constant := 0;
- SIGSTKFLT : constant := 0;
- -- These don't exist for Linux/SPARC. The constants are present
- -- so that we can continue to use a-intnam-linux.ads.
-
- -- 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#200#;
- SA_ONSTACK : constant := 16#001#;
-
-end System.Linux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . L I N U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 2013-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- --
-------------------------------------------------------------------------------
-
--- This is the x32 version of this package
-
--- This package encapsulates cpu specific differences between implementations
--- of GNU/Linux, in order to share s-osinte-linux.ads.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package
-
-with Interfaces.C;
-
-package System.Linux is
- pragma Preelaborate;
-
- ----------
- -- Time --
- ----------
-
- type time_t is new Long_Long_Integer;
- subtype clockid_t is Interfaces.C.int;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : Long_Long_Integer;
- end record;
- pragma Convention (C, timespec);
-
- type timeval is record
- tv_sec : time_t;
- tv_usec : Long_Long_Integer;
- 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
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 7; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 10; -- user defined signal 1
- SIGUSR2 : constant := 12; -- user defined signal 2
- SIGCLD : constant := 17; -- alias for SIGCHLD
- SIGCHLD : constant := 17; -- child status change
- SIGPWR : constant := 30; -- power-fail restart
- SIGWINCH : constant := 28; -- window size change
- SIGURG : constant := 23; -- urgent condition on IO channel
- SIGPOLL : constant := 29; -- pollable event occurred
- SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
- SIGLOST : constant := 29; -- File lock lost
- SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 20; -- user stop requested from tty
- SIGCONT : constant := 18; -- stopped process has been continued
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
- SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
-
- -- struct_sigaction offsets
-
- sa_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.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2009-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the alpha version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+
+package System.Linux is
+ pragma Preelaborate;
+
+ ----------
+ -- 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 := 35;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 60;
+
+ -------------
+ -- Signals --
+ -------------
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O now possible (4.2 BSD)
+ SIGPOLL : constant := 23; -- pollable event occurred
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGPWR : constant := 29; -- power-fail restart
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ SIGUNUSED : constant := 0;
+ SIGSTKFLT : constant := 0;
+ SIGLOST : constant := 0;
+ -- These don't exist for Linux/Alpha. The constants are present
+ -- so that we can continue to use a-intnam-linux.ads.
+
+ -- struct_sigaction offsets
+
+ sa_handler_pos : constant := 0;
+ sa_mask_pos : constant := Standard'Address_Size / 8;
+ sa_flags_pos : constant := 128 + sa_mask_pos;
+
+ SA_SIGINFO : constant := 16#40#;
+ SA_ONSTACK : constant := 16#01#;
+
+end System.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2014-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. --
+-- --
+-- 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. --
+-- --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Android version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package
+
+with Interfaces.C;
+
+package System.Linux is
+ pragma Preelaborate;
+
+ ----------
+ -- 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
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 7; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 10; -- user defined signal 1
+ SIGUSR2 : constant := 12; -- user defined signal 2
+ SIGCLD : constant := 17; -- alias for SIGCHLD
+ SIGCHLD : constant := 17; -- child status change
+ SIGPWR : constant := 30; -- power-fail restart
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 23; -- urgent condition on IO channel
+ SIGPOLL : constant := 29; -- pollable event occurred
+ SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
+ SIGLOST : constant := 29; -- File lock lost
+ SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 20; -- user stop requested from tty
+ SIGCONT : constant := 18; -- stopped process has been continued
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
+ SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ -- struct_sigaction offsets
+
+ sa_handler_pos : constant := 0;
+ sa_mask_pos : constant := Standard'Address_Size / 8;
+ sa_flags_pos : constant := 4 + sa_mask_pos;
+
+ SA_SIGINFO : constant := 16#00000004#;
+ SA_ONSTACK : constant := 16#08000000#;
+ SA_RESTART : constant := 16#10000000#;
+ SA_NODEFER : constant := 16#40000000#;
+
+end System.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the hppa version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+
+package System.Linux 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 := 238;
+
+ -------------
+ -- Signals --
+ -------------
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGVTALRM : constant := 20; -- virtual timer expired
+ SIGPROF : constant := 21; -- profiling timer expired
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGIO : constant := 22; -- I/O now possible (4.2 BSD)
+ SIGWINCH : constant := 23; -- window size change
+ SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 25; -- user stop requested from tty
+ SIGCONT : constant := 26; -- stopped process has been continued
+ SIGTTIN : constant := 27; -- background tty read attempted
+ SIGTTOU : constant := 28; -- background tty write attempted
+ SIGURG : constant := 29; -- urgent condition on IO channel
+ SIGLOST : constant := 30; -- File lock lost
+ SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
+ SIGXCPU : constant := 33; -- CPU time limit exceeded
+ SIGXFSZ : constant := 34; -- filesize limit exceeded
+ SIGSTKFLT : constant := 36; -- coprocessor stack fault (Linux)
+ SIGLTHRRES : constant := 37; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 38; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 39; -- GNU/LinuxThreads debugger signal
+
+ -- struct_sigaction offsets
+
+ sa_handler_pos : constant := 0;
+ sa_flags_pos : constant := Standard'Address_Size / 8;
+ sa_mask_pos : constant := sa_flags_pos * 2;
+
+ SA_SIGINFO : constant := 16#10#;
+ SA_ONSTACK : constant := 16#01#;
+
+end System.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2009-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the MIPS version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package
+
+with Interfaces.C;
+
+package System.Linux is
+ pragma Preelaborate;
+
+ ----------
+ -- Time --
+ ----------
+
+ subtype int is Interfaces.C.int;
+ 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 := 145;
+
+ -------------
+ -- Signals --
+ -------------
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ 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
+
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ -- These don't exist for Linux/MIPS. The constants are present
+ -- so that we can continue to use a-intnam-linux.ads.
+ SIGLOST : constant := 0; -- File lock lost
+ SIGSTKFLT : constant := 0; -- coprocessor stack fault (Linux)
+ SIGUNUSED : constant := 0; -- unused signal (GNU/Linux)
+
+ -- struct_sigaction offsets
+
+ sa_handler_pos : constant := int'Size / 8;
+ sa_mask_pos : constant := int'Size / 8 +
+ Standard'Address_Size / 8;
+ sa_flags_pos : constant := 0;
+
+ SA_SIGINFO : constant := 16#08#;
+ SA_ONSTACK : constant := 16#08000000#;
+
+end System.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2009-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the SPARC version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package
+
+with Interfaces.C;
+
+package System.Linux is
+ pragma Preelaborate;
+
+ ----------
+ -- 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)
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGEMT : constant := 7; -- EMT
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCHLD : constant := 20; -- child status change
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O now possible (4.2 BSD)
+ SIGPOLL : constant := 23; -- pollable event occurred
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGLOST : constant := 29; -- File lock lost
+ SIGPWR : constant := 29; -- power-fail restart
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ SIGUNUSED : constant := 0;
+ SIGSTKFLT : constant := 0;
+ -- These don't exist for Linux/SPARC. The constants are present
+ -- so that we can continue to use a-intnam-linux.ads.
+
+ -- 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#200#;
+ SA_ONSTACK : constant := 16#001#;
+
+end System.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2013-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the x32 version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package
+
+with Interfaces.C;
+
+package System.Linux is
+ pragma Preelaborate;
+
+ ----------
+ -- Time --
+ ----------
+
+ type time_t is new Long_Long_Integer;
+ subtype clockid_t is Interfaces.C.int;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : Long_Long_Integer;
+ end record;
+ pragma Convention (C, timespec);
+
+ type timeval is record
+ tv_sec : time_t;
+ tv_usec : Long_Long_Integer;
+ 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
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 7; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 10; -- user defined signal 1
+ SIGUSR2 : constant := 12; -- user defined signal 2
+ SIGCLD : constant := 17; -- alias for SIGCHLD
+ SIGCHLD : constant := 17; -- child status change
+ SIGPWR : constant := 30; -- power-fail restart
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 23; -- urgent condition on IO channel
+ SIGPOLL : constant := 29; -- pollable event occurred
+ SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
+ SIGLOST : constant := 29; -- File lock lost
+ SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 20; -- user stop requested from tty
+ SIGCONT : constant := 18; -- stopped process has been continued
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
+ SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ -- struct_sigaction offsets
+
+ sa_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.Linux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2011-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 --
--- <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. --
--- --
-------------------------------------------------------------------------------
-
--- Body used on targets where the operating system supports setting task
--- affinities.
-
-with System.Tasking.Initialization;
-with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
-
-with Ada.Unchecked_Conversion;
-
-package body System.Multiprocessors.Dispatching_Domains is
-
- package ST renames System.Tasking;
-
- -----------------------
- -- Local subprograms --
- -----------------------
-
- function Convert_Ids is new
- Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, ST.Task_Id);
-
- procedure Unchecked_Set_Affinity
- (Domain : ST.Dispatching_Domain_Access;
- CPU : CPU_Range;
- T : ST.Task_Id);
- -- Internal procedure to move a task to a target domain and CPU. No checks
- -- are performed about the validity of the domain and the CPU because they
- -- are done by the callers of this procedure (either Assign_Task or
- -- Set_CPU).
-
- procedure Freeze_Dispatching_Domains;
- pragma Export
- (Ada, Freeze_Dispatching_Domains, "__gnat_freeze_dispatching_domains");
- -- Signal the time when no new dispatching domains can be created. It
- -- should be called before the environment task calls the main procedure
- -- (and after the elaboration code), so the binder-generated file needs to
- -- import and call this procedure.
-
- -----------------
- -- Assign_Task --
- -----------------
-
- procedure Assign_Task
- (Domain : in out Dispatching_Domain;
- CPU : CPU_Range := Not_A_Specific_CPU;
- T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task)
- is
- Target : constant ST.Task_Id := Convert_Ids (T);
-
- begin
- -- The exception Dispatching_Domain_Error is propagated if T is already
- -- assigned to a Dispatching_Domain other than
- -- System_Dispatching_Domain, or if CPU is not one of the processors of
- -- Domain (and is not Not_A_Specific_CPU).
-
- if Dispatching_Domain (Target.Common.Domain) /= System_Dispatching_Domain
- then
- raise Dispatching_Domain_Error with
- "task already in user-defined dispatching domain";
-
- elsif CPU /= Not_A_Specific_CPU and then CPU not in Domain'Range then
- raise Dispatching_Domain_Error with
- "processor does not belong to dispatching domain";
- end if;
-
- -- Assigning a task to System_Dispatching_Domain that is already
- -- assigned to that domain has no effect.
-
- if Domain = System_Dispatching_Domain then
- return;
-
- else
- -- Set the task affinity once we know it is possible
-
- Unchecked_Set_Affinity
- (ST.Dispatching_Domain_Access (Domain), CPU, Target);
- end if;
- end Assign_Task;
-
- ------------
- -- Create --
- ------------
-
- function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain is
- begin
- return Create ((First .. Last => True));
- end Create;
-
- function Create (Set : CPU_Set) return Dispatching_Domain is
- ST_DD : aliased constant ST.Dispatching_Domain :=
- ST.Dispatching_Domain (Set);
- First : constant CPU := Get_First_CPU (ST_DD'Unrestricted_Access);
- Last : constant CPU_Range := Get_Last_CPU (ST_DD'Unrestricted_Access);
- subtype Rng is CPU_Range range First .. Last;
-
- use type ST.Dispatching_Domain;
- use type ST.Dispatching_Domain_Access;
- use type ST.Task_Id;
-
- T : ST.Task_Id;
-
- New_System_Domain : ST.Dispatching_Domain := ST.System_Domain.all;
-
- ST_DD_Slice : constant ST.Dispatching_Domain := ST_DD (Rng);
-
- begin
- -- The set of processors for creating a dispatching domain must
- -- comply with the following restrictions:
- -- - Not exceeding the range of available processors.
- -- - CPUs from the System_Dispatching_Domain.
- -- - The calling task must be the environment task.
- -- - The call to Create must take place before the call to the main
- -- subprogram.
- -- - Set does not contain a processor with a task assigned to it.
- -- - The allocation cannot leave System_Dispatching_Domain empty.
-
- -- Note that a previous version of the language forbade empty domains.
-
- if Rng'Last > Number_Of_CPUs then
- raise Dispatching_Domain_Error with
- "CPU not supported by the target";
- end if;
-
- declare
- System_Domain_Slice : constant ST.Dispatching_Domain :=
- ST.System_Domain (Rng);
- Actual : constant ST.Dispatching_Domain :=
- ST_DD_Slice and not System_Domain_Slice;
- Expected : constant ST.Dispatching_Domain := (Rng => False);
- begin
- if Actual /= Expected then
- raise Dispatching_Domain_Error with
- "CPU not currently in System_Dispatching_Domain";
- end if;
- end;
-
- if Self /= Environment_Task then
- raise Dispatching_Domain_Error with
- "only the environment task can create dispatching domains";
- end if;
-
- if ST.Dispatching_Domains_Frozen then
- raise Dispatching_Domain_Error with
- "cannot create dispatching domain after call to main procedure";
- end if;
-
- for Proc in Rng loop
- if ST_DD (Proc) and then
- ST.Dispatching_Domain_Tasks (Proc) /= 0
- then
- raise Dispatching_Domain_Error with "CPU has tasks assigned";
- end if;
- end loop;
-
- New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD_Slice;
-
- if New_System_Domain = (New_System_Domain'Range => False) then
- raise Dispatching_Domain_Error with
- "would leave System_Dispatching_Domain empty";
- end if;
-
- return Result : constant Dispatching_Domain :=
- new ST.Dispatching_Domain'(ST_DD_Slice)
- do
- -- At this point we need to fix the processors belonging to the
- -- system domain, and change the affinity of every task that has
- -- been created and assigned to the system domain.
-
- ST.Initialization.Defer_Abort (Self);
-
- Lock_RTS;
-
- ST.System_Domain (Rng) := New_System_Domain (Rng);
- pragma Assert (ST.System_Domain.all = New_System_Domain);
-
- -- Iterate the list of tasks belonging to the default system
- -- dispatching domain and set the appropriate affinity.
-
- T := ST.All_Tasks_List;
-
- while T /= null loop
- if T.Common.Domain = ST.System_Domain then
- Set_Task_Affinity (T);
- end if;
-
- T := T.Common.All_Tasks_Link;
- end loop;
-
- Unlock_RTS;
-
- ST.Initialization.Undefer_Abort (Self);
- end return;
- end Create;
-
- -----------------------------
- -- Delay_Until_And_Set_CPU --
- -----------------------------
-
- procedure Delay_Until_And_Set_CPU
- (Delay_Until_Time : Ada.Real_Time.Time;
- CPU : CPU_Range)
- is
- begin
- -- Not supported atomically by the underlying operating systems.
- -- Operating systems use to migrate the task immediately after the call
- -- to set the affinity.
-
- delay until Delay_Until_Time;
- Set_CPU (CPU);
- end Delay_Until_And_Set_CPU;
-
- --------------------------------
- -- Freeze_Dispatching_Domains --
- --------------------------------
-
- procedure Freeze_Dispatching_Domains is
- begin
- -- Signal the end of the elaboration code
-
- ST.Dispatching_Domains_Frozen := True;
- end Freeze_Dispatching_Domains;
-
- -------------
- -- Get_CPU --
- -------------
-
- function Get_CPU
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task) return CPU_Range
- is
- begin
- return Convert_Ids (T).Common.Base_CPU;
- end Get_CPU;
-
- -----------------
- -- Get_CPU_Set --
- -----------------
-
- function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is
- begin
- return CPU_Set (Domain.all);
- end Get_CPU_Set;
-
- ----------------------------
- -- Get_Dispatching_Domain --
- ----------------------------
-
- function Get_Dispatching_Domain
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task) return Dispatching_Domain
- is
- begin
- return Result : constant Dispatching_Domain :=
- Dispatching_Domain (Convert_Ids (T).Common.Domain)
- do
- pragma Assert (Result /= null);
- end return;
- end Get_Dispatching_Domain;
-
- -------------------
- -- Get_First_CPU --
- -------------------
-
- function Get_First_CPU (Domain : Dispatching_Domain) return CPU is
- begin
- for Proc in Domain'Range loop
- if Domain (Proc) then
- return Proc;
- end if;
- end loop;
-
- return CPU'First;
- end Get_First_CPU;
-
- ------------------
- -- Get_Last_CPU --
- ------------------
-
- function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is
- begin
- for Proc in reverse Domain'Range loop
- if Domain (Proc) then
- return Proc;
- end if;
- end loop;
-
- return CPU_Range'First;
- end Get_Last_CPU;
-
- -------------
- -- Set_CPU --
- -------------
-
- procedure Set_CPU
- (CPU : CPU_Range;
- T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task)
- is
- Target : constant ST.Task_Id := Convert_Ids (T);
-
- begin
- -- The exception Dispatching_Domain_Error is propagated if CPU is not
- -- one of the processors of the Dispatching_Domain on which T is
- -- assigned (and is not Not_A_Specific_CPU).
-
- if CPU /= Not_A_Specific_CPU and then
- (CPU not in Target.Common.Domain'Range or else
- not Target.Common.Domain (CPU))
- then
- raise Dispatching_Domain_Error with
- "processor does not belong to the task's dispatching domain";
- end if;
-
- Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target);
- end Set_CPU;
-
- ----------------------------
- -- Unchecked_Set_Affinity --
- ----------------------------
-
- procedure Unchecked_Set_Affinity
- (Domain : ST.Dispatching_Domain_Access;
- CPU : CPU_Range;
- T : ST.Task_Id)
- is
- Source_CPU : constant CPU_Range := T.Common.Base_CPU;
-
- use type ST.Dispatching_Domain_Access;
-
- begin
- Write_Lock (T);
-
- -- Move to the new domain
-
- T.Common.Domain := Domain;
-
- -- Attach the CPU to the task
-
- T.Common.Base_CPU := CPU;
-
- -- Change the number of tasks attached to a given task in the system
- -- domain if needed.
-
- if not ST.Dispatching_Domains_Frozen
- and then (Domain = null or else Domain = ST.System_Domain)
- then
- -- Reduce the number of tasks attached to the CPU from which this
- -- task is being moved, if needed.
-
- if Source_CPU /= Not_A_Specific_CPU then
- ST.Dispatching_Domain_Tasks (Source_CPU) :=
- ST.Dispatching_Domain_Tasks (Source_CPU) - 1;
- end if;
-
- -- Increase the number of tasks attached to the CPU to which this
- -- task is being moved, if needed.
-
- if CPU /= Not_A_Specific_CPU then
- ST.Dispatching_Domain_Tasks (CPU) :=
- ST.Dispatching_Domain_Tasks (CPU) + 1;
- end if;
- end if;
-
- -- Change the actual affinity calling the operating system level
-
- Set_Task_Affinity (T);
-
- Unlock (T);
- end Unchecked_Set_Affinity;
-
-end System.Multiprocessors.Dispatching_Domains;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2011-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 --
+-- <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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Body used on targets where the operating system supports setting task
+-- affinities.
+
+with System.Tasking.Initialization;
+with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
+
+with Ada.Unchecked_Conversion;
+
+package body System.Multiprocessors.Dispatching_Domains is
+
+ package ST renames System.Tasking;
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ function Convert_Ids is new
+ Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, ST.Task_Id);
+
+ procedure Unchecked_Set_Affinity
+ (Domain : ST.Dispatching_Domain_Access;
+ CPU : CPU_Range;
+ T : ST.Task_Id);
+ -- Internal procedure to move a task to a target domain and CPU. No checks
+ -- are performed about the validity of the domain and the CPU because they
+ -- are done by the callers of this procedure (either Assign_Task or
+ -- Set_CPU).
+
+ procedure Freeze_Dispatching_Domains;
+ pragma Export
+ (Ada, Freeze_Dispatching_Domains, "__gnat_freeze_dispatching_domains");
+ -- Signal the time when no new dispatching domains can be created. It
+ -- should be called before the environment task calls the main procedure
+ -- (and after the elaboration code), so the binder-generated file needs to
+ -- import and call this procedure.
+
+ -----------------
+ -- Assign_Task --
+ -----------------
+
+ procedure Assign_Task
+ (Domain : in out Dispatching_Domain;
+ CPU : CPU_Range := Not_A_Specific_CPU;
+ T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task)
+ is
+ Target : constant ST.Task_Id := Convert_Ids (T);
+
+ begin
+ -- The exception Dispatching_Domain_Error is propagated if T is already
+ -- assigned to a Dispatching_Domain other than
+ -- System_Dispatching_Domain, or if CPU is not one of the processors of
+ -- Domain (and is not Not_A_Specific_CPU).
+
+ if Dispatching_Domain (Target.Common.Domain) /= System_Dispatching_Domain
+ then
+ raise Dispatching_Domain_Error with
+ "task already in user-defined dispatching domain";
+
+ elsif CPU /= Not_A_Specific_CPU and then CPU not in Domain'Range then
+ raise Dispatching_Domain_Error with
+ "processor does not belong to dispatching domain";
+ end if;
+
+ -- Assigning a task to System_Dispatching_Domain that is already
+ -- assigned to that domain has no effect.
+
+ if Domain = System_Dispatching_Domain then
+ return;
+
+ else
+ -- Set the task affinity once we know it is possible
+
+ Unchecked_Set_Affinity
+ (ST.Dispatching_Domain_Access (Domain), CPU, Target);
+ end if;
+ end Assign_Task;
+
+ ------------
+ -- Create --
+ ------------
+
+ function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain is
+ begin
+ return Create ((First .. Last => True));
+ end Create;
+
+ function Create (Set : CPU_Set) return Dispatching_Domain is
+ ST_DD : aliased constant ST.Dispatching_Domain :=
+ ST.Dispatching_Domain (Set);
+ First : constant CPU := Get_First_CPU (ST_DD'Unrestricted_Access);
+ Last : constant CPU_Range := Get_Last_CPU (ST_DD'Unrestricted_Access);
+ subtype Rng is CPU_Range range First .. Last;
+
+ use type ST.Dispatching_Domain;
+ use type ST.Dispatching_Domain_Access;
+ use type ST.Task_Id;
+
+ T : ST.Task_Id;
+
+ New_System_Domain : ST.Dispatching_Domain := ST.System_Domain.all;
+
+ ST_DD_Slice : constant ST.Dispatching_Domain := ST_DD (Rng);
+
+ begin
+ -- The set of processors for creating a dispatching domain must
+ -- comply with the following restrictions:
+ -- - Not exceeding the range of available processors.
+ -- - CPUs from the System_Dispatching_Domain.
+ -- - The calling task must be the environment task.
+ -- - The call to Create must take place before the call to the main
+ -- subprogram.
+ -- - Set does not contain a processor with a task assigned to it.
+ -- - The allocation cannot leave System_Dispatching_Domain empty.
+
+ -- Note that a previous version of the language forbade empty domains.
+
+ if Rng'Last > Number_Of_CPUs then
+ raise Dispatching_Domain_Error with
+ "CPU not supported by the target";
+ end if;
+
+ declare
+ System_Domain_Slice : constant ST.Dispatching_Domain :=
+ ST.System_Domain (Rng);
+ Actual : constant ST.Dispatching_Domain :=
+ ST_DD_Slice and not System_Domain_Slice;
+ Expected : constant ST.Dispatching_Domain := (Rng => False);
+ begin
+ if Actual /= Expected then
+ raise Dispatching_Domain_Error with
+ "CPU not currently in System_Dispatching_Domain";
+ end if;
+ end;
+
+ if Self /= Environment_Task then
+ raise Dispatching_Domain_Error with
+ "only the environment task can create dispatching domains";
+ end if;
+
+ if ST.Dispatching_Domains_Frozen then
+ raise Dispatching_Domain_Error with
+ "cannot create dispatching domain after call to main procedure";
+ end if;
+
+ for Proc in Rng loop
+ if ST_DD (Proc) and then
+ ST.Dispatching_Domain_Tasks (Proc) /= 0
+ then
+ raise Dispatching_Domain_Error with "CPU has tasks assigned";
+ end if;
+ end loop;
+
+ New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD_Slice;
+
+ if New_System_Domain = (New_System_Domain'Range => False) then
+ raise Dispatching_Domain_Error with
+ "would leave System_Dispatching_Domain empty";
+ end if;
+
+ return Result : constant Dispatching_Domain :=
+ new ST.Dispatching_Domain'(ST_DD_Slice)
+ do
+ -- At this point we need to fix the processors belonging to the
+ -- system domain, and change the affinity of every task that has
+ -- been created and assigned to the system domain.
+
+ ST.Initialization.Defer_Abort (Self);
+
+ Lock_RTS;
+
+ ST.System_Domain (Rng) := New_System_Domain (Rng);
+ pragma Assert (ST.System_Domain.all = New_System_Domain);
+
+ -- Iterate the list of tasks belonging to the default system
+ -- dispatching domain and set the appropriate affinity.
+
+ T := ST.All_Tasks_List;
+
+ while T /= null loop
+ if T.Common.Domain = ST.System_Domain then
+ Set_Task_Affinity (T);
+ end if;
+
+ T := T.Common.All_Tasks_Link;
+ end loop;
+
+ Unlock_RTS;
+
+ ST.Initialization.Undefer_Abort (Self);
+ end return;
+ end Create;
+
+ -----------------------------
+ -- Delay_Until_And_Set_CPU --
+ -----------------------------
+
+ procedure Delay_Until_And_Set_CPU
+ (Delay_Until_Time : Ada.Real_Time.Time;
+ CPU : CPU_Range)
+ is
+ begin
+ -- Not supported atomically by the underlying operating systems.
+ -- Operating systems use to migrate the task immediately after the call
+ -- to set the affinity.
+
+ delay until Delay_Until_Time;
+ Set_CPU (CPU);
+ end Delay_Until_And_Set_CPU;
+
+ --------------------------------
+ -- Freeze_Dispatching_Domains --
+ --------------------------------
+
+ procedure Freeze_Dispatching_Domains is
+ begin
+ -- Signal the end of the elaboration code
+
+ ST.Dispatching_Domains_Frozen := True;
+ end Freeze_Dispatching_Domains;
+
+ -------------
+ -- Get_CPU --
+ -------------
+
+ function Get_CPU
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task) return CPU_Range
+ is
+ begin
+ return Convert_Ids (T).Common.Base_CPU;
+ end Get_CPU;
+
+ -----------------
+ -- Get_CPU_Set --
+ -----------------
+
+ function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is
+ begin
+ return CPU_Set (Domain.all);
+ end Get_CPU_Set;
+
+ ----------------------------
+ -- Get_Dispatching_Domain --
+ ----------------------------
+
+ function Get_Dispatching_Domain
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task) return Dispatching_Domain
+ is
+ begin
+ return Result : constant Dispatching_Domain :=
+ Dispatching_Domain (Convert_Ids (T).Common.Domain)
+ do
+ pragma Assert (Result /= null);
+ end return;
+ end Get_Dispatching_Domain;
+
+ -------------------
+ -- Get_First_CPU --
+ -------------------
+
+ function Get_First_CPU (Domain : Dispatching_Domain) return CPU is
+ begin
+ for Proc in Domain'Range loop
+ if Domain (Proc) then
+ return Proc;
+ end if;
+ end loop;
+
+ return CPU'First;
+ end Get_First_CPU;
+
+ ------------------
+ -- Get_Last_CPU --
+ ------------------
+
+ function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is
+ begin
+ for Proc in reverse Domain'Range loop
+ if Domain (Proc) then
+ return Proc;
+ end if;
+ end loop;
+
+ return CPU_Range'First;
+ end Get_Last_CPU;
+
+ -------------
+ -- Set_CPU --
+ -------------
+
+ procedure Set_CPU
+ (CPU : CPU_Range;
+ T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task)
+ is
+ Target : constant ST.Task_Id := Convert_Ids (T);
+
+ begin
+ -- The exception Dispatching_Domain_Error is propagated if CPU is not
+ -- one of the processors of the Dispatching_Domain on which T is
+ -- assigned (and is not Not_A_Specific_CPU).
+
+ if CPU /= Not_A_Specific_CPU and then
+ (CPU not in Target.Common.Domain'Range or else
+ not Target.Common.Domain (CPU))
+ then
+ raise Dispatching_Domain_Error with
+ "processor does not belong to the task's dispatching domain";
+ end if;
+
+ Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target);
+ end Set_CPU;
+
+ ----------------------------
+ -- Unchecked_Set_Affinity --
+ ----------------------------
+
+ procedure Unchecked_Set_Affinity
+ (Domain : ST.Dispatching_Domain_Access;
+ CPU : CPU_Range;
+ T : ST.Task_Id)
+ is
+ Source_CPU : constant CPU_Range := T.Common.Base_CPU;
+
+ use type ST.Dispatching_Domain_Access;
+
+ begin
+ Write_Lock (T);
+
+ -- Move to the new domain
+
+ T.Common.Domain := Domain;
+
+ -- Attach the CPU to the task
+
+ T.Common.Base_CPU := CPU;
+
+ -- Change the number of tasks attached to a given task in the system
+ -- domain if needed.
+
+ if not ST.Dispatching_Domains_Frozen
+ and then (Domain = null or else Domain = ST.System_Domain)
+ then
+ -- Reduce the number of tasks attached to the CPU from which this
+ -- task is being moved, if needed.
+
+ if Source_CPU /= Not_A_Specific_CPU then
+ ST.Dispatching_Domain_Tasks (Source_CPU) :=
+ ST.Dispatching_Domain_Tasks (Source_CPU) - 1;
+ end if;
+
+ -- Increase the number of tasks attached to the CPU to which this
+ -- task is being moved, if needed.
+
+ if CPU /= Not_A_Specific_CPU then
+ ST.Dispatching_Domain_Tasks (CPU) :=
+ ST.Dispatching_Domain_Tasks (CPU) + 1;
+ end if;
+ end if;
+
+ -- Change the actual affinity calling the operating system level
+
+ Set_Task_Affinity (T);
+
+ Unlock (T);
+ end Unchecked_Set_Affinity;
+
+end System.Multiprocessors.Dispatching_Domains;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1997-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 --
--- <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 a AIX (Native) version of this package
-
-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.
-
-package body System.OS_Interface is
-
- use Interfaces.C;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- Dispatching_Policy : Character;
- pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
-
- Time_Slice_Val : Integer;
- pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
-
- begin
- -- For the case SCHED_OTHER the only valid priority across all supported
- -- versions of AIX is 1 (note that the scheduling policy can be set
- -- with the pragma Task_Dispatching_Policy or setting the time slice
- -- value). Otherwise, for SCHED_RR and SCHED_FIFO, the system defines
- -- priorities in the range 1 .. 127. This means that we must map
- -- System.Any_Priority in the range 0 .. 126 to 1 .. 127.
-
- if Dispatching_Policy = ' ' and then Time_Slice_Val < 0 then
- return 1;
- else
- return Interfaces.C.int (Prio) + 1;
- end if;
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F is negative due to a round-up, adjust for positive F value
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- -----------------
- -- sched_yield --
- -----------------
-
- -- AIX Thread does not have sched_yield;
-
- function sched_yield return int is
- procedure pthread_yield;
- pragma Import (C, pthread_yield, "sched_yield");
- begin
- pthread_yield;
- return 0;
- end sched_yield;
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- --------------------------
- -- PTHREAD_PRIO_INHERIT --
- --------------------------
-
- AIX_Version : Integer := 0;
- -- AIX version in the form xy for AIX version x.y (0 means not set)
-
- SYS_NMLN : constant := 32;
- -- AIX system constant used to define utsname, see sys/utsname.h
-
- subtype String_NMLN is String (1 .. SYS_NMLN);
-
- type utsname is record
- sysname : String_NMLN;
- nodename : String_NMLN;
- release : String_NMLN;
- version : String_NMLN;
- machine : String_NMLN;
- procserial : String_NMLN;
- end record;
- pragma Convention (C, utsname);
-
- procedure uname (name : out utsname);
- pragma Import (C, uname);
-
- function PTHREAD_PRIO_INHERIT return int is
- name : utsname;
-
- function Val (C : Character) return Integer;
- -- Transform a numeric character ('0' .. '9') to an integer
-
- ---------
- -- Val --
- ---------
-
- function Val (C : Character) return Integer is
- begin
- return Character'Pos (C) - Character'Pos ('0');
- end Val;
-
- -- Start of processing for PTHREAD_PRIO_INHERIT
-
- begin
- if AIX_Version = 0 then
-
- -- Set AIX_Version
-
- uname (name);
- AIX_Version := Val (name.version (1)) * 10 + Val (name.release (1));
- end if;
-
- if AIX_Version < 53 then
-
- -- Under AIX < 5.3, PTHREAD_PRIO_INHERIT is defined as 0 in pthread.h
-
- return 0;
-
- else
- -- Under AIX >= 5.3, PTHREAD_PRIO_INHERIT is defined as 3
-
- return 3;
- end if;
- end PTHREAD_PRIO_INHERIT;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1991-2017, Florida State University --
--- 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 --
--- <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 a AIX (Native THREADS) 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 Interfaces.C.Extensions;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-pthread");
- -- This implies -lpthreads + other things depending on the GCC
- -- configuration, such as the selection of a proper libgcc variant
- -- for table-based exception handling when it is available.
-
- pragma Linker_Options ("-lc_r");
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype long_long is Interfaces.C.Extensions.long_long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIMEDOUT : constant := 78;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 63;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGPWR : constant := 29; -- power-fail restart
- SIGWINCH : constant := 28; -- window size change
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGPOLL : constant := 23; -- pollable event occurred
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGVTALRM : constant := 34; -- virtual timer expired
- SIGPROF : constant := 32; -- profiling timer expired
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGWAITING : constant := 39; -- m:n scheduling
-
- -- The following signals are AIX specific
-
- SIGMSG : constant := 27; -- input data is in the ring buffer
- SIGDANGER : constant := 33; -- system crash imminent
- SIGMIGRATE : constant := 35; -- migrate process
- SIGPRE : constant := 36; -- programming exception
- SIGVIRT : constant := 37; -- AIX virtual time alarm
- SIGALRM1 : constant := 38; -- m:n condition variables
- SIGCPUFAIL : constant := 59; -- Predictive De-configuration of Processors
- SIGKAP : constant := 60; -- keep alive poll from native keyboard
- SIGGRANT : constant := SIGKAP; -- monitor mode granted
- SIGRETRACT : constant := 61; -- monitor mode should be relinquished
- SIGSOUND : constant := 62; -- sound control has completed
- SIGSAK : constant := 63; -- secure attention key
-
- SIGADAABORT : constant := SIGEMT;
- -- Note: on other targets, we usually use SIGABRT, but on AIX, it appears
- -- that SIGABRT can't be used in sigwait(), so we use SIGEMT.
- -- SIGEMT is "Emulator Trap Instruction" from the PDP-11, and does not
- -- have a standardized usage.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set :=
- (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF);
- Reserved : constant Signal_Set :=
- (SIGABRT, SIGKILL, SIGSTOP, SIGALRM1, SIGWAITING, SIGCPUFAIL);
-
- 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 struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SA_SIGINFO : constant := 16#0100#;
- SA_ONSTACK : constant := 16#0001#;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := True;
- -- Indicates whether time slicing is supported
-
- type timespec is private;
-
- type clockid_t is new long_long;
-
- 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);
-
- type struct_timezone is record
- tz_minuteswest : int;
- tz_dsttime : int;
- end record;
- pragma Convention (C, struct_timezone);
- type struct_timezone_ptr is access all struct_timezone;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 1;
- SCHED_RR : constant := 2;
- SCHED_OTHER : constant := 0;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- pragma Import (C, lwp_self, "thread_self");
-
- -------------
- -- 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 private;
- subtype Thread_Id is 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 AIX. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- 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_size : size_t;
- ss_flags : int;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- -- This is a dummy definition, never used (Alternate_Stack_Size is null)
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- Returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- 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 --
- ---------------------------------------
-
- -- Though not documented, pthread_init *must* be called before any other
- -- pthread call.
-
- procedure pthread_init;
- pragma Import (C, pthread_init, "pthread_init");
-
- -------------------------
- -- 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, "sigthreadmask");
-
- --------------------------
- -- 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 := 2;
-
- function PTHREAD_PRIO_INHERIT return int;
- -- Return value of C macro PTHREAD_PRIO_INHERIT. This function is needed
- -- since the value is different between AIX versions.
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol);
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import (C, pthread_mutexattr_setprioceiling);
-
- type Array_5_Int is array (0 .. 5) of int;
- type struct_sched_param is record
- sched_priority : int;
- sched_policy : int;
- sched_reserved : Array_5_Int;
- end record;
-
- 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;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import (C, pthread_attr_setinheritsched);
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy);
-
- function pthread_attr_setschedparam
- (attr : access pthread_attr_t;
- sched_param : int) return int;
- pragma Import (C, pthread_attr_setschedparam);
-
- function sched_yield return int;
- -- AIX have a nonstandard 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);
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize);
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address)
- return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
-private
- type sigset_t is record
- losigs : unsigned_long;
- hisigs : unsigned_long;
- end record;
- pragma Convention (C_Pass_By_Copy, sigset_t);
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type pthread_attr_t is new System.Address;
- pragma Convention (C, pthread_attr_t);
- -- typedef struct __pt_attr *pthread_attr_t;
-
- type pthread_condattr_t is new System.Address;
- pragma Convention (C, pthread_condattr_t);
- -- typedef struct __pt_attr *pthread_condattr_t;
-
- type pthread_mutexattr_t is new System.Address;
- pragma Convention (C, pthread_mutexattr_t);
- -- typedef struct __pt_attr *pthread_mutexattr_t;
-
- type pthread_t is new System.Address;
- pragma Convention (C, pthread_t);
- -- typedef void *pthread_t;
-
- type ptq_queue;
- type ptq_queue_ptr is access all ptq_queue;
-
- type ptq_queue is record
- ptq_next : ptq_queue_ptr;
- ptq_prev : ptq_queue_ptr;
- end record;
-
- type Array_3_Int is array (0 .. 3) of int;
- type pthread_mutex_t is record
- link : ptq_queue;
- ptmtx_lock : int;
- ptmtx_flags : long;
- protocol : int;
- prioceiling : int;
- ptmtx_owner : pthread_t;
- mtx_id : int;
- attr : pthread_attr_t;
- mtx_kind : int;
- lock_cpt : int;
- reserved : Array_3_Int;
- end record;
- pragma Convention (C, pthread_mutex_t);
- type pthread_mutex_t_ptr is access pthread_mutex_t;
-
- type pthread_cond_t is record
- link : ptq_queue;
- ptcv_lock : int;
- ptcv_flags : long;
- ptcv_waiters : ptq_queue;
- cv_id : int;
- attr : pthread_attr_t;
- mutex : pthread_mutex_t_ptr;
- cptwait : int;
- reserved : int;
- end record;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_key_t is new unsigned;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1995-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- --
--- 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 an Android version of this package.
-
-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.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-with Interfaces.C; use Interfaces.C;
-
-package body System.OS_Interface is
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <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 an Android version of this package which is based on the
--- GNU/Linux version
-
--- 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.Linux;
-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");
-
- EAGAIN : constant := System.Linux.EAGAIN;
- EINTR : constant := System.Linux.EINTR;
- EINVAL : constant := System.Linux.EINVAL;
- ENOMEM : constant := System.Linux.ENOMEM;
- EPERM : constant := System.Linux.EPERM;
- ETIMEDOUT : constant := System.Linux.ETIMEDOUT;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 31;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := System.Linux.SIGHUP;
- SIGINT : constant := System.Linux.SIGINT;
- SIGQUIT : constant := System.Linux.SIGQUIT;
- SIGILL : constant := System.Linux.SIGILL;
- SIGTRAP : constant := System.Linux.SIGTRAP;
- SIGIOT : constant := System.Linux.SIGIOT;
- SIGABRT : constant := System.Linux.SIGABRT;
- SIGFPE : constant := System.Linux.SIGFPE;
- SIGKILL : constant := System.Linux.SIGKILL;
- SIGBUS : constant := System.Linux.SIGBUS;
- SIGSEGV : constant := System.Linux.SIGSEGV;
- SIGPIPE : constant := System.Linux.SIGPIPE;
- SIGALRM : constant := System.Linux.SIGALRM;
- SIGTERM : constant := System.Linux.SIGTERM;
- SIGUSR1 : constant := System.Linux.SIGUSR1;
- SIGUSR2 : constant := System.Linux.SIGUSR2;
- SIGCLD : constant := System.Linux.SIGCLD;
- SIGCHLD : constant := System.Linux.SIGCHLD;
- SIGPWR : constant := System.Linux.SIGPWR;
- SIGWINCH : constant := System.Linux.SIGWINCH;
- SIGURG : constant := System.Linux.SIGURG;
- SIGPOLL : constant := System.Linux.SIGPOLL;
- SIGIO : constant := System.Linux.SIGIO;
- SIGLOST : constant := System.Linux.SIGLOST;
- SIGSTOP : constant := System.Linux.SIGSTOP;
- SIGTSTP : constant := System.Linux.SIGTSTP;
- SIGCONT : constant := System.Linux.SIGCONT;
- SIGTTIN : constant := System.Linux.SIGTTIN;
- SIGTTOU : constant := System.Linux.SIGTTOU;
- SIGVTALRM : constant := System.Linux.SIGVTALRM;
- SIGPROF : constant := System.Linux.SIGPROF;
- SIGXCPU : constant := System.Linux.SIGXCPU;
- SIGXFSZ : constant := System.Linux.SIGXFSZ;
- SIGUNUSED : constant := System.Linux.SIGUNUSED;
- SIGSTKFLT : constant := System.Linux.SIGSTKFLT;
-
- 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 := (SIGVTALRM, SIGUNUSED);
- -- Not clear why these two signals are reserved. Perhaps they are not
- -- supported by this version of GNU/Linux ???
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "_sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "_sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "_sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "_sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "_sigemptyset");
-
- type union_type_3 is new String (1 .. 116);
- type siginfo_t is record
- si_signo : int;
- si_code : int;
- si_errno : int;
- X_data : union_type_3;
- end record;
- pragma Convention (C, siginfo_t);
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : Interfaces.C.unsigned_long;
- sa_restorer : System.Address;
- end record;
- pragma Convention (C, struct_sigaction);
-
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SA_SIGINFO : constant := System.Linux.SA_SIGINFO;
- SA_ONSTACK : constant := System.Linux.SA_ONSTACK;
- SA_NODEFER : constant := System.Linux.SA_NODEFER;
- SA_RESTART : constant := System.Linux.SA_RESTART;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- 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 is (Interfaces.C.int (Prio));
- -- 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;
- pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
- -- The alternate signal stack for stack overflows
-
- Alternate_Stack_Size : constant := 16 * 1024;
- -- This must be in keeping with init.c:__gnat_alternate_stack
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t)
- return Address is (Null_Address);
- -- 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 is null;
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "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, "__gnat_lwp_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
-
- function pthread_setaffinity_np
- (thread : pthread_t;
- cpusetsize : size_t;
- cpuset : cpu_set_t_ptr) return int;
- pragma Import (C, pthread_setaffinity_np, "pthread_setaffinity_np");
- pragma Weak_External (pthread_setaffinity_np);
- -- Use a weak symbol because this function may be available or not,
- -- depending on the version of the system.
-
- function pthread_attr_setaffinity_np
- (attr : access pthread_attr_t;
- cpusetsize : size_t;
- cpuset : cpu_set_t_ptr) return int;
- pragma Import (C, pthread_attr_setaffinity_np,
- "pthread_attr_setaffinity_np");
- pragma Weak_External (pthread_attr_setaffinity_np);
- -- Use a weak symbol because this function may be available or not,
- -- depending on the version of the system.
-
-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;
-
- pragma Warnings (Off);
- for struct_sigaction use record
- sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1;
- sa_mask at Linux.sa_mask_pos range 0 .. sigset_t'Size - 1;
- sa_flags at Linux.sa_flags_pos
- range 0 .. Interfaces.C.unsigned_long'Size - 1;
- end record;
- -- We intentionally leave sa_restorer unspecified and let the compiler
- -- append it after the last field, so disable corresponding warning.
- pragma Warnings (On);
-
- type pid_t is new int;
-
- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1999-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 --
--- <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 a Darwin Threads version of this package
-
-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 Interfaces.C.Extensions;
-
-package body System.OS_Interface is
- use Interfaces.C;
- use Interfaces.C.Extensions;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- -------------------
- -- clock_gettime --
- -------------------
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec) return int
- is
- pragma Unreferenced (clock_id);
-
- -- Darwin Threads don't have clock_gettime, so use gettimeofday
-
- use Interfaces;
-
- type timeval is array (1 .. 3) of C.long;
- -- The timeval array is sized to contain long_long sec and long usec.
- -- If long_long'Size = long'Size then it will be overly large but that
- -- won't effect the implementation since it's not accessed directly.
-
- procedure timeval_to_duration
- (T : not null access timeval;
- sec : not null access C.Extensions.long_long;
- usec : not null access C.long);
- pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
-
- Micro : constant := 10**6;
- sec : aliased C.Extensions.long_long;
- usec : aliased C.long;
- TV : aliased timeval;
- Result : int;
-
- function gettimeofday
- (Tv : access timeval;
- Tz : System.Address := System.Null_Address) return int;
- pragma Import (C, gettimeofday, "gettimeofday");
-
- begin
- Result := gettimeofday (TV'Access, System.Null_Address);
- pragma Assert (Result = 0);
- timeval_to_duration (TV'Access, sec'Access, usec'Access);
- tp.all := To_Timespec (Duration (sec) + Duration (usec) / Micro);
- return Result;
- end clock_gettime;
-
- ------------------
- -- clock_getres --
- ------------------
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int
- is
- pragma Unreferenced (clock_id);
-
- -- Darwin Threads don't have clock_getres.
-
- Nano : constant := 10**9;
- nsec : int := 0;
- Result : int := -1;
-
- function clock_get_res return int;
- pragma Import (C, clock_get_res, "__gnat_clock_get_res");
-
- begin
- nsec := clock_get_res;
- res.all := To_Timespec (Duration (0.0) + Duration (nsec) / Nano);
-
- if nsec > 0 then
- Result := 0;
- end if;
-
- return Result;
- end clock_getres;
-
- -----------------
- -- sched_yield --
- -----------------
-
- function sched_yield return int is
- procedure sched_yield_base (arg : System.Address);
- pragma Import (C, sched_yield_base, "pthread_yield_np");
-
- begin
- sched_yield_base (System.Null_Address);
- return 0;
- end sched_yield;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- ----------------
- -- Stack_Base --
- ----------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Unreferenced (thread);
- begin
- return System.Null_Address;
- end Get_Stack_Base;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1991-2017, Florida State University --
--- 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 --
--- <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 Darwin pthreads version of this package
-
--- This package includes 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
--- Elaborate_Body. It is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-with System.OS_Constants;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- subtype int is Interfaces.C.int;
- 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");
-
- EINTR : constant := 4;
- ENOMEM : constant := 12;
- EINVAL : constant := 22;
- EAGAIN : constant := 35;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 31;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGINFO : constant := 29; -- information request
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set :=
- (SIGTTIN, SIGTTOU, SIGSTOP, SIGTSTP);
-
- Reserved : constant Signal_Set :=
- (SIGKILL, SIGSTOP);
-
- Exception_Signals : constant Signal_Set :=
- (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
- -- These signals (when runtime or system) will be caught and converted
- -- into an Ada exception.
-
- 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 siginfo_t is private;
- type ucontext_t is private;
-
- type Signal_Handler is access procedure
- (signo : Signal;
- info : access siginfo_t;
- context : access ucontext_t);
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- SA_SIGINFO : constant := 16#0040#;
- SA_ONSTACK : constant := 16#0001#;
-
- 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;
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_OTHER : constant := 1;
- SCHED_RR : constant := 2;
- SCHED_FIFO : constant := 4;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- pragma Import (C, lwp_self, "__gnat_lwp_self");
- -- Return the mach thread bound to the current thread. The value is not
- -- used by the run-time library but made available to debuggers.
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- type pthread_t is private;
- subtype Thread_Id is 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;
-
- type pthread_mutex_ptr is access all pthread_mutex_t;
- type pthread_cond_ptr is access all pthread_cond_t;
-
- PTHREAD_CREATE_DETACHED : constant := 2;
-
- PTHREAD_SCOPE_PROCESS : constant := 2;
- PTHREAD_SCOPE_SYSTEM : constant := 1;
-
- -- Read/Write lock not supported on Darwin. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- 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_size : size_t;
- ss_flags : int;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
- -- The alternate signal stack for stack overflows
-
- Alternate_Stack_Size : constant := 32 * 1024;
- -- 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. This
- -- allows us to share s-osinte.adb between all the FSU run time. Note that
- -- this value can only be true if pthread_t has a complete definition that
- -- corresponds exactly to the C header files.
-
- function Get_Stack_Base (thread : pthread_t) return System.Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- 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_NONE;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect
- (addr : System.Address;
- len : size_t;
- prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_INHERIT : constant := 1;
- PTHREAD_PRIO_PROTECT : constant := 2;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprioceiling,
- "pthread_mutexattr_setprioceiling");
-
- type padding is array (int range <>) of Interfaces.C.char;
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- opaque : padding (1 .. 4);
- 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;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import
- (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched");
-
- function sched_yield return int;
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import
- (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import
- (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
-private
-
- type sigset_t is new unsigned;
-
- type int32_t is new int;
-
- type pid_t is new int32_t;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- --
- -- Darwin specific signal implementation
- --
- type Pad_Type is array (1 .. 7) of unsigned_long;
- type siginfo_t is record
- si_signo : int; -- signal number
- si_errno : int; -- errno association
- si_code : int; -- signal code
- si_pid : int; -- sending process
- si_uid : unsigned; -- sender's ruid
- si_status : int; -- exit value
- si_addr : System.Address; -- faulting instruction
- si_value : System.Address; -- signal value
- si_band : long; -- band event for SIGPOLL
- pad : Pad_Type; -- RFU
- end record;
- pragma Convention (C, siginfo_t);
-
- type mcontext_t is new System.Address;
-
- type ucontext_t is record
- uc_onstack : int;
- uc_sigmask : sigset_t; -- Signal Mask Used By This Context
- uc_stack : stack_t; -- Stack Used By This Context
- uc_link : System.Address; -- Pointer To Resuming Context
- uc_mcsize : size_t; -- Size of The Machine Context
- uc_mcontext : mcontext_t; -- Machine Specific Context
- end record;
- pragma Convention (C, ucontext_t);
-
- --
- -- Darwin specific pthread implementation
- --
- type pthread_t is new System.Address;
-
- type pthread_attr_t is record
- sig : long;
- opaque : padding (1 .. System.OS_Constants.PTHREAD_ATTR_SIZE);
- end record;
- pragma Convention (C, pthread_attr_t);
-
- type pthread_mutexattr_t is record
- sig : long;
- opaque : padding (1 .. System.OS_Constants.PTHREAD_MUTEXATTR_SIZE);
- end record;
- pragma Convention (C, pthread_mutexattr_t);
-
- type pthread_mutex_t is record
- sig : long;
- opaque : padding (1 .. System.OS_Constants.PTHREAD_MUTEX_SIZE);
- end record;
- pragma Convention (C, pthread_mutex_t);
-
- type pthread_condattr_t is record
- sig : long;
- opaque : padding (1 .. System.OS_Constants.PTHREAD_CONDATTR_SIZE);
- end record;
- pragma Convention (C, pthread_condattr_t);
-
- type pthread_cond_t is record
- sig : long;
- opaque : padding (1 .. System.OS_Constants.PTHREAD_COND_SIZE);
- end record;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_once_t is record
- sig : long;
- opaque : padding (1 .. System.OS_Constants.PTHREAD_ONCE_SIZE);
- end record;
- pragma Convention (C, pthread_once_t);
-
- type pthread_key_t is new unsigned_long;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-2015, 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. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
--- This is the DragonFly THREADS version of this package
-
-with Interfaces.C; use Interfaces.C;
-
-package body System.OS_Interface is
-
- -----------
- -- Errno --
- -----------
-
- function Errno return int is
- type int_ptr is access all int;
-
- function internal_errno return int_ptr;
- pragma Import (C, internal_errno, "__get_errno");
-
- begin
- return (internal_errno.all);
- end Errno;
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Unreferenced (thread);
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(ts_sec => S,
- ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1991-1994, Florida State University --
--- Copyright (C) 1995-2015, 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
--- This is the DragonFly BSD PTHREADS version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-pthread");
-
- subtype int is Interfaces.C.int;
- 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 Inline (Errno);
-
- EAGAIN : constant := 35;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 31;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGINFO : constant := 29; -- information request (BSD)
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- -- Interrupts that must be unmasked at all times. DragonFlyBSD
- -- pthreads will not allow an application to mask out any
- -- interrupt needed by the threads library.
- Unmasked : constant Signal_Set :=
- (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP);
-
- -- DragonFlyBSD will uses SIGPROF for timing. Do not allow a
- -- handler to attach to this signal.
- Reserved : constant Signal_Set := (0 .. 0 => SIGPROF);
-
- 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");
-
- -- sigcontext is architecture dependent, so define it private
- type struct_sigcontext is private;
-
- type old_struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, old_struct_sigaction);
-
- type new_struct_sigaction is record
- sa_handler : System.Address;
- sa_flags : int;
- sa_mask : sigset_t;
- end record;
- pragma Convention (C, new_struct_sigaction);
-
- subtype struct_sigaction is new_struct_sigaction;
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- SA_SIGINFO : constant := 16#0040#;
- SA_ONSTACK : constant := 16#0001#;
-
- 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 (i.e SCHED_RR is supported)
-
- type timespec is private;
-
- function nanosleep (rqtp, rmtp : access timespec) return int;
- pragma Import (C, nanosleep, "nanosleep");
-
- type clockid_t is new unsigned_long;
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
- pragma Import (C, clock_getres, "clock_getres");
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec)
- return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- type struct_timezone is record
- tz_minuteswest : int;
- tz_dsttime : int;
- end record;
- pragma Convention (C, struct_timezone);
-
- procedure usleep (useconds : unsigned_long);
- pragma Import (C, usleep, "usleep");
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 1;
- SCHED_OTHER : constant := 2;
- SCHED_RR : constant := 3;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- Threads --
- -------------
-
- 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 private;
- subtype Thread_Id is 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_CREATE_JOINABLE : constant := 0;
-
- PTHREAD_SCOPE_PROCESS : constant := 0;
- PTHREAD_SCOPE_SYSTEM : constant := 2;
-
- -- Read/Write lock not supported on DragonFly. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- 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_size : size_t;
- ss_flags : int;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- -- This is a dummy definition, never used (Alternate_Stack_Size is null)
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target. This
- -- allows us to share s-osinte.adb between all the FSU run time. Note that
- -- this value can only be true if pthread_t has a complete definition that
- -- corresponds exactly to the C header files.
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- 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_NONE;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- -- FSU_THREADS requires pthread_init, which is nonstandard and this should
- -- be invoked during the elaboration of s-taprop.adb.
-
- -- DragonFlyBSD does not require this so we provide an empty Ada body
-
- procedure pthread_init;
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 2;
- PTHREAD_PRIO_INHERIT : constant := 1;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
-
- function pthread_mutexattr_getprotocol
- (attr : access pthread_mutexattr_t;
- protocol : access int) return int;
- pragma Import
- (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol");
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprioceiling,
- "pthread_mutexattr_setprioceiling");
-
- function pthread_mutexattr_getprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : access int) return int;
- pragma Import
- (C, pthread_mutexattr_getprioceiling,
- "pthread_mutexattr_getprioceiling");
-
- type struct_sched_param is record
- sched_priority : int;
- end record;
- pragma Convention (C, struct_sched_param);
-
- function pthread_getschedparam
- (thread : pthread_t;
- policy : access int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_getschedparam, "pthread_getschedparam");
-
- 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;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_getscope
- (attr : access pthread_attr_t;
- contentionscope : access int) return int;
- pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import
- (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
-
- function pthread_attr_getinheritsched
- (attr : access pthread_attr_t;
- inheritsched : access int) return int;
- pragma Import
- (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy,
- "pthread_attr_setschedpolicy");
-
- function pthread_attr_getschedpolicy
- (attr : access pthread_attr_t;
- policy : access int) return int;
- pragma Import (C, pthread_attr_getschedpolicy,
- "pthread_attr_getschedpolicy");
-
- function pthread_attr_setschedparam
- (attr : access pthread_attr_t;
- sched_param : int) return int;
- pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
-
- function pthread_attr_getschedparam
- (attr : access pthread_attr_t;
- sched_param : access int) return int;
- pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam");
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "pthread_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_getdetachstate
- (attr : access pthread_attr_t;
- detachstate : access int) return int;
- pragma Import
- (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate");
-
- function pthread_attr_getstacksize
- (attr : access pthread_attr_t;
- stacksize : access size_t) return int;
- pragma Import
- (C, pthread_attr_getstacksize, "pthread_attr_getstacksize");
-
- 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");
-
- function pthread_detach (thread : pthread_t) return int;
- pragma Import (C, pthread_detach, "pthread_detach");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- ------------------------------------
- -- Non-portable Pthread Functions --
- ------------------------------------
-
- function pthread_set_name_np
- (thread : pthread_t;
- name : System.Address) return int;
- pragma Import (C, pthread_set_name_np, "pthread_set_name_np");
-
-private
-
- type sigset_t is array (1 .. 4) of unsigned;
-
- -- In DragonFlyBSD the component sa_handler turns out to
- -- be one a union type, and the selector is a macro:
- -- #define sa_handler __sigaction_u._handler
- -- #define sa_sigaction __sigaction_u._sigaction
-
- -- Should we add a signal_context type here ???
- -- How could it be done independent of the CPU architecture ???
- -- sigcontext type is opaque, so it is architecturally neutral.
- -- It is always passed as an access type, so define it as an empty record
- -- since the contents are not used anywhere.
-
- type struct_sigcontext is null record;
- pragma Convention (C, struct_sigcontext);
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- ts_sec : time_t;
- ts_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type pthread_t is new System.Address;
- type pthread_attr_t is new System.Address;
- type pthread_mutex_t is new System.Address;
- type pthread_mutexattr_t is new System.Address;
- type pthread_cond_t is new System.Address;
- type pthread_condattr_t is new System.Address;
- type pthread_key_t is new int;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1991-2017, Florida State University --
--- 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 --
--- <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 no tasking version
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 2;
- type Signal is new Integer range 0 .. Max_Interrupt;
-
- type sigset_t is new Integer;
- type Thread_Id is new Integer;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
--- This is the FreeBSD THREADS version of this package
-
-with Interfaces.C; use Interfaces.C;
-
-package body System.OS_Interface is
-
- -----------
- -- Errno --
- -----------
-
- function Errno return int is
- type int_ptr is access all int;
-
- function internal_errno return int_ptr;
- pragma Import (C, internal_errno, "__get_errno");
-
- begin
- return (internal_errno.all);
- end Errno;
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Unreferenced (thread);
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(ts_sec => S,
- ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1991-2017, Florida State University --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
--- This is the FreeBSD (POSIX Threads) version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-pthread");
-
- subtype int is Interfaces.C.int;
- 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 Inline (Errno);
-
- EAGAIN : constant := 35;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 31;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD)
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- -- Interrupts that must be unmasked at all times. FreeBSD
- -- pthreads will not allow an application to mask out any
- -- interrupt needed by the threads library.
- Unmasked : constant Signal_Set :=
- (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP);
-
- -- FreeBSD will uses SIGPROF for timing. Do not allow a
- -- handler to attach to this signal.
- Reserved : constant Signal_Set := (0 .. 0 => SIGPROF);
-
- 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");
-
- -- sigcontext is architecture dependent, so define it private
- type struct_sigcontext is private;
-
- type old_struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, old_struct_sigaction);
-
- type new_struct_sigaction is record
- sa_handler : System.Address;
- sa_flags : int;
- sa_mask : sigset_t;
- end record;
- pragma Convention (C, new_struct_sigaction);
-
- subtype struct_sigaction is new_struct_sigaction;
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- SA_SIGINFO : constant := 16#0040#;
- SA_ONSTACK : constant := 16#0001#;
-
- 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 (i.e SCHED_RR is supported)
-
- type timespec is private;
-
- function nanosleep (rqtp, rmtp : access timespec) return int;
- pragma Import (C, nanosleep, "nanosleep");
-
- type clockid_t is new int;
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
- pragma Import (C, clock_getres, "clock_getres");
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec)
- return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- type struct_timezone is record
- tz_minuteswest : int;
- tz_dsttime : int;
- end record;
- pragma Convention (C, struct_timezone);
-
- procedure usleep (useconds : unsigned_long);
- pragma Import (C, usleep, "usleep");
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 1;
- SCHED_OTHER : constant := 2;
- SCHED_RR : constant := 3;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- Self_PID : constant pid_t;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- Threads --
- -------------
-
- 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 private;
- subtype Thread_Id is 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_CREATE_JOINABLE : constant := 0;
-
- PTHREAD_SCOPE_PROCESS : constant := 0;
- PTHREAD_SCOPE_SYSTEM : constant := 2;
-
- -- Read/Write lock not supported on freebsd. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- 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_size : size_t;
- ss_flags : int;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- -- This is a dummy definition, never used (Alternate_Stack_Size is null)
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- 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_NONE;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- -- FSU_THREADS requires pthread_init, which is nonstandard and this should
- -- be invoked during the elaboration of s-taprop.adb.
-
- -- FreeBSD does not require this so we provide an empty Ada body
-
- procedure pthread_init;
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 2;
- PTHREAD_PRIO_INHERIT : constant := 1;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
-
- function pthread_mutexattr_getprotocol
- (attr : access pthread_mutexattr_t;
- protocol : access int) return int;
- pragma Import
- (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol");
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprioceiling,
- "pthread_mutexattr_setprioceiling");
-
- function pthread_mutexattr_getprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : access int) return int;
- pragma Import
- (C, pthread_mutexattr_getprioceiling,
- "pthread_mutexattr_getprioceiling");
-
- type struct_sched_param is record
- sched_priority : int;
- end record;
- pragma Convention (C, struct_sched_param);
-
- function pthread_getschedparam
- (thread : pthread_t;
- policy : access int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_getschedparam, "pthread_getschedparam");
-
- 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;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_getscope
- (attr : access pthread_attr_t;
- contentionscope : access int) return int;
- pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import
- (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
-
- function pthread_attr_getinheritsched
- (attr : access pthread_attr_t;
- inheritsched : access int) return int;
- pragma Import
- (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy,
- "pthread_attr_setschedpolicy");
-
- function pthread_attr_getschedpolicy
- (attr : access pthread_attr_t;
- policy : access int) return int;
- pragma Import (C, pthread_attr_getschedpolicy,
- "pthread_attr_getschedpolicy");
-
- function pthread_attr_setschedparam
- (attr : access pthread_attr_t;
- sched_param : int) return int;
- pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
-
- function pthread_attr_getschedparam
- (attr : access pthread_attr_t;
- sched_param : access int) return int;
- pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam");
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "pthread_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_getdetachstate
- (attr : access pthread_attr_t;
- detachstate : access int) return int;
- pragma Import
- (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate");
-
- function pthread_attr_getstacksize
- (attr : access pthread_attr_t;
- stacksize : access size_t) return int;
- pragma Import
- (C, pthread_attr_getstacksize, "pthread_attr_getstacksize");
-
- 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");
-
- function pthread_detach (thread : pthread_t) return int;
- pragma Import (C, pthread_detach, "pthread_detach");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- ------------------------------------
- -- Non-portable Pthread Functions --
- ------------------------------------
-
- function pthread_set_name_np
- (thread : pthread_t;
- name : System.Address) return int;
- pragma Import (C, pthread_set_name_np, "pthread_set_name_np");
-
-private
-
- type sigset_t is array (1 .. 4) of unsigned;
-
- -- In FreeBSD the component sa_handler turns out to
- -- be one a union type, and the selector is a macro:
- -- #define sa_handler __sigaction_u._handler
- -- #define sa_sigaction __sigaction_u._sigaction
-
- -- Should we add a signal_context type here ???
- -- How could it be done independent of the CPU architecture ???
- -- sigcontext type is opaque, so it is architecturally neutral.
- -- It is always passed as an access type, so define it as an empty record
- -- since the contents are not used anywhere.
-
- type struct_sigcontext is null record;
- pragma Convention (C, struct_sigcontext);
-
- type pid_t is new int;
- Self_PID : constant pid_t := 0;
-
- type time_t is new long;
-
- type timespec is record
- ts_sec : time_t;
- ts_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type pthread_t is new System.Address;
- type pthread_attr_t is new System.Address;
- type pthread_mutex_t is new System.Address;
- type pthread_mutexattr_t is new System.Address;
- type pthread_cond_t is new System.Address;
- type pthread_condattr_t is new System.Address;
- type pthread_key_t is new int;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2015-2016, 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 --
--- <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 GNU/Hurd version of this package.
-
-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.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-package body System.OS_Interface is
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
-
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- --------------------------------------
- -- pthread_mutexattr_setprioceiling --
- --------------------------------------
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int is
- pragma Unreferenced (attr, prioceiling);
- begin
- return 0;
- end pthread_mutexattr_setprioceiling;
-
- --------------------------------------
- -- pthread_mutexattr_getprioceiling --
- --------------------------------------
-
- function pthread_mutexattr_getprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : access int) return int is
- pragma Unreferenced (attr, prioceiling);
- begin
- return 0;
- end pthread_mutexattr_getprioceiling;
-
- ---------------------------
- -- pthread_setschedparam --
- ---------------------------
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int is
- pragma Unreferenced (thread, policy, param);
- begin
- return 0;
- end pthread_setschedparam;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2016, 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 --
--- <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 GNU/Hurd (POSIX Threads) version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package
-
-with Interfaces.C;
-with Unchecked_Conversion;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lpthread");
- pragma Linker_Options ("-lrt");
-
- 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 --
- -----------
- -- From /usr/include/i386-gnu/bits/errno.h
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 1073741859;
- EINTR : constant := 1073741828;
- EINVAL : constant := 1073741846;
- ENOMEM : constant := 1073741836;
- EPERM : constant := 1073741825;
- ETIMEDOUT : constant := 1073741884;
-
- -------------
- -- Signals --
- -------------
- -- From /usr/include/i386-gnu/bits/signum.h
-
- Max_Interrupt : constant := 32;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGPOLL : constant := 23; -- I/O possible (same as SIGIO?)
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD)
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
- SIGLOST : constant := 32; -- Resource lost (Sun); server died (GNU)
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set := (
- SIGTRAP,
- -- To enable debugging on multithreaded applications, mark SIGTRAP to
- -- be kept unmasked.
-
- SIGBUS,
-
- SIGTTIN, SIGTTOU, SIGTSTP,
- -- Keep these three signals unmasked so that background processes
- -- and IO behaves as normal "C" applications
-
- SIGPROF,
- -- To avoid confusing the profiler
-
- SIGKILL, SIGSTOP);
- -- These two signals actually cannot be masked;
- -- POSIX simply won't allow it.
-
- Reserved : constant Signal_Set :=
- -- I am not sure why the following signal is reserved.
- -- I guess they are not supported by this version of GNU/Hurd.
- (0 .. 0 => SIGVTALRM);
-
- type sigset_t is private;
-
- -- From /usr/include/signal.h /usr/include/i386-gnu/bits/sigset.h
- 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");
-
- -- sigcontext is architecture dependent, so define it private
- type struct_sigcontext is private;
-
- -- From /usr/include/i386-gnu/bits/sigaction.h: Note: arg. order differs
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
-
- type struct_sigaction_ptr is access all struct_sigaction;
-
- -- From /usr/include/i386-gnu/bits/sigaction.h
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- -- From /usr/include/i386-gnu/bits/signum.h
- SIG_ERR : constant := 1;
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
- SIG_HOLD : constant := 2;
-
- -- From /usr/include/i386-gnu/bits/sigaction.h
- SA_SIGINFO : constant := 16#0040#;
- SA_ONSTACK : constant := 16#0001#;
-
- 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 (i.e SCHED_RR is supported)
-
- type timespec is private;
-
- function nanosleep (rqtp, rmtp : access timespec) return int;
- pragma Import (C, nanosleep, "nanosleep");
-
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 0;
-
- -- From: /usr/include/time.h
- 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);
-
- -- From: /usr/include/unistd.h
- function sysconf (name : int) return long;
- pragma Import (C, sysconf);
-
- -- From /usr/include/i386-gnu/bits/confname.h
- SC_CLK_TCK : constant := 2;
- SC_NPROCESSORS_ONLN : constant := 84;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
- -- From /usr/include/i386-gnu/bits/sched.h
-
- SCHED_OTHER : constant := 0;
- SCHED_FIFO : constant := 1;
- SCHED_RR : constant := 2;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority.
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- -- From: /usr/include/signal.h
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- -- From: /usr/include/unistd.h
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- -- From: /usr/include/pthread/pthread.h
- function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Unchecked_Conversion (System.Address, Thread_Body);
-
- -- From: /usr/include/bits/pthread.h:typedef int __pthread_t;
- -- /usr/include/pthread/pthreadtypes.h:typedef __pthread_t pthread_t;
- type pthread_t is new unsigned_long;
- subtype Thread_Id is pthread_t;
-
- function To_pthread_t is new Unchecked_Conversion
- (unsigned_long, pthread_t);
-
- type pthread_mutex_t is limited private;
- type pthread_rwlock_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_rwlockattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- -- From /usr/include/pthread/pthreadtypes.h
- PTHREAD_CREATE_DETACHED : constant := 1;
- PTHREAD_CREATE_JOINABLE : constant := 0;
-
- PTHREAD_SCOPE_PROCESS : constant := 1;
- PTHREAD_SCOPE_SYSTEM : constant := 0;
-
- -----------
- -- Stack --
- -----------
-
- -- From: /usr/include/i386-gnu/bits/sigstack.h
- type stack_t is record
- ss_sp : System.Address;
- ss_size : size_t;
- ss_flags : int;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- -- This is a dummy definition, never used (Alternate_Stack_Size is null)
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- -- From: /usr/include/i386-gnu/bits/shm.h
- function Get_Page_Size return int;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- Returns the size of a page
-
- -- From /usr/include/i386-gnu/bits/mman.h
- PROT_NONE : constant := 0;
- PROT_READ : constant := 4;
- PROT_WRITE : constant := 2;
- PROT_EXEC : constant := 1;
- PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
- PROT_ON : constant := PROT_NONE;
- PROT_OFF : constant := PROT_ALL;
-
- -- From /usr/include/i386-gnu/bits/mman.h
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
- pragma Inline (pthread_init);
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- -- From: /usr/include/signal.h:
- -- sigwait (__const sigset_t *__restrict __set, int *__restrict __sig)
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- -- From: /usr/include/pthread/pthread.h:
- -- extern int pthread_kill (pthread_t thread, int signo);
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- -- From: /usr/include/i386-gnu/bits/sigthread.h
- -- extern int pthread_sigmask (int __how, __const __sigset_t *__newmask,
- -- __sigset_t *__oldmask) __THROW;
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- -- From: /usr/include/pthread/pthread.h and
- -- /usr/include/pthread/pthreadtypes.h
- 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_rwlockattr_init
- (attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init");
-
- function pthread_rwlockattr_destroy
- (attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy");
- PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0;
- PTHREAD_RWLOCK_PREFER_WRITER_NP : constant := 1;
- PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 2;
-
- function pthread_rwlockattr_setkind_np
- (attr : access pthread_rwlockattr_t;
- pref : int) return int;
- pragma Import
- (C, pthread_rwlockattr_setkind_np, "pthread_rwlockattr_setkind_np");
-
- function pthread_rwlock_init
- (mutex : access pthread_rwlock_t;
- attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init");
-
- function pthread_rwlock_destroy
- (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy");
-
- function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock");
-
- function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock");
-
- function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_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 --
- --------------------------
- -- From /usr/include/pthread/pthreadtypes.h
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 2;
- PTHREAD_PRIO_INHERIT : constant := 1;
-
- -- GNU/Hurd does not support Thread Priority Protection or Thread
- -- Priority Inheritance and lacks some pthread_mutexattr_* functions.
- -- Replace them with dummy versions.
- -- From: /usr/include/pthread/pthread.h
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol,
- "pthread_mutexattr_setprotocol");
-
- function pthread_mutexattr_getprotocol
- (attr : access pthread_mutexattr_t;
- protocol : access int) return int;
- pragma Import (C, pthread_mutexattr_getprotocol,
- "pthread_mutexattr_getprotocol");
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
-
- function pthread_mutexattr_getprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : access int) return int;
-
- 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;
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_getscope
- (attr : access pthread_attr_t;
- contentionscope : access int) return int;
- pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import (C, pthread_attr_setinheritsched,
- "pthread_attr_setinheritsched");
-
- function pthread_attr_getinheritsched
- (attr : access pthread_attr_t;
- inheritsched : access int) return int;
- pragma Import (C, pthread_attr_getinheritsched,
- "pthread_attr_getinheritsched");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy, "pthread_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");
-
- -- From: /usr/include/pthread/pthread.h
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- -- From /usr/include/i386-gnu/bits/sched.h
- CPU_SETSIZE : constant := 1_024;
-
- type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
- for bit_field'Size use CPU_SETSIZE;
- pragma Pack (bit_field);
- pragma Convention (C, bit_field);
-
- type cpu_set_t is record
- bits : bit_field;
- end record;
- pragma Convention (C, cpu_set_t);
-
-private
-
- type sigset_t is array (1 .. 4) of unsigned;
-
- -- In GNU/Hurd the component sa_handler turns out to
- -- be one a union type, and the selector is a macro:
- -- #define sa_handler __sigaction_handler.sa_handler
- -- #define sa_sigaction __sigaction_handler.sa_sigaction
-
- -- Should we add a signal_context type here ?
- -- How could it be done independent of the CPU architecture ?
- -- sigcontext type is opaque, so it is architecturally neutral.
- -- It is always passed as an access type, so define it as an empty record
- -- since the contents are not used anywhere.
- type struct_sigcontext is null record;
- pragma Convention (C, struct_sigcontext);
-
- 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);
-
- -- From: /usr/include/pthread/pthreadtypes.h:
- -- typedef struct __pthread_attr pthread_attr_t;
- -- /usr/include/i386-gnu/bits/thread-attr.h: struct __pthread_attr...
- -- /usr/include/pthread/pthreadtypes.h: enum __pthread_contentionscope
- -- enum __pthread_detachstate detachstate;
- -- enum __pthread_inheritsched inheritsched;
- -- enum __pthread_contentionscope contentionscope;
- -- Not used: schedpolicy : int;
- type pthread_attr_t is record
- schedparam : struct_sched_param;
- stackaddr : System.Address;
- stacksize : size_t;
- guardsize : size_t;
- detachstate : int;
- inheritsched : int;
- contentionscope : int;
- schedpolicy : int;
- end record;
- pragma Convention (C, pthread_attr_t);
-
- -- From: /usr/include/pthread/pthreadtypes.h:
- -- typedef struct __pthread_condattr pthread_condattr_t;
- -- From: /usr/include/i386-gnu/bits/condition-attr.h:
- -- struct __pthread_condattr {
- -- enum __pthread_process_shared pshared;
- -- __Clockid_T Clock;}
- -- From: /usr/include/pthread/pthreadtypes.h:
- -- enum __pthread_process_shared
- type pthread_condattr_t is record
- pshared : int;
- clock : clockid_t;
- end record;
- pragma Convention (C, pthread_condattr_t);
-
- -- From: /usr/include/pthread/pthreadtypes.h:
- -- typedef struct __pthread_mutexattr pthread_mutexattr_t; and
- -- /usr/include/i386-gnu/bits/mutex-attr.h
- -- struct __pthread_mutexattr {
- -- int prioceiling;
- -- enum __pthread_mutex_protocol protocol;
- -- enum __pthread_process_shared pshared;
- -- enum __pthread_mutex_type mutex_type;};
- type pthread_mutexattr_t is record
- prioceiling : int;
- protocol : int;
- pshared : int;
- mutex_type : int;
- end record;
- pragma Convention (C, pthread_mutexattr_t);
-
- -- From: /usr/include/pthread/pthreadtypes.h
- -- typedef struct __pthread_mutex pthread_mutex_t; and
- -- /usr/include/i386-gnu/bits/mutex.h:
- -- struct __pthread_mutex {
- -- __pthread_spinlock_t __held;
- -- __pthread_spinlock_t __lock;
- -- /* in cthreads, mutex_init does not initialized the third
- -- pointer, as such, we cannot rely on its value for anything. */
- -- char *cthreadscompat1;
- -- struct __pthread *__queue;
- -- struct __pthread_mutexattr *attr;
- -- void *data;
- -- /* up to this point, we are completely compatible with cthreads
- -- and what libc expects. */
- -- void *owner;
- -- unsigned locks;
- -- /* if null then the default attributes apply. */
- -- };
-
- type pthread_mutex_t is record
- held : int;
- lock : int;
- cthreadcompat : System.Address;
- queue : System.Address;
- attr : System.Address;
- data : System.Address;
- owner : System.Address;
- locks : unsigned;
- end record;
- pragma Convention (C, pthread_mutex_t);
- -- pointer needed?
- -- type pthread_mutex_t_ptr is access pthread_mutex_t;
-
- -- From: /usr/include/pthread/pthreadtypes.h:
- -- typedef struct __pthread_cond pthread_cond_t;
- -- typedef struct __pthread_condattr pthread_condattr_t;
- -- /usr/include/i386-gnu/bits/condition.h:struct __pthread_cond{}
- -- pthread_condattr_t: see above!
- -- /usr/include/i386-gnu/bits/condition.h:
- -- struct __pthread_condimpl *__impl;
-
- type pthread_cond_t is record
- lock : int;
- queue : System.Address;
- condattr : System.Address;
- impl : System.Address;
- data : System.Address;
- end record;
- pragma Convention (C, pthread_cond_t);
-
- -- From: /usr/include/pthread/pthreadtypes.h:
- -- typedef __pthread_key pthread_key_t; and
- -- /usr/include/i386-gnu/bits/thread-specific.h:
- -- typedef int __pthread_key;
-
- type pthread_key_t is new int;
-
- -- From: /usr/include/i386-gnu/bits/rwlock-attr.h:
- -- struct __pthread_rwlockattr {
- -- enum __pthread_process_shared pshared; };
-
- type pthread_rwlockattr_t is record
- pshared : int;
- end record;
- pragma Convention (C, pthread_rwlockattr_t);
-
- -- From: /usr/include/i386-gnu/bits/rwlock.h:
- -- struct __pthread_rwlock {
- -- __pthread_spinlock_t __held;
- -- __pthread_spinlock_t __lock;
- -- int readers;
- -- struct __pthread *readerqueue;
- -- struct __pthread *writerqueue;
- -- struct __pthread_rwlockattr *__attr;
- -- void *__data; };
-
- type pthread_rwlock_t is record
- held : int;
- lock : int;
- readers : int;
- readerqueue : System.Address;
- writerqueue : System.Address;
- attr : pthread_rwlockattr_t;
- data : int;
- end record;
- pragma Convention (C, pthread_rwlock_t);
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2010, 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- --
--- 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 a DCE version of this package.
--- Currently HP-UX and SNI use this file
-
-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.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-with Interfaces.C; use Interfaces.C;
-
-package body System.OS_Interface is
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int
- is
- Result : int;
-
- begin
- Result := sigwait (set);
-
- if Result = -1 then
- sig.all := 0;
- return errno;
- end if;
-
- sig.all := Signal (Result);
- return 0;
- end sigwait;
-
- -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int is
- pragma Unreferenced (thread, sig);
- begin
- return 0;
- end pthread_kill;
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- -- For all following functions, DCE Threads has a non standard behavior.
- -- It sets errno but the standard Posix requires it to be returned.
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int
- is
- function pthread_mutexattr_create
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create");
-
- begin
- if pthread_mutexattr_create (attr) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutexattr_init;
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int
- is
- function pthread_mutexattr_delete
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete");
-
- begin
- if pthread_mutexattr_delete (attr) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutexattr_destroy;
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int
- is
- function pthread_mutex_init_base
- (mutex : access pthread_mutex_t;
- attr : pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init");
-
- begin
- if pthread_mutex_init_base (mutex, attr.all) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutex_init;
-
- function pthread_mutex_destroy
- (mutex : access pthread_mutex_t) return int
- is
- function pthread_mutex_destroy_base
- (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy");
-
- begin
- if pthread_mutex_destroy_base (mutex) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutex_destroy;
-
- function pthread_mutex_lock
- (mutex : access pthread_mutex_t) return int
- is
- function pthread_mutex_lock_base
- (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock");
-
- begin
- if pthread_mutex_lock_base (mutex) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutex_lock;
-
- function pthread_mutex_unlock
- (mutex : access pthread_mutex_t) return int
- is
- function pthread_mutex_unlock_base
- (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock");
-
- begin
- if pthread_mutex_unlock_base (mutex) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutex_unlock;
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int
- is
- function pthread_condattr_create
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_create, "pthread_condattr_create");
-
- begin
- if pthread_condattr_create (attr) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_condattr_init;
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int
- is
- function pthread_condattr_delete
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete");
-
- begin
- if pthread_condattr_delete (attr) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_condattr_destroy;
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int
- is
- function pthread_cond_init_base
- (cond : access pthread_cond_t;
- attr : pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init_base, "pthread_cond_init");
-
- begin
- if pthread_cond_init_base (cond, attr.all) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_cond_init;
-
- function pthread_cond_destroy
- (cond : access pthread_cond_t) return int
- is
- function pthread_cond_destroy_base
- (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy");
-
- begin
- if pthread_cond_destroy_base (cond) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_cond_destroy;
-
- function pthread_cond_signal
- (cond : access pthread_cond_t) return int
- is
- function pthread_cond_signal_base
- (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal");
-
- begin
- if pthread_cond_signal_base (cond) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_cond_signal;
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int
- is
- function pthread_cond_wait_base
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait");
-
- begin
- if pthread_cond_wait_base (cond, mutex) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_cond_wait;
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int
- is
- function pthread_cond_timedwait_base
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
-
- begin
- if pthread_cond_timedwait_base (cond, mutex, abstime) /= 0 then
- return (if errno = EAGAIN then ETIMEDOUT else errno);
- else
- return 0;
- end if;
- end pthread_cond_timedwait;
-
- ----------------------------
- -- POSIX.1c Section 13 --
- ----------------------------
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int
- is
- function pthread_setscheduler
- (thread : pthread_t;
- policy : int;
- priority : int) return int;
- pragma Import (C, pthread_setscheduler, "pthread_setscheduler");
-
- begin
- if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then
- return errno;
- else
- return 0;
- end if;
- end pthread_setschedparam;
-
- function sched_yield return int is
- procedure pthread_yield;
- pragma Import (C, pthread_yield, "pthread_yield");
- begin
- pthread_yield;
- return 0;
- end sched_yield;
-
- -----------------------------
- -- P1003.1c - Section 16 --
- -----------------------------
-
- function pthread_attr_init
- (attributes : access pthread_attr_t) return int
- is
- function pthread_attr_create
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_create, "pthread_attr_create");
-
- begin
- if pthread_attr_create (attributes) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_attr_init;
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int
- is
- function pthread_attr_delete
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_delete, "pthread_attr_delete");
-
- begin
- if pthread_attr_delete (attributes) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_attr_destroy;
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int
- is
- function pthread_attr_setstacksize_base
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize_base,
- "pthread_attr_setstacksize");
-
- begin
- if pthread_attr_setstacksize_base (attr, stacksize) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_attr_setstacksize;
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int
- is
- function pthread_create_base
- (thread : access pthread_t;
- attributes : pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create_base, "pthread_create");
-
- begin
- if pthread_create_base
- (thread, attributes.all, start_routine, arg) /= 0
- then
- return errno;
- else
- return 0;
- end if;
- end pthread_create;
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int
- is
- function pthread_setspecific_base
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific_base, "pthread_setspecific");
-
- begin
- if pthread_setspecific_base (key, value) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_setspecific;
-
- function pthread_getspecific (key : pthread_key_t) return System.Address is
- function pthread_getspecific_base
- (key : pthread_key_t;
- value : access System.Address) return int;
- pragma Import (C, pthread_getspecific_base, "pthread_getspecific");
- Addr : aliased System.Address;
-
- begin
- if pthread_getspecific_base (key, Addr'Access) /= 0 then
- return System.Null_Address;
- else
- return Addr;
- end if;
- end pthread_getspecific;
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int
- is
- function pthread_keycreate
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_keycreate, "pthread_keycreate");
-
- begin
- if pthread_keycreate (key, destructor) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_key_create;
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- function intr_attach (sig : int; handler : isr_address) return long is
- function c_signal (sig : int; handler : isr_address) return long;
- pragma Import (C, c_signal, "signal");
- begin
- return c_signal (sig, handler);
- end intr_attach;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1991-1994, Florida State University --
--- Copyright (C) 1995-2012, 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 --
--- <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 HP-UX version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lcma");
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIME : constant := 52;
- ETIMEDOUT : constant := 238;
-
- FUNC_ERR : constant := -1;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 44;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
- SIGCLD : constant := 18; -- alias for SIGCHLD
- SIGCHLD : constant := 18; -- child status change
- SIGPWR : constant := 19; -- power-fail restart
- SIGVTALRM : constant := 20; -- virtual timer alarm
- SIGPROF : constant := 21; -- profiling timer alarm
- SIGIO : constant := 22; -- asynchronous I/O
- SIGPOLL : constant := 22; -- pollable event occurred
- SIGWINCH : constant := 23; -- window size change
- SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 25; -- user stop requested from tty
- SIGCONT : constant := 26; -- stopped process has been continued
- SIGTTIN : constant := 27; -- background tty read attempted
- SIGTTOU : constant := 28; -- background tty write attempted
- SIGURG : constant := 29; -- urgent condition on IO channel
- SIGLOST : constant := 30; -- remote lock lost (NFS)
- SIGDIL : constant := 32; -- DIL signal
- SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit)
- SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit)
-
- SIGADAABORT : constant := SIGABRT;
- -- Note: on other targets, we usually use SIGABRT, but on HP/UX, it
- -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set :=
- (SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP);
-
- Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
-
- type sigset_t is private;
-
- type isr_address is access procedure (sig : int);
- pragma Convention (C, isr_address);
-
- function intr_attach (sig : int; handler : isr_address) return long;
-
- Intr_Attach_Reset : constant Boolean := True;
- -- True if intr_attach is reset after an interrupt handler is called
-
- 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 Signal_Handler is access procedure (signo : Signal);
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SA_RESTART : constant := 16#40#;
- SA_SIGINFO : constant := 16#10#;
- SA_ONSTACK : constant := 16#01#;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
- SIG_ERR : constant := -1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- type timespec is private;
-
- function nanosleep (rqtp, rmtp : access timespec) return int;
- pragma Import (C, nanosleep);
-
- type clockid_t is new int;
-
- function Clock_Gettime
- (Clock_Id : clockid_t; Tp : access timespec) return int;
- pragma Import (C, Clock_Gettime);
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 0;
- SCHED_RR : constant := 1;
- SCHED_OTHER : constant := 2;
-
- -------------
- -- 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 private;
- subtype Thread_Id is 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;
-
- -- Read/Write lock not supported on HPUX. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- subtype pthread_rwlock_t is pthread_mutex_t;
- subtype pthread_rwlockattr_t is pthread_mutexattr_t;
-
- -----------
- -- Stack --
- -----------
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- This is a dummy procedure to share some GNULLI files
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
- pragma Inline (pthread_init);
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t) return int;
- pragma Import (C, sigwait, "cma_sigwait");
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Inline (sigwait);
- -- DCE_THREADS has a nonstandard sigwait
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Inline (pthread_kill);
- -- DCE_THREADS doesn't have pthread_kill
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- -- DCE THREADS does not have pthread_sigmask. Instead, it uses sigprocmask
- -- to do the signal handling when the thread library is sucked in.
- pragma Import (C, pthread_sigmask, "sigprocmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- -- DCE_THREADS has a nonstandard pthread_mutexattr_init
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- -- DCE_THREADS has a nonstandard pthread_mutexattr_destroy
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- -- DCE_THREADS has a nonstandard pthread_mutex_init
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- -- DCE_THREADS has a nonstandard pthread_mutex_destroy
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Inline (pthread_mutex_lock);
- -- DCE_THREADS has nonstandard pthread_mutex_lock
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Inline (pthread_mutex_unlock);
- -- DCE_THREADS has nonstandard pthread_mutex_lock
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- -- DCE_THREADS has nonstandard pthread_condattr_init
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- -- DCE_THREADS has nonstandard pthread_condattr_destroy
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- -- DCE_THREADS has nonstandard pthread_cond_init
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- -- DCE_THREADS has nonstandard pthread_cond_destroy
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Inline (pthread_cond_signal);
- -- DCE_THREADS has nonstandard pthread_cond_signal
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Inline (pthread_cond_wait);
- -- DCE_THREADS has a nonstandard pthread_cond_wait
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Inline (pthread_cond_timedwait);
- -- DCE_THREADS has a nonstandard pthread_cond_timedwait
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- end record;
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Inline (pthread_setschedparam);
- -- DCE_THREADS has a nonstandard pthread_setschedparam
-
- function sched_yield return int;
- pragma Inline (sched_yield);
- -- DCE_THREADS has a nonstandard sched_yield
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init (attributes : access pthread_attr_t) return int;
- pragma Inline (pthread_attr_init);
- -- DCE_THREADS has a nonstandard pthread_attr_init
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Inline (pthread_attr_destroy);
- -- DCE_THREADS has a nonstandard pthread_attr_destroy
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Inline (pthread_attr_setstacksize);
- -- DCE_THREADS has a nonstandard 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 Inline (pthread_create);
- -- DCE_THREADS has a nonstandard pthread_create
-
- procedure pthread_detach (thread : access pthread_t);
- pragma Import (C, pthread_detach);
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Inline (pthread_setspecific);
- -- DCE_THREADS has a nonstandard pthread_setspecific
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Inline (pthread_getspecific);
- -- DCE_THREADS has a nonstandard 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 Inline (pthread_key_create);
- -- DCE_THREADS has a nonstandard pthread_key_create
-
-private
-
- type array_type_1 is array (Integer range 0 .. 7) of unsigned_long;
- type sigset_t is record
- X_X_sigbits : array_type_1;
- end record;
- pragma Convention (C, sigset_t);
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- CLOCK_REALTIME : constant clockid_t := 1;
-
- type cma_t_address is new System.Address;
-
- type cma_t_handle is record
- field1 : cma_t_address;
- field2 : Short_Integer;
- field3 : Short_Integer;
- end record;
- for cma_t_handle'Size use 64;
-
- type pthread_attr_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_attr_t);
-
- type pthread_condattr_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_condattr_t);
-
- type pthread_mutexattr_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_mutexattr_t);
-
- type pthread_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_t);
-
- type pthread_mutex_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_mutex_t);
-
- type pthread_cond_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_cond_t);
-
- type pthread_key_t is new int;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1991-2017, Florida State University --
--- 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 --
--- <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 a HPUX 11.0 (Native THREADS) version of this package
-
--- This package encapsulates all direct interfaces to OS services that are
--- needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lpthread");
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIMEDOUT : constant := 238;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 44;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
- SIGCLD : constant := 18; -- alias for SIGCHLD
- SIGCHLD : constant := 18; -- child status change
- SIGPWR : constant := 19; -- power-fail restart
- SIGVTALRM : constant := 20; -- virtual timer alarm
- SIGPROF : constant := 21; -- profiling timer alarm
- SIGIO : constant := 22; -- asynchronous I/O
- SIGPOLL : constant := 22; -- pollable event occurred
- SIGWINCH : constant := 23; -- window size change
- SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 25; -- user stop requested from tty
- SIGCONT : constant := 26; -- stopped process has been continued
- SIGTTIN : constant := 27; -- background tty read attempted
- SIGTTOU : constant := 28; -- background tty write attempted
- SIGURG : constant := 29; -- urgent condition on IO channel
- SIGLOST : constant := 30; -- remote lock lost (NFS)
- SIGDIL : constant := 32; -- DIL signal
- SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit)
- SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit)
- SIGCANCEL : constant := 35; -- used for pthread cancellation.
- SIGGFAULT : constant := 36; -- Graphics framebuffer fault
-
- SIGADAABORT : constant := SIGABRT;
- -- Note: on other targets, we usually use SIGABRT, but on HPUX, it
- -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM.
- -- Do we use SIGTERM or SIGABRT???
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set :=
- (SIGABRT, SIGPIPE, SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF,
- SIGALRM, SIGVTALRM, SIGIO, SIGCHLD);
-
- Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SA_SIGINFO : constant := 16#10#;
- SA_ONSTACK : constant := 16#01#;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- 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);
-
- type struct_timezone is record
- tz_minuteswest : int;
- tz_dsttime : int;
- end record;
- pragma Convention (C, struct_timezone);
- type struct_timezone_ptr is access all struct_timezone;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 0;
- SCHED_RR : constant := 1;
- SCHED_OTHER : constant := 2;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- pragma Import (C, lwp_self, "_lwp_self");
-
- -------------
- -- 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 private;
- subtype Thread_Id is 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 := 16#de#;
-
- PTHREAD_SCOPE_PROCESS : constant := 2;
- PTHREAD_SCOPE_SYSTEM : constant := 1;
-
- -- Read/Write lock not supported on HPUX. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- 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;
- pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
- -- The alternate signal stack for stack overflows
-
- Alternate_Stack_Size : constant := 128 * 1024;
- -- 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 Address;
- pragma Inline (Get_Stack_Base);
- -- Returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- 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;
- pragma Inline (pthread_init);
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 16#100#;
- PTHREAD_PRIO_PROTECT : constant := 16#200#;
- PTHREAD_PRIO_INHERIT : constant := 16#400#;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol);
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import (C, pthread_mutexattr_setprioceiling);
-
- type Array_7_Int is array (0 .. 6) of int;
- type struct_sched_param is record
- sched_priority : int;
- sched_reserved : Array_7_Int;
- end record;
-
- 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;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import (C, pthread_attr_setinheritsched);
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, 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_system");
-
- 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);
-
- 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_system");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
-private
-
- type unsigned_int_array_8 is array (0 .. 7) of unsigned;
- type sigset_t is record
- sigset : unsigned_int_array_8;
- end record;
- pragma Convention (C_Pass_By_Copy, sigset_t);
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type pthread_attr_t is new int;
- type pthread_condattr_t is new int;
- type pthread_mutexattr_t is new int;
- type pthread_t is new int;
-
- type short_array is array (Natural range <>) of short;
- type int_array is array (Natural range <>) of int;
-
- type pthread_mutex_t is record
- m_short : short_array (0 .. 1);
- m_int : int;
- m_int1 : int_array (0 .. 3);
- m_pad : int;
-
- m_ptr : int;
- -- actually m_ptr is a void*, and on 32 bit ABI, m_pad is added so that
- -- this field takes 64 bits. On 64 bit ABI, m_pad is gone, and m_ptr is
- -- a 64 bit void*. Assume int'Size = 32.
-
- m_int2 : int_array (0 .. 1);
- m_int3 : int_array (0 .. 3);
- m_short2 : short_array (0 .. 1);
- m_int4 : int_array (0 .. 4);
- m_int5 : int_array (0 .. 1);
- end record;
- for pthread_mutex_t'Alignment use System.Address'Alignment;
- pragma Convention (C, pthread_mutex_t);
-
- type pthread_cond_t is record
- c_short : short_array (0 .. 1);
- c_int : int;
- c_int1 : int_array (0 .. 3);
- m_pad : int;
- m_ptr : int; -- see comment in pthread_mutex_t
- c_int2 : int_array (0 .. 1);
- c_int3 : int_array (0 .. 1);
- c_int4 : int_array (0 .. 1);
- end record;
- for pthread_cond_t'Alignment use System.Address'Alignment;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_key_t is new int;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2016, 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 --
--- <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 GNU/kFreeBSD (POSIX Threads) version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package
-
-with Interfaces.C;
-with Unchecked_Conversion;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lpthread");
-
- subtype int is Interfaces.C.int;
- subtype char is Interfaces.C.char;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 35;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- EPERM : constant := 1;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 128;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD)
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set := (
- SIGTRAP,
- -- To enable debugging on multithreaded applications, mark SIGTRAP to
- -- be kept unmasked.
-
- SIGBUS,
-
- SIGTTIN, SIGTTOU, SIGTSTP,
- -- Keep these three signals unmasked so that background processes
- -- and IO behaves as normal "C" applications
-
- SIGPROF,
- -- To avoid confusing the profiler
-
- SIGKILL, SIGSTOP,
- -- These two signals actually cannot be masked;
- -- POSIX simply won't allow it.
-
- SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG);
- -- These three signals are used by GNU/LinuxThreads starting from
- -- glibc 2.1 (future 2.2).
-
- Reserved : constant Signal_Set :=
- -- I am not sure why the following signal is reserved.
- -- I guess they are not supported by this version of GNU/kFreeBSD.
- (0 .. 0 => SIGVTALRM);
-
- 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");
-
- -- sigcontext is architecture dependent, so define it private
- type struct_sigcontext is private;
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_flags : int;
- sa_mask : sigset_t;
- end record;
- pragma Convention (C, struct_sigaction);
-
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- SA_SIGINFO : constant := 16#0040#;
- SA_ONSTACK : constant := 16#0001#;
-
- 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 (i.e SCHED_RR is supported)
-
- type timespec is private;
-
- function nanosleep (rqtp, rmtp : access timespec) return int;
- pragma Import (C, nanosleep, "nanosleep");
-
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
-
- 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_FIFO : constant := 1;
- SCHED_OTHER : constant := 2;
- SCHED_RR : constant := 3;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority.
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Unchecked_Conversion (System.Address, Thread_Body);
-
- type pthread_t is new unsigned_long;
- subtype Thread_Id is pthread_t;
-
- function To_pthread_t is new Unchecked_Conversion
- (unsigned_long, pthread_t);
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- PTHREAD_CREATE_DETACHED : constant := 1;
- PTHREAD_CREATE_JOINABLE : constant := 0;
-
- PTHREAD_SCOPE_PROCESS : constant := 0;
- PTHREAD_SCOPE_SYSTEM : constant := 2;
-
- -- Read/Write lock not supported on kfreebsd. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- 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_size : size_t;
- ss_flags : int;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- -- This is a dummy definition, never used (Alternate_Stack_Size is null)
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- 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_NONE;
- 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;
- pragma Inline (pthread_init);
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 2;
- PTHREAD_PRIO_INHERIT : constant := 1;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
-
- function pthread_mutexattr_getprotocol
- (attr : access pthread_mutexattr_t;
- protocol : access int) return int;
- pragma Import
- (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol");
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprioceiling,
- "pthread_mutexattr_setprioceiling");
-
- function pthread_mutexattr_getprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : access int) return int;
- pragma Import
- (C, pthread_mutexattr_getprioceiling,
- "pthread_mutexattr_getprioceiling");
-
- 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;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_getscope
- (attr : access pthread_attr_t;
- contentionscope : access int) return int;
- pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import
- (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
-
- function pthread_attr_getinheritsched
- (attr : access pthread_attr_t;
- inheritsched : access int) return int;
- pragma Import
- (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import
- (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy");
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "sched_yield");
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import
- (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- CPU_SETSIZE : constant := 1_024;
-
- type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
- for bit_field'Size use CPU_SETSIZE;
- pragma Pack (bit_field);
- pragma Convention (C, bit_field);
-
- type cpu_set_t is record
- bits : bit_field;
- end record;
- pragma Convention (C, cpu_set_t);
-
- function pthread_setaffinity_np
- (thread : pthread_t;
- cpusetsize : size_t;
- cpuset : access cpu_set_t) return int;
- pragma Import (C, pthread_setaffinity_np, "__gnat_pthread_setaffinity_np");
-
-private
-
- type sigset_t is array (1 .. 4) of unsigned;
-
- -- In FreeBSD the component sa_handler turns out to
- -- be one a union type, and the selector is a macro:
- -- #define sa_handler __sigaction_u._handler
- -- #define sa_sigaction __sigaction_u._sigaction
-
- -- Should we add a signal_context type here ?
- -- How could it be done independent of the CPU architecture ?
- -- sigcontext type is opaque, so it is architecturally neutral.
- -- It is always passed as an access type, so define it as an empty record
- -- since the contents are not used anywhere.
- type struct_sigcontext is null record;
- pragma Convention (C, struct_sigcontext);
-
- 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 clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 0;
-
- type pthread_attr_t is record
- detachstate : int;
- schedpolicy : int;
- schedparam : struct_sched_param;
- inheritsched : int;
- scope : int;
- guardsize : size_t;
- stackaddr_set : int;
- stackaddr : System.Address;
- stacksize : size_t;
- end record;
- pragma Convention (C, pthread_attr_t);
-
- type pthread_condattr_t is record
- dummy : int;
- end record;
- pragma Convention (C, pthread_condattr_t);
-
- type pthread_mutexattr_t is record
- mutexkind : int;
- end record;
- pragma Convention (C, pthread_mutexattr_t);
-
- type struct_pthread_fast_lock is record
- status : long;
- spinlock : int;
- end record;
- pragma Convention (C, struct_pthread_fast_lock);
-
- type pthread_mutex_t is record
- m_reserved : int;
- m_count : int;
- m_owner : System.Address;
- m_kind : int;
- m_lock : struct_pthread_fast_lock;
- end record;
- pragma Convention (C, pthread_mutex_t);
-
- type pthread_cond_t is array (0 .. 47) of unsigned_char;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_key_t is new unsigned;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1991-2017, Florida State University --
--- 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 --
--- <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 a GNU/Linux (GNU/LinuxThreads) version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-with Interfaces.C;
-with System.Linux;
-with System.OS_Constants;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lpthread");
- pragma Linker_Options ("-lrt");
- -- Needed for clock_getres with glibc versions prior to 2.17
-
- subtype int is Interfaces.C.int;
- subtype char is Interfaces.C.char;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := System.Linux.EAGAIN;
- EINTR : constant := System.Linux.EINTR;
- EINVAL : constant := System.Linux.EINVAL;
- ENOMEM : constant := System.Linux.ENOMEM;
- EPERM : constant := System.Linux.EPERM;
- ETIMEDOUT : constant := System.Linux.ETIMEDOUT;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 63;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := System.Linux.SIGHUP;
- SIGINT : constant := System.Linux.SIGINT;
- SIGQUIT : constant := System.Linux.SIGQUIT;
- SIGILL : constant := System.Linux.SIGILL;
- SIGTRAP : constant := System.Linux.SIGTRAP;
- SIGIOT : constant := System.Linux.SIGIOT;
- SIGABRT : constant := System.Linux.SIGABRT;
- SIGFPE : constant := System.Linux.SIGFPE;
- SIGKILL : constant := System.Linux.SIGKILL;
- SIGBUS : constant := System.Linux.SIGBUS;
- SIGSEGV : constant := System.Linux.SIGSEGV;
- SIGPIPE : constant := System.Linux.SIGPIPE;
- SIGALRM : constant := System.Linux.SIGALRM;
- SIGTERM : constant := System.Linux.SIGTERM;
- SIGUSR1 : constant := System.Linux.SIGUSR1;
- SIGUSR2 : constant := System.Linux.SIGUSR2;
- SIGCLD : constant := System.Linux.SIGCLD;
- SIGCHLD : constant := System.Linux.SIGCHLD;
- SIGPWR : constant := System.Linux.SIGPWR;
- SIGWINCH : constant := System.Linux.SIGWINCH;
- SIGURG : constant := System.Linux.SIGURG;
- SIGPOLL : constant := System.Linux.SIGPOLL;
- SIGIO : constant := System.Linux.SIGIO;
- SIGLOST : constant := System.Linux.SIGLOST;
- SIGSTOP : constant := System.Linux.SIGSTOP;
- SIGTSTP : constant := System.Linux.SIGTSTP;
- SIGCONT : constant := System.Linux.SIGCONT;
- SIGTTIN : constant := System.Linux.SIGTTIN;
- SIGTTOU : constant := System.Linux.SIGTTOU;
- SIGVTALRM : constant := System.Linux.SIGVTALRM;
- SIGPROF : constant := System.Linux.SIGPROF;
- SIGXCPU : constant := System.Linux.SIGXCPU;
- SIGXFSZ : constant := System.Linux.SIGXFSZ;
- SIGUNUSED : constant := System.Linux.SIGUNUSED;
- SIGSTKFLT : constant := System.Linux.SIGSTKFLT;
- SIGLTHRRES : constant := System.Linux.SIGLTHRRES;
- SIGLTHRCAN : constant := System.Linux.SIGLTHRCAN;
- SIGLTHRDBG : constant := System.Linux.SIGLTHRDBG;
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this 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)
-
- SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG);
- -- These three signals are used by GNU/LinuxThreads starting from glibc
- -- 2.1 (future 2.2).
-
- Reserved : constant Signal_Set := (SIGVTALRM, SIGUNUSED);
- -- Not clear why these two signals are reserved. Perhaps they are not
- -- supported by this version of GNU/Linux ???
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type union_type_3 is new String (1 .. 116);
- type siginfo_t is record
- si_signo : int;
- si_code : int;
- si_errno : int;
- X_data : union_type_3;
- end record;
- pragma Convention (C, siginfo_t);
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- sa_restorer : System.Address;
- end record;
- pragma Convention (C, struct_sigaction);
-
- type struct_sigaction_ptr is access all struct_sigaction;
-
- type Machine_State is record
- eip : unsigned_long;
- ebx : unsigned_long;
- esp : unsigned_long;
- ebp : unsigned_long;
- esi : unsigned_long;
- edi : unsigned_long;
- end record;
- type Machine_State_Ptr is access all Machine_State;
-
- SA_SIGINFO : constant := System.Linux.SA_SIGINFO;
- SA_ONSTACK : constant := System.Linux.SA_ONSTACK;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- subtype time_t is System.Linux.time_t;
- subtype timespec is System.Linux.timespec;
- subtype timeval is System.Linux.timeval;
- subtype clockid_t is System.Linux.clockid_t;
-
- 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;
- -- 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");
-
- PR_SET_NAME : constant := 15;
- PR_GET_NAME : constant := 16;
-
- function prctl
- (option : int;
- arg2, arg3, arg4, arg5 : unsigned_long := 0) return int;
- pragma Import (C, prctl);
-
- -------------
- -- 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_rwlock_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_rwlockattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- PTHREAD_CREATE_DETACHED : constant := 1;
-
- -----------
- -- Stack --
- -----------
-
- type stack_t is record
- ss_sp : System.Address;
- ss_flags : int;
- ss_size : size_t;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
- -- The alternate signal stack for stack overflows
-
- Alternate_Stack_Size : constant := 16 * 1024;
- -- This must be in keeping with init.c:__gnat_alternate_stack
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- This is a dummy procedure to share some GNULLI files
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
- pragma Inline (pthread_init);
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_rwlockattr_init
- (attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init");
-
- function pthread_rwlockattr_destroy
- (attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy");
-
- PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0;
- PTHREAD_RWLOCK_PREFER_WRITER_NP : constant := 1;
- PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 2;
-
- function pthread_rwlockattr_setkind_np
- (attr : access pthread_rwlockattr_t;
- pref : int) return int;
- pragma Import
- (C, pthread_rwlockattr_setkind_np, "pthread_rwlockattr_setkind_np");
-
- function pthread_rwlock_init
- (mutex : access pthread_rwlock_t;
- attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init");
-
- function pthread_rwlock_destroy
- (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy");
-
- function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock");
-
- function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock");
-
- function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_INHERIT : constant := 1;
- PTHREAD_PRIO_PROTECT : constant := 2;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol);
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import (C, pthread_mutexattr_setprioceiling);
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- end record;
- pragma Convention (C, struct_sched_param);
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import
- (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy");
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "sched_yield");
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import
- (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- function lwp_self return System.Address;
- pragma Import (C, lwp_self, "__gnat_lwp_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");
-
- ----------------
- -- Extensions --
- ----------------
-
- 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
-
- function pthread_setaffinity_np
- (thread : pthread_t;
- cpusetsize : size_t;
- cpuset : cpu_set_t_ptr) return int;
- pragma Import (C, pthread_setaffinity_np, "pthread_setaffinity_np");
- pragma Weak_External (pthread_setaffinity_np);
- -- Use a weak symbol because this function may be available or not,
- -- depending on the version of the system.
-
- function pthread_attr_setaffinity_np
- (attr : access pthread_attr_t;
- cpusetsize : size_t;
- cpuset : cpu_set_t_ptr) return int;
- pragma Import (C, pthread_attr_setaffinity_np,
- "pthread_attr_setaffinity_np");
- pragma Weak_External (pthread_attr_setaffinity_np);
- -- Use a weak symbol because this function may be available or not,
- -- depending on the version of the system.
-
-private
-
- type sigset_t is
- array (0 .. OS_Constants.SIZEOF_sigset - 1) of unsigned_char;
- pragma Convention (C, sigset_t);
- for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
- pragma Warnings (Off);
- for struct_sigaction use record
- sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1;
- sa_mask at Linux.sa_mask_pos range 0 .. 1023;
- sa_flags at Linux.sa_flags_pos range 0 .. int'Size - 1;
- end record;
- -- We intentionally leave sa_restorer unspecified and let the compiler
- -- append it after the last field, so disable corresponding warning.
- pragma Warnings (On);
-
- type pid_t is new int;
-
- 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_rwlockattr_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCKATTR_SIZE);
- end record;
- pragma Convention (C, pthread_rwlockattr_t);
- for pthread_rwlockattr_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
- type pthread_rwlock_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCK_SIZE);
- end record;
- pragma Convention (C, pthread_rwlock_t);
- for pthread_rwlock_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 Interfaces.Unsigned_64'Alignment;
-
- type pthread_key_t is new unsigned;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-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- --
--- 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. --
--- --
-------------------------------------------------------------------------------
-
--- Version of System.OS_Interface for LynxOS-178 (POSIX Threads)
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It may cause infinite loops and other problems.
-
-package body System.OS_Interface is
-
- use Interfaces.C;
-
- ------------------
- -- Current_CPU --
- ------------------
-
- function Current_CPU return Multiprocessors.CPU is
- begin
- -- No multiprocessor support, always return the first CPU Id
-
- return Multiprocessors.CPU'First;
- end Current_CPU;
-
- --------------------
- -- Get_Affinity --
- --------------------
-
- function Get_Affinity (Id : Thread_Id) return Multiprocessors.CPU_Range is
- pragma Unreferenced (Id);
-
- begin
- -- No multiprocessor support, always return Not_A_Specific_CPU
-
- return Multiprocessors.Not_A_Specific_CPU;
- end Get_Affinity;
-
- ---------------
- -- Get_CPU --
- ---------------
-
- function Get_CPU (Id : Thread_Id) return Multiprocessors.CPU is
- pragma Unreferenced (Id);
-
- begin
- -- No multiprocessor support, always return the first CPU Id
-
- return Multiprocessors.CPU'First;
- end Get_CPU;
-
- -------------------
- -- Get_Page_Size --
- -------------------
-
- SC_PAGESIZE : constant := 17;
- -- C macro to get pagesize value from sysconf
-
- function sysconf (name : int) return long;
- pragma Import (C, sysconf, "sysconf");
-
- function Get_Page_Size return int is
- begin
- return int (sysconf (SC_PAGESIZE));
- end Get_Page_Size;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F is negative due to a round-up, adjust for positive F value
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- -------------
- -- sigwait --
- -------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal)
- return int
- is
- function sigwaitinfo
- (set : access sigset_t;
- info : System.Address) return Signal;
- pragma Import (C, sigwaitinfo, "sigwaitinfo");
-
- begin
- sig.all := sigwaitinfo (set, Null_Address);
-
- if sig.all = -1 then
- return errno;
- end if;
-
- return 0;
- end sigwait;
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1991-1994, Florida State University --
--- 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 --
--- <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 a LynxOS-178 Elf (POSIX-8 Threads) 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.Multiprocessors;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-mthreads");
- -- Selects the POSIX 1.c runtime, rather than the non-threading runtime or
- -- the deprecated legacy threads library.
-
- subtype int is Interfaces.C.int;
- 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;
- subtype int64 is Interfaces.Integer_64;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIMEDOUT : constant := 60;
- -- Error codes
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 63;
- -- Max_Interrupt is the number of OS signals, as defined in:
- --
- -- /usr/include/sys/signal.h
- --
- -- The lowest numbered signal is 1, but 0 is a valid argument to some
- -- library functions, e.g. kill(2). However, 0 is not just another signal:
- -- For instance 'I in Signal' and similar should be used with caution.
-
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGBRK : constant := 6; -- break
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in future
- SIGCORE : constant := 7; -- kill with core dump
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGPOLL : constant := 23; -- pollable event occurred
- SIGTHREADKILL : constant := 24; -- Reserved by LynxOS runtime
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGLOST : constant := 29; -- SUN 4.1 compatibility
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGPRIO : constant := 32;
- -- Sent to a process with its priority or group is changed
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort. SIGTERM
- -- might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set :=
- (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGTHREADKILL);
- Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO);
-
- 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 struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SA_SIGINFO : constant := 16#80#;
-
- SA_ONSTACK : constant := 16#00#;
- -- SA_ONSTACK is not defined on LynxOS, but it is referred to in the POSIX
- -- implementation of System.Interrupt_Management. Therefore we define a
- -- dummy value of zero here so that setting this flag is a nop.
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- 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);
-
- type struct_timezone is record
- tz_minuteswest : int;
- tz_dsttime : int;
- end record;
- pragma Convention (C, struct_timezone);
- type struct_timezone_ptr is access all struct_timezone;
-
- type struct_timeval is private;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_RR : constant := 16#100_000#;
- SCHED_FIFO : constant := 16#200_000#;
- SCHED_OTHER : constant := 16#400_000#;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- type pthread_t is private;
-
- function lwp_self return pthread_t;
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- 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);
-
- subtype Thread_Id is 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_CREATE_JOINABLE : constant := 0;
-
- PTHREAD_SCOPE_PROCESS : constant := 0; -- not supported by LynxOS178
- PTHREAD_SCOPE_SYSTEM : constant := 1;
-
- -- Read/Write lock not supported on LynxOS. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- 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");
- -- Neither stack_t nor sigaltstack are available on LynxOS-178
-
- Alternate_Stack : aliased System.Address;
- -- This is a dummy definition, never used (Alternate_Stack_Size is 0)
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- Returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- function Get_Page_Size return int;
- -- Returns the size of a page in bytes
-
- PROT_NONE : constant := 1;
- PROT_READ : constant := 2;
- PROT_WRITE : constant := 4;
- PROT_EXEC : constant := 8;
- 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;
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Inline (sigwait);
- -- LynxOS has non standard sigwait
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- ----------------------------
- -- POSIX.1c Section 11 --
- ----------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_INHERIT : constant := 1;
- PTHREAD_PRIO_PROTECT : constant := 2;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol);
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import (C, pthread_mutexattr_setprioceiling);
-
- type struct_sched_param is record
- sched_priority : int;
- 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;
- contentionscope : int) return int is (0);
- -- pthread_attr_setscope is not implemented in production mode
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import (C, pthread_attr_setinheritsched);
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, 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);
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize);
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific
- (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer
- ) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- ---------------------
- -- Multiprocessors --
- ---------------------
-
- function Current_CPU return Multiprocessors.CPU;
- -- Return the id of the current CPU
-
- function Get_Affinity (Id : Thread_Id) return Multiprocessors.CPU_Range;
- -- Return CPU affinity of the given thread (maybe Not_A_Specific_CPU)
-
- function Get_CPU (Id : Thread_Id) return Multiprocessors.CPU;
- -- Return the CPU in charge of the given thread (always a valid CPU)
-
-private
-
- type sigset_t is array (1 .. 2) of long;
- pragma Convention (C, sigset_t);
-
- type pid_t is new long;
-
- type time_t is new int64;
-
- type suseconds_t is new int;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type struct_timeval is record
- tv_sec : time_t;
- tv_usec : suseconds_t;
- end record;
- pragma Convention (C, struct_timeval);
-
- type st_attr is record
- stksize : int;
- prio : int;
- inheritsched : int;
- state : int;
- sched : int;
- detachstate : int;
- guardsize : int;
- end record;
- pragma Convention (C, st_attr);
- subtype st_attr_t is st_attr;
-
- type pthread_attr_t is record
- pthread_attr_magic : unsigned;
- st : st_attr_t;
- pthread_attr_scope : int;
- end record;
- pragma Convention (C, pthread_attr_t);
-
- type pthread_condattr_t is record
- cv_magic : unsigned;
- cv_pshared : unsigned;
- end record;
- pragma Convention (C, pthread_condattr_t);
-
- type pthread_mutexattr_t is record
- m_flags : unsigned;
- m_prio_c : int;
- m_pshared : int;
- end record;
- pragma Convention (C, pthread_mutexattr_t);
-
- type tid_t is new short;
- type pthread_t is new tid_t;
-
- type block_obj_t is record
- b_head : int;
- end record;
- pragma Convention (C, block_obj_t);
-
- type pthread_mutex_t is record
- m_flags : unsigned;
- m_owner : tid_t;
- m_wait : block_obj_t;
- m_prio_c : int;
- m_oldprio : int;
- m_count : int;
- m_referenced : int;
- end record;
- pragma Convention (C, pthread_mutex_t);
- type pthread_mutex_t_ptr is access all pthread_mutex_t;
-
- type pthread_cond_t is record
- cv_magic : unsigned;
- cv_wait : block_obj_t;
- cv_mutex : pthread_mutex_t_ptr;
- cv_refcnt : int;
- end record;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_key_t is new int;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1991-2017, Florida State University --
--- 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 --
--- <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 a NT (native) version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl). For non tasking
--- oriented services consider declaring them into system-win32.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-with Interfaces.C.Strings;
-with System.Win32;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-mthreads");
-
- subtype int is Interfaces.C.int;
- subtype long is Interfaces.C.long;
-
- subtype LARGE_INTEGER is System.Win32.LARGE_INTEGER;
-
- -------------------
- -- General Types --
- -------------------
-
- subtype PSZ is Interfaces.C.Strings.chars_ptr;
-
- Null_Void : constant Win32.PVOID := System.Null_Address;
-
- -------------------------
- -- Handles for objects --
- -------------------------
-
- subtype Thread_Id is Win32.HANDLE;
-
- -----------
- -- Errno --
- -----------
-
- NO_ERROR : constant := 0;
- FUNC_ERR : constant := -1;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 31;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGINT : constant := 2; -- interrupt (Ctrl-C)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGFPE : constant := 8; -- floating point exception
- SIGSEGV : constant := 11; -- segmentation violation
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGBREAK : constant := 21; -- break (Ctrl-Break)
- SIGABRT : constant := 22; -- used by abort, replace SIGIOT in the future
-
- type sigset_t is private;
-
- type isr_address is access procedure (sig : int);
- pragma Convention (C, isr_address);
-
- function intr_attach (sig : int; handler : isr_address) return long;
- pragma Import (C, intr_attach, "signal");
-
- Intr_Attach_Reset : constant Boolean := True;
- -- True if intr_attach is reset after an interrupt handler is called
-
- procedure kill (sig : Signal);
- pragma Import (C, kill, "raise");
-
- ------------
- -- Clock --
- ------------
-
- procedure QueryPerformanceFrequency
- (lpPerformanceFreq : access LARGE_INTEGER);
- pragma Import
- (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency");
-
- -- According to the spec, on XP and later than function cannot fail,
- -- so we ignore the return value and import it as a procedure.
-
- -------------
- -- 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);
-
- procedure SwitchToThread;
- pragma Import (Stdcall, SwitchToThread, "SwitchToThread");
-
- function GetThreadTimes
- (hThread : Win32.HANDLE;
- lpCreationTime : access Long_Long_Integer;
- lpExitTime : access Long_Long_Integer;
- lpKernelTime : access Long_Long_Integer;
- lpUserTime : access Long_Long_Integer) return Win32.BOOL;
- pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes");
-
- -----------------------
- -- Critical sections --
- -----------------------
-
- type CRITICAL_SECTION is private;
-
- -------------------------------------------------------------
- -- Thread Creation, Activation, Suspension And Termination --
- -------------------------------------------------------------
-
- type PTHREAD_START_ROUTINE is access function
- (pThreadParameter : Win32.PVOID) return Win32.DWORD;
- pragma Convention (Stdcall, PTHREAD_START_ROUTINE);
-
- function To_PTHREAD_START_ROUTINE is new
- Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);
-
- function CreateThread
- (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
- dwStackSize : Win32.DWORD;
- pStartAddress : PTHREAD_START_ROUTINE;
- pParameter : Win32.PVOID;
- dwCreationFlags : Win32.DWORD;
- pThreadId : access Win32.DWORD) return Win32.HANDLE;
- pragma Import (Stdcall, CreateThread, "CreateThread");
-
- function BeginThreadEx
- (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
- dwStackSize : Win32.DWORD;
- pStartAddress : PTHREAD_START_ROUTINE;
- pParameter : Win32.PVOID;
- dwCreationFlags : Win32.DWORD;
- pThreadId : not null access Win32.DWORD) return Win32.HANDLE;
- pragma Import (C, BeginThreadEx, "_beginthreadex");
-
- Debug_Process : constant := 16#00000001#;
- Debug_Only_This_Process : constant := 16#00000002#;
- Create_Suspended : constant := 16#00000004#;
- Detached_Process : constant := 16#00000008#;
- Create_New_Console : constant := 16#00000010#;
-
- Create_New_Process_Group : constant := 16#00000200#;
-
- Create_No_window : constant := 16#08000000#;
-
- Profile_User : constant := 16#10000000#;
- Profile_Kernel : constant := 16#20000000#;
- Profile_Server : constant := 16#40000000#;
-
- Stack_Size_Param_Is_A_Reservation : constant := 16#00010000#;
-
- function GetExitCodeThread
- (hThread : Win32.HANDLE;
- pExitCode : not null access Win32.DWORD) return Win32.BOOL;
- pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread");
-
- function ResumeThread (hThread : Win32.HANDLE) return Win32.DWORD;
- pragma Import (Stdcall, ResumeThread, "ResumeThread");
-
- function SuspendThread (hThread : Win32.HANDLE) return Win32.DWORD;
- pragma Import (Stdcall, SuspendThread, "SuspendThread");
-
- procedure ExitThread (dwExitCode : Win32.DWORD);
- pragma Import (Stdcall, ExitThread, "ExitThread");
-
- procedure EndThreadEx (dwExitCode : Win32.DWORD);
- pragma Import (C, EndThreadEx, "_endthreadex");
-
- function TerminateThread
- (hThread : Win32.HANDLE;
- dwExitCode : Win32.DWORD) return Win32.BOOL;
- pragma Import (Stdcall, TerminateThread, "TerminateThread");
-
- function GetCurrentThread return Win32.HANDLE;
- pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread");
-
- function GetCurrentProcess return Win32.HANDLE;
- pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess");
-
- function GetCurrentThreadId return Win32.DWORD;
- pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId");
-
- function TlsAlloc return Win32.DWORD;
- pragma Import (Stdcall, TlsAlloc, "TlsAlloc");
-
- function TlsGetValue (dwTlsIndex : Win32.DWORD) return Win32.PVOID;
- pragma Import (Stdcall, TlsGetValue, "TlsGetValue");
-
- function TlsSetValue
- (dwTlsIndex : Win32.DWORD; pTlsValue : Win32.PVOID) return Win32.BOOL;
- pragma Import (Stdcall, TlsSetValue, "TlsSetValue");
-
- function TlsFree (dwTlsIndex : Win32.DWORD) return Win32.BOOL;
- pragma Import (Stdcall, TlsFree, "TlsFree");
-
- TLS_Nothing : constant := Win32.DWORD'Last;
-
- procedure ExitProcess (uExitCode : Interfaces.C.unsigned);
- pragma Import (Stdcall, ExitProcess, "ExitProcess");
-
- function WaitForSingleObject
- (hHandle : Win32.HANDLE;
- dwMilliseconds : Win32.DWORD) return Win32.DWORD;
- pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject");
-
- function WaitForSingleObjectEx
- (hHandle : Win32.HANDLE;
- dwMilliseconds : Win32.DWORD;
- fAlertable : Win32.BOOL) return Win32.DWORD;
- pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx");
-
- Wait_Infinite : constant := Win32.DWORD'Last;
- WAIT_TIMEOUT : constant := 16#0000_0102#;
- WAIT_FAILED : constant := 16#FFFF_FFFF#;
-
- ------------------------------------
- -- Semaphores, Events and Mutexes --
- ------------------------------------
-
- function CreateSemaphore
- (pSemaphoreAttributes : access Win32.SECURITY_ATTRIBUTES;
- lInitialCount : Interfaces.C.long;
- lMaximumCount : Interfaces.C.long;
- pName : PSZ) return Win32.HANDLE;
- pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA");
-
- function OpenSemaphore
- (dwDesiredAccess : Win32.DWORD;
- bInheritHandle : Win32.BOOL;
- pName : PSZ) return Win32.HANDLE;
- pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA");
-
- function ReleaseSemaphore
- (hSemaphore : Win32.HANDLE;
- lReleaseCount : Interfaces.C.long;
- pPreviousCount : access Win32.LONG) return Win32.BOOL;
- pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore");
-
- function CreateEvent
- (pEventAttributes : access Win32.SECURITY_ATTRIBUTES;
- bManualReset : Win32.BOOL;
- bInitialState : Win32.BOOL;
- pName : PSZ) return Win32.HANDLE;
- pragma Import (Stdcall, CreateEvent, "CreateEventA");
-
- function OpenEvent
- (dwDesiredAccess : Win32.DWORD;
- bInheritHandle : Win32.BOOL;
- pName : PSZ) return Win32.HANDLE;
- pragma Import (Stdcall, OpenEvent, "OpenEventA");
-
- function SetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
- pragma Import (Stdcall, SetEvent, "SetEvent");
-
- function ResetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
- pragma Import (Stdcall, ResetEvent, "ResetEvent");
-
- function PulseEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
- pragma Import (Stdcall, PulseEvent, "PulseEvent");
-
- function CreateMutex
- (pMutexAttributes : access Win32.SECURITY_ATTRIBUTES;
- bInitialOwner : Win32.BOOL;
- pName : PSZ) return Win32.HANDLE;
- pragma Import (Stdcall, CreateMutex, "CreateMutexA");
-
- function OpenMutex
- (dwDesiredAccess : Win32.DWORD;
- bInheritHandle : Win32.BOOL;
- pName : PSZ) return Win32.HANDLE;
- pragma Import (Stdcall, OpenMutex, "OpenMutexA");
-
- function ReleaseMutex (hMutex : Win32.HANDLE) return Win32.BOOL;
- pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex");
-
- ---------------------------------------------------
- -- Accessing properties of Threads and Processes --
- ---------------------------------------------------
-
- -----------------
- -- Priorities --
- -----------------
-
- function SetThreadPriority
- (hThread : Win32.HANDLE;
- nPriority : Interfaces.C.int) return Win32.BOOL;
- pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority");
-
- function GetThreadPriority (hThread : Win32.HANDLE) return Interfaces.C.int;
- pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority");
-
- function SetPriorityClass
- (hProcess : Win32.HANDLE;
- dwPriorityClass : Win32.DWORD) return Win32.BOOL;
- pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass");
-
- procedure SetThreadPriorityBoost
- (hThread : Win32.HANDLE;
- DisablePriorityBoost : Win32.BOOL);
- pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost");
-
- Normal_Priority_Class : constant := 16#00000020#;
- Idle_Priority_Class : constant := 16#00000040#;
- High_Priority_Class : constant := 16#00000080#;
- Realtime_Priority_Class : constant := 16#00000100#;
-
- Thread_Priority_Idle : constant := -15;
- Thread_Priority_Lowest : constant := -2;
- Thread_Priority_Below_Normal : constant := -1;
- Thread_Priority_Normal : constant := 0;
- Thread_Priority_Above_Normal : constant := 1;
- Thread_Priority_Highest : constant := 2;
- Thread_Priority_Time_Critical : constant := 15;
- Thread_Priority_Error_Return : constant := Interfaces.C.long'Last;
-
-private
-
- type sigset_t is new Interfaces.C.unsigned_long;
-
- type CRITICAL_SECTION is record
- DebugInfo : System.Address;
-
- LockCount : Long_Integer;
- RecursionCount : Long_Integer;
- OwningThread : Win32.HANDLE;
- -- The above three fields control entering and exiting the critical
- -- section for the resource.
-
- LockSemaphore : Win32.HANDLE;
- SpinCount : Win32.DWORD;
- end record;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-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- --
--- 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 version is for POSIX-like operating systems
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-with Interfaces.C; use Interfaces.C;
-package body System.OS_Interface is
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
-
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-2009 Florida State University --
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
--- --
--- The GNARL files that were developed for RTEMS are maintained by On-Line --
--- Applications Research Corporation (http://www.oarcorp.com) in coopera- --
--- tion with Ada Core Technologies Inc. and Florida State University. --
--- --
-------------------------------------------------------------------------------
-
--- This is the RTEMS version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-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 Interfaces.C; use Interfaces.C;
-package body System.OS_Interface is
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to round-up, adjust for positive F value
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
-
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- -----------------
- -- sigaltstack --
- -----------------
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int is
- pragma Unreferenced (ss);
- pragma Unreferenced (oss);
- begin
- return 0;
- end sigaltstack;
-
- -----------------------------------
- -- pthread_rwlockattr_setkind_np --
- -----------------------------------
-
- function pthread_rwlockattr_setkind_np
- (attr : access pthread_rwlockattr_t;
- pref : int) return int is
- pragma Unreferenced (attr);
- pragma Unreferenced (pref);
- begin
- return 0;
- end pthread_rwlockattr_setkind_np;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1997-2016 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. --
--- --
--- The GNARL files that were developed for RTEMS are maintained by On-Line --
--- Applications Research Corporation (http://www.oarcorp.com) in coopera- --
--- tion with Ada Core Technologies Inc. and Florida State University. --
--- --
-------------------------------------------------------------------------------
-
--- This is the RTEMS version of this package.
---
--- RTEMS target names are of the form CPU-rtems.
--- This implementation is designed to work on ALL RTEMS targets.
--- The RTEMS implementation is primarily based upon the POSIX threads
--- API but there are also bindings to GNAT/RTEMS support routines
--- to insulate this code from C API specific details and, in some
--- cases, obtain target architecture and BSP specific information
--- that is unavailable at the time this package is built.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
--- PLEASE DO NOT add any with-clauses to this package
--- or remove the pragma Preelaborate.
--- It is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-with System.OS_Constants;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- -- This interface assumes that "unsigned" is a 32-bit entity. This
- -- will correspond to RTEMS object ids.
-
- subtype rtems_id is Interfaces.C.unsigned;
-
- subtype int is Interfaces.C.int;
- subtype char is Interfaces.C.char;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := System.OS_Constants.EAGAIN;
- EINTR : constant := System.OS_Constants.EINTR;
- EINVAL : constant := System.OS_Constants.EINVAL;
- ENOMEM : constant := System.OS_Constants.ENOMEM;
- ETIMEDOUT : constant := System.OS_Constants.ETIMEDOUT;
-
- -------------
- -- Signals --
- -------------
-
- Num_HW_Interrupts : constant := 256;
-
- Max_HW_Interrupt : constant := Num_HW_Interrupts - 1;
- 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;
-
- SIGXCPU : constant := 0; -- XCPU
- 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
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
-
- SIGADAABORT : constant := SIGABRT;
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set := (SIGTRAP, SIGALRM, SIGEMT);
- Reserved : constant Signal_Set := (1 .. 1 => SIGKILL);
-
- 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 struct_sigaction is record
- sa_flags : int;
- sa_mask : sigset_t;
- sa_handler : System.Address;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SA_SIGINFO : constant := 16#02#;
-
- SA_ONSTACK : constant := 16#00#;
- -- SA_ONSTACK is not defined on RTEMS, but it is referred to in the POSIX
- -- implementation of System.Interrupt_Management. Therefore we define a
- -- dummy value of zero here so that setting this flag is a nop.
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- 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 (i.e SCHED_RR is supported)
-
- type timespec is private;
-
- type clockid_t is new int;
-
- CLOCK_REALTIME : constant clockid_t;
- CLOCK_MONOTONIC : constant clockid_t;
-
- 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);
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 1;
- SCHED_RR : constant := 2;
- SCHED_OTHER : constant := 0;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- type pthread_t is private;
- subtype Thread_Id is pthread_t;
-
- type pthread_mutex_t is limited private;
- type pthread_rwlock_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_rwlockattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- No_Key : constant pthread_key_t;
-
- PTHREAD_CREATE_DETACHED : constant := 0;
-
- PTHREAD_SCOPE_PROCESS : constant := 0;
- PTHREAD_SCOPE_SYSTEM : constant := 1;
-
- -----------
- -- Stack --
- -----------
-
- type stack_t is record
- ss_sp : System.Address;
- ss_flags : int;
- ss_size : size_t;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
-
- Alternate_Stack : aliased System.Address;
- -- This is a dummy definition, never used (Alternate_Stack_Size is null)
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target.
- -- This allows us to share s-osinte.adb between all the FSU/RTEMS
- -- run time.
- -- Note that this value can only be true if pthread_t has a complete
- -- definition that corresponds exactly to the C header files.
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread.
- -- Only call this function when Stack_Base_Available is True.
-
- -- These two functions are only needed to share s-taprop.adb with
- -- FSU threads.
-
- function Get_Page_Size return int;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- Returns the size of a page
-
- PROT_ON : constant := 0;
- PROT_OFF : constant := 0;
-
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- -----------------------------------------
- -- Nonstandard Thread Initialization --
- -----------------------------------------
-
- procedure pthread_init;
- -- FSU_THREADS requires pthread_init, which is nonstandard
- -- and this should be invoked during the elaboration of s-taprop.adb
- --
- -- RTEMS does not require this so we provide an empty Ada body.
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- ----------------------------
- -- POSIX.1c Section 11 --
- ----------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_rwlockattr_init
- (attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init");
-
- function pthread_rwlockattr_destroy
- (attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy");
-
- PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0;
- PTHREAD_RWLOCK_PREFER_WRITER_NP : constant := 1;
- PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 2;
-
- function pthread_rwlockattr_setkind_np
- (attr : access pthread_rwlockattr_t;
- pref : int) return int;
-
- function pthread_rwlock_init
- (mutex : access pthread_rwlock_t;
- attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init");
-
- function pthread_rwlock_destroy
- (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy");
-
- function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock");
-
- function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock");
-
- function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_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_NONE : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 2;
- PTHREAD_PRIO_INHERIT : constant := 1;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol);
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprioceiling,
- "pthread_mutexattr_setprioceiling");
-
- type struct_sched_param is record
- sched_priority : int;
- ss_low_priority : int;
- ss_replenish_period : timespec;
- ss_initial_budget : timespec;
- sched_ss_max_repl : int;
- 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;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import (C, pthread_attr_setinheritsched);
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy);
-
- function pthread_attr_setschedparam
- (attr : access pthread_attr_t;
- sched_param : int) return int;
- pragma Import (C, pthread_attr_setschedparam);
-
- 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);
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- ------------------------------------------------------------
- -- Binary Semaphore Wrapper to Support Interrupt Tasks --
- ------------------------------------------------------------
-
- 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");
-
- function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int;
- pragma Import (
- C,
- Binary_Semaphore_Delete,
- "__gnat_binary_semaphore_delete");
-
- function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int;
- pragma Import (
- C,
- Binary_Semaphore_Obtain,
- "__gnat_binary_semaphore_obtain");
-
- function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int;
- pragma Import (
- C,
- Binary_Semaphore_Release,
- "__gnat_binary_semaphore_release");
-
- function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int;
- pragma Import (
- C,
- Binary_Semaphore_Flush,
- "__gnat_binary_semaphore_flush");
-
- ------------------------------------------------------------
- -- Hardware Interrupt Wrappers to Support Interrupt Tasks --
- ------------------------------------------------------------
-
- 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");
- -- 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
-
- type sigset_t is new int;
-
- 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);
-
- CLOCK_REALTIME : constant clockid_t := System.OS_Constants.CLOCK_REALTIME;
- CLOCK_MONOTONIC : constant clockid_t := System.OS_Constants.CLOCK_MONOTONIC;
-
- 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.double'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.double'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.double'Alignment;
-
- type pthread_rwlockattr_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCKATTR_SIZE);
- end record;
- pragma Convention (C, pthread_rwlockattr_t);
- for pthread_rwlockattr_t'Alignment use Interfaces.C.double'Alignment;
-
- type pthread_t is new rtems_id;
-
- type pthread_mutex_t is new rtems_id;
-
- type pthread_rwlock_t is new rtems_id;
-
- type pthread_cond_t is new rtems_id;
-
- type pthread_key_t is new rtems_id;
-
- No_Key : constant pthread_key_t := 0;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-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- --
--- 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 a Solaris version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-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 Interfaces.C; use Interfaces.C;
-
-package body System.OS_Interface is
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1991-2017, Florida State University --
--- 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 --
--- <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 a Solaris (native) version of this package
-
--- This package includes 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 Interfaces.C;
-
-with Ada.Unchecked_Conversion;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lposix4");
- pragma Linker_Options ("-lthread");
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIME : constant := 62;
- ETIMEDOUT : constant := 145;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 45;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
- SIGCLD : constant := 18; -- alias for SIGCHLD
- SIGCHLD : constant := 18; -- child status change
- SIGPWR : constant := 19; -- power-fail restart
- 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 possible (Solaris SIGPOLL alias)
- 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
- SIGWAITING : constant := 32; -- process's lwps blocked (Solaris)
- SIGLWP : constant := 33; -- used by thread library (Solaris)
- SIGFREEZE : constant := 34; -- used by CPR (Solaris)
- SIGTHAW : constant := 35; -- used by CPR (Solaris)
- SIGCANCEL : constant := 36; -- thread cancellation signal (libthread)
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF);
-
- -- Following signals should not be disturbed.
- -- See c-posix-signals.c in FLORIST.
-
- Reserved : constant Signal_Set :=
- (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL, SIGTRAP, 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);
-
- -- The types mcontext_t and gregset_t are part of the ucontext_t
- -- information, which is specific to Solaris2.4 for SPARC
- -- The ucontext_t info seems to be used by the handler
- -- for SIGSEGV to decide whether it is a Storage_Error (stack overflow) or
- -- a Constraint_Error (bad pointer). The original code that did this
- -- is suspect, so it is not clear whether we really need this part of
- -- the signal context information, or perhaps something else.
- -- More analysis is needed, after which these declarations may need to
- -- be changed.
-
- type greg_t is new int;
-
- type gregset_t is array (0 .. 18) of greg_t;
-
- type union_type_2 is new String (1 .. 128);
- type record_type_1 is record
- fpu_fr : union_type_2;
- fpu_q : System.Address;
- fpu_fsr : unsigned;
- fpu_qcnt : unsigned_char;
- fpu_q_entrysize : unsigned_char;
- fpu_en : unsigned_char;
- end record;
- pragma Convention (C, record_type_1);
-
- type array_type_7 is array (Integer range 0 .. 20) of long;
- type mcontext_t is record
- gregs : gregset_t;
- gwins : System.Address;
- fpregs : record_type_1;
- filler : array_type_7;
- end record;
- pragma Convention (C, mcontext_t);
-
- type record_type_2 is record
- ss_sp : System.Address;
- ss_size : int;
- ss_flags : int;
- end record;
- pragma Convention (C, record_type_2);
-
- type array_type_8 is array (Integer range 0 .. 22) of long;
- type ucontext_t is record
- uc_flags : unsigned_long;
- uc_link : System.Address;
- uc_sigmask : sigset_t;
- uc_stack : record_type_2;
- uc_mcontext : mcontext_t;
- uc_filler : array_type_8;
- end record;
- pragma Convention (C, ucontext_t);
-
- type Signal_Handler is access procedure
- (signo : Signal;
- info : access siginfo_t;
- context : access ucontext_t);
-
- type union_type_1 is new plain_char;
- type array_type_2 is array (Integer range 0 .. 1) of int;
- type struct_sigaction is record
- sa_flags : int;
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_resv : array_type_2;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- type timespec is private;
-
- 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);
-
- -------------
- -- 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);
-
- THR_DETACHED : constant := 64;
- THR_BOUND : constant := 1;
- THR_NEW_LWP : constant := 2;
- USYNC_THREAD : constant := 0;
-
- type thread_t is new unsigned;
- subtype Thread_Id is thread_t;
- -- These types should be commented ???
-
- function To_thread_t is new Ada.Unchecked_Conversion (Integer, thread_t);
-
- type mutex_t is limited private;
-
- type cond_t is limited private;
-
- type thread_key_t is private;
-
- function thr_create
- (stack_base : System.Address;
- stack_size : size_t;
- start_routine : Thread_Body;
- arg : System.Address;
- flags : int;
- new_thread : access thread_t) return int;
- pragma Import (C, thr_create, "thr_create");
-
- function thr_min_stack return size_t;
- pragma Import (C, thr_min_stack, "thr_min_stack");
-
- function thr_self return thread_t;
- pragma Import (C, thr_self, "thr_self");
-
- function mutex_init
- (mutex : access mutex_t;
- mtype : int;
- arg : System.Address) return int;
- pragma Import (C, mutex_init, "mutex_init");
-
- function mutex_destroy (mutex : access mutex_t) return int;
- pragma Import (C, mutex_destroy, "mutex_destroy");
-
- function mutex_lock (mutex : access mutex_t) return int;
- pragma Import (C, mutex_lock, "mutex_lock");
-
- function mutex_unlock (mutex : access mutex_t) return int;
- pragma Import (C, mutex_unlock, "mutex_unlock");
-
- function cond_init
- (cond : access cond_t;
- ctype : int;
- arg : int) return int;
- pragma Import (C, cond_init, "cond_init");
-
- function cond_wait
- (cond : access cond_t; mutex : access mutex_t) return int;
- pragma Import (C, cond_wait, "cond_wait");
-
- function cond_timedwait
- (cond : access cond_t;
- mutex : access mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, cond_timedwait, "cond_timedwait");
-
- function cond_signal (cond : access cond_t) return int;
- pragma Import (C, cond_signal, "cond_signal");
-
- function cond_destroy (cond : access cond_t) return int;
- pragma Import (C, cond_destroy, "cond_destroy");
-
- function thr_setspecific
- (key : thread_key_t; value : System.Address) return int;
- pragma Import (C, thr_setspecific, "thr_setspecific");
-
- function thr_getspecific
- (key : thread_key_t;
- value : access System.Address) return int;
- pragma Import (C, thr_getspecific, "thr_getspecific");
-
- function thr_keycreate
- (key : access thread_key_t; destructor : System.Address) return int;
- pragma Import (C, thr_keycreate, "thr_keycreate");
-
- function thr_setprio (thread : thread_t; priority : int) return int;
- pragma Import (C, thr_setprio, "thr_setprio");
-
- procedure thr_exit (status : System.Address);
- pragma Import (C, thr_exit, "thr_exit");
-
- function thr_setconcurrency (new_level : int) return int;
- pragma Import (C, thr_setconcurrency, "thr_setconcurrency");
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "__posix_sigwait");
-
- function thr_kill (thread : thread_t; sig : Signal) return int;
- pragma Import (C, thr_kill, "thr_kill");
-
- function thr_sigsetmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, thr_sigsetmask, "thr_sigsetmask");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "thr_sigsetmask");
-
- function thr_suspend (target_thread : thread_t) return int;
- pragma Import (C, thr_suspend, "thr_suspend");
-
- function thr_continue (target_thread : thread_t) return int;
- pragma Import (C, thr_continue, "thr_continue");
-
- procedure thr_yield;
- pragma Import (C, thr_yield, "thr_yield");
-
- ---------
- -- LWP --
- ---------
-
- P_PID : constant := 0;
- P_LWPID : constant := 8;
-
- PC_GETCID : constant := 0;
- PC_GETCLINFO : constant := 1;
- PC_SETPARMS : constant := 2;
- PC_GETPARMS : constant := 3;
- PC_ADMIN : constant := 4;
-
- PC_CLNULL : constant := -1;
-
- RT_NOCHANGE : constant := -1;
- RT_TQINF : constant := -2;
- RT_TQDEF : constant := -3;
-
- PC_CLNMSZ : constant := 16;
-
- PC_VERSION : constant := 1;
-
- type lwpid_t is new int;
-
- type pri_t is new short;
-
- type id_t is new long;
-
- P_MYID : constant := -1;
- -- The specified LWP or process is the current one
-
- type struct_pcinfo is record
- pc_cid : id_t;
- pc_clname : String (1 .. PC_CLNMSZ);
- rt_maxpri : short;
- end record;
- pragma Convention (C, struct_pcinfo);
-
- type struct_pcparms is record
- pc_cid : id_t;
- rt_pri : pri_t;
- rt_tqsecs : long;
- rt_tqnsecs : long;
- end record;
- pragma Convention (C, struct_pcparms);
-
- function priocntl
- (ver : int;
- id_type : int;
- id : lwpid_t;
- cmd : int;
- arg : System.Address) return Interfaces.C.long;
- pragma Import (C, priocntl, "__priocntl");
-
- function lwp_self return lwpid_t;
- pragma Import (C, lwp_self, "_lwp_self");
-
- type processorid_t is new int;
- type processorid_t_ptr is access all processorid_t;
-
- -- Constants for function processor_bind
-
- PBIND_QUERY : constant processorid_t := -2;
- -- The processor bindings are not changed
-
- PBIND_NONE : constant processorid_t := -1;
- -- The processor bindings of the specified LWPs are cleared
-
- -- Flags for function p_online
-
- PR_OFFLINE : constant int := 1;
- -- Processor is offline, as quiet as possible
-
- PR_ONLINE : constant int := 2;
- -- Processor online
-
- PR_STATUS : constant int := 3;
- -- Value passed to p_online to request status
-
- function p_online (processorid : processorid_t; flag : int) return int;
- pragma Import (C, p_online, "p_online");
-
- function processor_bind
- (id_type : int;
- id : id_t;
- proc_id : processorid_t;
- obind : processorid_t_ptr) return int;
- pragma Import (C, processor_bind, "processor_bind");
-
- type psetid_t is new int;
-
- function pset_create (pset : access psetid_t) return int;
- pragma Import (C, pset_create, "pset_create");
-
- function pset_assign
- (pset : psetid_t;
- proc_id : processorid_t;
- opset : access psetid_t) return int;
- pragma Import (C, pset_assign, "pset_assign");
-
- function pset_bind
- (pset : psetid_t;
- id_type : int;
- id : id_t;
- opset : access psetid_t) return int;
- pragma Import (C, pset_bind, "pset_bind");
-
- procedure pthread_init;
- -- Dummy procedure to share s-intman.adb with other Solaris targets
-
-private
-
- type array_type_1 is array (0 .. 3) of unsigned_long;
- type sigset_t is record
- X_X_sigbits : array_type_1;
- end record;
- pragma Convention (C, sigset_t);
-
- type pid_t is new long;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type array_type_9 is array (0 .. 3) of unsigned_char;
- type record_type_3 is record
- flag : array_type_9;
- Xtype : unsigned_long;
- end record;
- pragma Convention (C, record_type_3);
-
- type mutex_t is record
- flags : record_type_3;
- lock : String (1 .. 8);
- data : String (1 .. 8);
- end record;
- pragma Convention (C, mutex_t);
-
- type cond_t is record
- flag : array_type_9;
- Xtype : unsigned_long;
- data : String (1 .. 8);
- end record;
- pragma Convention (C, cond_t);
-
- type thread_key_t is new unsigned;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1997-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 --
--- <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 VxWorks version
-
--- This package encapsulates all direct interfaces to OS services that are
--- needed by children of System.
-
-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.
-
-package body System.OS_Interface is
-
- use type Interfaces.C.int;
-
- Low_Priority : constant := 255;
- -- VxWorks native (default) lowest scheduling priority
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
- end To_Duration;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F is negative due to a round-up, adjust for positive F value
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(ts_sec => S,
- ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- -------------------------
- -- To_VxWorks_Priority --
- -------------------------
-
- function To_VxWorks_Priority (Priority : int) return int is
- begin
- return Low_Priority - Priority;
- end To_VxWorks_Priority;
-
- --------------------
- -- To_Clock_Ticks --
- --------------------
-
- -- ??? - For now, we'll always get the system clock rate since it is
- -- allowed to be changed during run-time in VxWorks. A better method would
- -- be to provide an operation to set it that so we can always know its
- -- value.
-
- -- Another thing we should probably allow for is a resultant tick count
- -- greater than int'Last. This should probably be a procedure with two
- -- output parameters, one in the range 0 .. int'Last, and another
- -- representing the overflow count.
-
- function To_Clock_Ticks (D : Duration) return int is
- Ticks : Long_Long_Integer;
- Rate_Duration : Duration;
- Ticks_Duration : Duration;
-
- begin
- if D < 0.0 then
- return ERROR;
- end if;
-
- -- Ensure that the duration can be converted to ticks
- -- at the current clock tick rate without overflowing.
-
- Rate_Duration := Duration (sysClkRateGet);
-
- if D > (Duration'Last / Rate_Duration) then
- Ticks := Long_Long_Integer (int'Last);
- else
- Ticks_Duration := D * Rate_Duration;
- Ticks := Long_Long_Integer (Ticks_Duration);
-
- if Ticks_Duration > Duration (Ticks) then
- Ticks := Ticks + 1;
- end if;
-
- if Ticks > Long_Long_Integer (int'Last) then
- Ticks := Long_Long_Integer (int'Last);
- end if;
- end if;
-
- return int (Ticks);
- end To_Clock_Ticks;
-
- -----------------------------
- -- Binary_Semaphore_Create --
- -----------------------------
-
- function Binary_Semaphore_Create return Binary_Semaphore_Id is
- begin
- return Binary_Semaphore_Id (semBCreate (SEM_Q_FIFO, SEM_EMPTY));
- end Binary_Semaphore_Create;
-
- -----------------------------
- -- Binary_Semaphore_Delete --
- -----------------------------
-
- function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int is
- begin
- return semDelete (SEM_ID (ID));
- end Binary_Semaphore_Delete;
-
- -----------------------------
- -- Binary_Semaphore_Obtain --
- -----------------------------
-
- function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int is
- begin
- return semTake (SEM_ID (ID), WAIT_FOREVER);
- end Binary_Semaphore_Obtain;
-
- ------------------------------
- -- Binary_Semaphore_Release --
- ------------------------------
-
- function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int is
- begin
- return semGive (SEM_ID (ID));
- end Binary_Semaphore_Release;
-
- ----------------------------
- -- Binary_Semaphore_Flush --
- ----------------------------
-
- function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int is
- begin
- return semFlush (SEM_ID (ID));
- end Binary_Semaphore_Flush;
-
- ----------
- -- kill --
- ----------
-
- function kill (pid : t_id; sig : Signal) return int is
- begin
- return System.VxWorks.Ext.kill (pid, int (sig));
- end kill;
-
- -----------------------
- -- Interrupt_Connect --
- -----------------------
-
- function Interrupt_Connect
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler;
- Parameter : System.Address := System.Null_Address) return int is
- begin
- return
- System.VxWorks.Ext.Interrupt_Connect
- (System.VxWorks.Ext.Interrupt_Vector (Vector),
- System.VxWorks.Ext.Interrupt_Handler (Handler),
- Parameter);
- end Interrupt_Connect;
-
- -----------------------
- -- Interrupt_Context --
- -----------------------
-
- function Interrupt_Context return int is
- begin
- return System.VxWorks.Ext.Interrupt_Context;
- end Interrupt_Context;
-
- --------------------------------
- -- Interrupt_Number_To_Vector --
- --------------------------------
-
- function Interrupt_Number_To_Vector
- (intNum : int) return Interrupt_Vector
- is
- begin
- return Interrupt_Vector
- (System.VxWorks.Ext.Interrupt_Number_To_Vector (intNum));
- end Interrupt_Number_To_Vector;
-
- -----------------
- -- Current_CPU --
- -----------------
-
- function Current_CPU return Multiprocessors.CPU is
- begin
- -- ??? Should use vxworks multiprocessor interface
-
- return Multiprocessors.CPU'First;
- end Current_CPU;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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) 1991-2017, Florida State University --
--- Copyright (C) 1995-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. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- 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 VxWorks 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 Interfaces.C;
-with System.VxWorks;
-with System.VxWorks.Ext;
-with System.Multiprocessors;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- subtype int is Interfaces.C.int;
- subtype unsigned is Interfaces.C.unsigned;
- subtype short is Short_Integer;
- type unsigned_int is mod 2 ** int'Size;
- type long is new Long_Integer;
- type unsigned_long is mod 2 ** long'Size;
- type long_long is new Long_Long_Integer;
- type unsigned_long_long is mod 2 ** long_long'Size;
- type size_t is mod 2 ** Standard'Address_Size;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "errnoGet");
-
- EINTR : constant := 4;
- EAGAIN : constant := 35;
- ENOMEM : constant := 12;
- EINVAL : constant := 22;
- ETIMEDOUT : constant := 60;
-
- FUNC_ERR : constant := -1;
-
- ----------------------------
- -- Signals and interrupts --
- ----------------------------
-
- 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 := System.VxWorks.Num_HW_Interrupts - 1;
- type HW_Interrupt is new int range 0 .. Max_HW_Interrupt;
-
- Max_Interrupt : constant := Max_HW_Interrupt;
- subtype Interrupt_Range is Natural range 0 .. Max_HW_Interrupt;
- -- For s-interr
-
- -- Signals common to Vxworks 5.x and 6.x
-
- SIGILL : constant := 4; -- illegal instruction (not reset when caught)
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGFPE : constant := 8; -- floating point exception
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
-
- -- Signals specific to VxWorks 6.x
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt
- SIGQUIT : constant := 3; -- quit
- SIGTRAP : constant := 5; -- trace trap (not reset when caught)
- SIGEMT : constant := 7; -- EMT instruction
- SIGKILL : constant := 9; -- kill
- SIGFMT : constant := 12; -- STACK FORMAT ERROR (not posix)
- 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
- SIGCNCL : constant := 16; -- pthreads cancellation signal
- SIGSTOP : constant := 17; -- sendable stop signal not from tty
- SIGTSTP : constant := 18; -- stop signal from tty
- SIGCONT : constant := 19; -- continue a stopped process
- SIGCHLD : constant := 20; -- to parent on child stop or exit
- SIGTTIN : constant := 21; -- to readers pgrp upon background tty read
- SIGTTOU : constant := 22; -- like TTIN for output
-
- SIGRES1 : constant := 23; -- reserved signal number (Not POSIX)
- SIGRES2 : constant := 24; -- reserved signal number (Not POSIX)
- SIGRES3 : constant := 25; -- reserved signal number (Not POSIX)
- SIGRES4 : constant := 26; -- reserved signal number (Not POSIX)
- SIGRES5 : constant := 27; -- reserved signal number (Not POSIX)
- SIGRES6 : constant := 28; -- reserved signal number (Not POSIX)
- SIGRES7 : constant := 29; -- reserved signal number (Not POSIX)
-
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGPOLL : constant := 32; -- pollable event
- SIGPROF : constant := 33; -- profiling timer expired
- SIGSYS : constant := 34; -- bad system call
- SIGURG : constant := 35; -- high bandwidth data is available at socket
- SIGVTALRM : constant := 36; -- virtual timer expired
- SIGXCPU : constant := 37; -- CPU time limit exceeded
- SIGXFSZ : constant := 38; -- file size time limit exceeded
-
- SIGEVTS : constant := 39; -- signal event thread send
- SIGEVTD : constant := 40; -- signal event thread delete
-
- SIGRTMIN : constant := 48; -- Realtime signal min
- SIGRTMAX : constant := 63; -- Realtime signal max
-
- -----------------------------------
- -- Signal processing definitions --
- -----------------------------------
-
- -- The how in sigprocmask()
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- -- The sa_flags in struct sigaction
-
- SA_SIGINFO : constant := 16#0002#;
- SA_ONSTACK : constant := 16#0004#;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- type sigset_t is private;
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- 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");
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- type isr_address is access procedure (sig : int);
- pragma Convention (C, isr_address);
-
- function c_signal (sig : Signal; handler : isr_address) return isr_address;
- pragma Import (C, c_signal, "signal");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "sigprocmask");
-
- subtype t_id is System.VxWorks.Ext.t_id;
- subtype Thread_Id is t_id;
- -- Thread_Id and t_id are VxWorks identifiers for tasks. This value,
- -- although represented as a Long_Integer, is in fact an address. With
- -- some BSPs, this address can have a value sufficiently high that the
- -- Thread_Id becomes negative: this should not be considered as an error.
-
- function kill (pid : t_id; sig : Signal) return int;
- pragma Inline (kill);
-
- function getpid return t_id renames System.VxWorks.Ext.getpid;
-
- function Task_Stop (tid : t_id) return int
- renames System.VxWorks.Ext.Task_Stop;
- -- If we are in the kernel space, stop the task whose t_id is given in
- -- parameter in such a way that it can be examined by the debugger. This
- -- typically maps to taskSuspend on VxWorks 5 and to taskStop on VxWorks 6.
-
- function Task_Cont (tid : t_id) return int
- renames System.VxWorks.Ext.Task_Cont;
- -- If we are in the kernel space, continue the task whose t_id is given
- -- in parameter if it has been stopped previously to be examined by the
- -- debugger (e.g. by taskStop). It typically maps to taskResume on VxWorks
- -- 5 and to taskCont on VxWorks 6.
-
- function Int_Lock return int renames System.VxWorks.Ext.Int_Lock;
- -- If we are in the kernel space, lock interrupts. It typically maps to
- -- intLock.
-
- function Int_Unlock (Old : int) return int
- renames System.VxWorks.Ext.Int_Unlock;
- -- If we are in the kernel space, unlock interrupts. It typically maps to
- -- intUnlock. The parameter Old is only used on PowerPC where it contains
- -- the returned value from Int_Lock (the old MPSR).
-
- ----------
- -- Time --
- ----------
-
- type time_t is new unsigned_long;
-
- type timespec is record
- ts_sec : time_t;
- ts_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type clockid_t is new int;
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
- -- Convert a Duration value to a timespec value. Note that in VxWorks,
- -- timespec is always non-negative (since time_t is defined above as
- -- unsigned long). This means that there is a potential problem if a
- -- negative argument is passed for D. However, in actual usage, the
- -- value of the input argument D is always non-negative, so no problem
- -- arises in practice.
-
- function To_Clock_Ticks (D : Duration) return int;
- -- Convert a duration value (in seconds) into clock ticks
-
- function clock_gettime
- (clock_id : clockid_t; tp : access timespec) return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- ----------------------
- -- Utility Routines --
- ----------------------
-
- function To_VxWorks_Priority (Priority : int) return int;
- pragma Inline (To_VxWorks_Priority);
- -- Convenience routine to convert between VxWorks priority and Ada priority
-
- --------------------------
- -- VxWorks specific API --
- --------------------------
-
- subtype STATUS is int;
- -- Equivalent of the C type STATUS
-
- OK : constant STATUS := 0;
- ERROR : constant STATUS := Interfaces.C.int (-1);
-
- function taskIdVerify (tid : t_id) return STATUS;
- pragma Import (C, taskIdVerify, "taskIdVerify");
-
- function taskIdSelf return t_id;
- pragma Import (C, taskIdSelf, "taskIdSelf");
-
- function taskOptionsGet (tid : t_id; pOptions : access int) return int;
- pragma Import (C, taskOptionsGet, "taskOptionsGet");
-
- function taskSuspend (tid : t_id) return int;
- pragma Import (C, taskSuspend, "taskSuspend");
-
- function taskResume (tid : t_id) return int;
- pragma Import (C, taskResume, "taskResume");
-
- function taskIsSuspended (tid : t_id) return int;
- pragma Import (C, taskIsSuspended, "taskIsSuspended");
-
- function taskDelay (ticks : int) return int;
- pragma Import (C, taskDelay, "taskDelay");
-
- function sysClkRateGet return int;
- pragma Import (C, sysClkRateGet, "sysClkRateGet");
-
- -- VxWorks 5.x specific functions
- -- Must not be called from run-time for versions that do not support
- -- taskVarLib: eg VxWorks 6 RTPs
-
- function taskVarAdd
- (tid : t_id; pVar : access System.Address) return int;
- pragma Import (C, taskVarAdd, "taskVarAdd");
-
- function taskVarDelete
- (tid : t_id; pVar : access System.Address) return int;
- pragma Import (C, taskVarDelete, "taskVarDelete");
-
- function taskVarSet
- (tid : t_id;
- pVar : access System.Address;
- value : System.Address) return int;
- pragma Import (C, taskVarSet, "taskVarSet");
-
- function taskVarGet
- (tid : t_id;
- pVar : access System.Address) return int;
- pragma Import (C, taskVarGet, "taskVarGet");
-
- -- VxWorks 6.x specific functions
-
- -- Can only be called from the VxWorks 6 run-time libary that supports
- -- tlsLib, and not by the VxWorks 6.6 SMP library
-
- function tlsKeyCreate return int;
- pragma Import (C, tlsKeyCreate, "tlsKeyCreate");
-
- function tlsValueGet (key : int) return System.Address;
- pragma Import (C, tlsValueGet, "tlsValueGet");
-
- function tlsValueSet (key : int; value : System.Address) return STATUS;
- pragma Import (C, tlsValueSet, "tlsValueSet");
-
- -- Option flags for taskSpawn
-
- VX_UNBREAKABLE : constant := 16#0002#;
- VX_FP_PRIVATE_ENV : constant := 16#0080#;
- VX_NO_STACK_FILL : constant := 16#0100#;
-
- function taskSpawn
- (name : System.Address; -- Pointer to task name
- priority : int;
- options : int;
- stacksize : size_t;
- start_routine : System.Address;
- arg1 : System.Address;
- arg2 : int := 0;
- arg3 : int := 0;
- arg4 : int := 0;
- arg5 : int := 0;
- arg6 : int := 0;
- arg7 : int := 0;
- arg8 : int := 0;
- arg9 : int := 0;
- arg10 : int := 0) return t_id;
- pragma Import (C, taskSpawn, "taskSpawn");
-
- procedure taskDelete (tid : t_id);
- pragma Import (C, taskDelete, "taskDelete");
-
- function Set_Time_Slice (ticks : int) return int
- renames System.VxWorks.Ext.Set_Time_Slice;
- -- Calls kernelTimeSlice under VxWorks 5.x, VxWorks 653, or in VxWorks 6
- -- kernel apps. Returns ERROR for RTPs, VxWorks 5 /CERT
-
- function taskPriorityGet (tid : t_id; pPriority : access int) return int;
- pragma Import (C, taskPriorityGet, "taskPriorityGet");
-
- function taskPrioritySet (tid : t_id; newPriority : int) return int;
- pragma Import (C, taskPrioritySet, "taskPrioritySet");
-
- -- Semaphore creation flags
-
- SEM_Q_FIFO : constant := 0;
- SEM_Q_PRIORITY : constant := 1;
- SEM_DELETE_SAFE : constant := 4; -- only valid for binary semaphore
- SEM_INVERSION_SAFE : constant := 8; -- only valid for binary semaphore
-
- -- Semaphore initial state flags
-
- SEM_EMPTY : constant := 0;
- SEM_FULL : constant := 1;
-
- -- Semaphore take (semTake) time constants
-
- WAIT_FOREVER : constant := -1;
- NO_WAIT : constant := 0;
-
- -- Error codes (errno). The lower level 16 bits are the error code, with
- -- the upper 16 bits representing the module number in which the error
- -- occurred. By convention, the module number is 0 for UNIX errors. VxWorks
- -- reserves module numbers 1-500, with the remaining module numbers being
- -- available for user applications.
-
- M_objLib : constant := 61 * 2**16;
- -- semTake() failure with ticks = NO_WAIT
- S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2;
- -- semTake() timeout with ticks > NO_WAIT
- S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4;
-
- subtype SEM_ID is System.VxWorks.Ext.SEM_ID;
- -- typedef struct semaphore *SEM_ID;
-
- -- We use two different kinds of VxWorks semaphores: mutex and binary
- -- semaphores. A null ID is returned when a semaphore cannot be created.
-
- function semBCreate (options : int; initial_state : int) return SEM_ID;
- pragma Import (C, semBCreate, "semBCreate");
- -- Create a binary semaphore. Return ID, or 0 if memory could not
- -- be allocated.
-
- function semMCreate (options : int) return SEM_ID;
- pragma Import (C, semMCreate, "semMCreate");
-
- function semDelete (Sem : SEM_ID) return int
- renames System.VxWorks.Ext.semDelete;
- -- Delete a semaphore
-
- function semGive (Sem : SEM_ID) return int;
- pragma Import (C, semGive, "semGive");
-
- function semTake (Sem : SEM_ID; timeout : int) return int;
- pragma Import (C, semTake, "semTake");
- -- Attempt to take binary semaphore. Error is returned if operation
- -- times out
-
- function semFlush (SemID : SEM_ID) return STATUS;
- pragma Import (C, semFlush, "semFlush");
- -- Release all threads blocked on the semaphore
-
- ------------------------------------------------------------
- -- Binary Semaphore Wrapper to Support interrupt Tasks --
- ------------------------------------------------------------
-
- type Binary_Semaphore_Id is new Long_Integer;
-
- function Binary_Semaphore_Create return Binary_Semaphore_Id;
- pragma Inline (Binary_Semaphore_Create);
-
- function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int;
- pragma Inline (Binary_Semaphore_Delete);
-
- function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int;
- pragma Inline (Binary_Semaphore_Obtain);
-
- function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int;
- pragma Inline (Binary_Semaphore_Release);
-
- function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int;
- pragma Inline (Binary_Semaphore_Flush);
-
- ------------------------------------------------------------
- -- Hardware Interrupt Wrappers to Support Interrupt Tasks --
- ------------------------------------------------------------
-
- 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 Inline (Interrupt_Connect);
- -- Use this to set up an user handler. The routine installs a user handler
- -- which is invoked after the OS has saved enough context for a high-level
- -- language routine to be safely invoked.
-
- function Interrupt_Context return int;
- pragma Inline (Interrupt_Context);
- -- Return 1 if executing in an interrupt context; return 0 if executing in
- -- a task context.
-
- function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector;
- pragma Inline (Interrupt_Number_To_Vector);
- -- Convert a logical interrupt number to the hardware interrupt vector
- -- number used to connect the interrupt.
-
- --------------------------------
- -- Processor Affinity for SMP --
- --------------------------------
-
- function taskCpuAffinitySet (tid : t_id; CPU : int) return int
- renames System.VxWorks.Ext.taskCpuAffinitySet;
- -- For SMP run-times the affinity to CPU.
- -- For uniprocessor systems return ERROR status.
-
- function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int
- renames System.VxWorks.Ext.taskMaskAffinitySet;
- -- For SMP run-times the affinity to CPU_Set.
- -- For uniprocessor systems return ERROR status.
-
- ---------------------
- -- Multiprocessors --
- ---------------------
-
- function Current_CPU return Multiprocessors.CPU;
- -- Return the id of the current CPU
-
-private
- type pid_t is new int;
-
- ERROR_PID : constant pid_t := -1;
-
- type sigset_t is new System.VxWorks.Ext.sigset_t;
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-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- --
--- 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 version is for Linux/x32
-
-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.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-with Interfaces.C; use Interfaces.C;
-package body System.OS_Interface is
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
-
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- use type System.Linux.time_t;
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => Long_Long_Integer (F * 10#1#E9));
- end To_Timespec;
-
-end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1997-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 --
+-- <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 a AIX (Native) version of this package
+
+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.
+
+package body System.OS_Interface is
+
+ use Interfaces.C;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ begin
+ -- For the case SCHED_OTHER the only valid priority across all supported
+ -- versions of AIX is 1 (note that the scheduling policy can be set
+ -- with the pragma Task_Dispatching_Policy or setting the time slice
+ -- value). Otherwise, for SCHED_RR and SCHED_FIFO, the system defines
+ -- priorities in the range 1 .. 127. This means that we must map
+ -- System.Any_Priority in the range 0 .. 126 to 1 .. 127.
+
+ if Dispatching_Policy = ' ' and then Time_Slice_Val < 0 then
+ return 1;
+ else
+ return Interfaces.C.int (Prio) + 1;
+ end if;
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F is negative due to a round-up, adjust for positive F value
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ -----------------
+ -- sched_yield --
+ -----------------
+
+ -- AIX Thread does not have sched_yield;
+
+ function sched_yield return int is
+ procedure pthread_yield;
+ pragma Import (C, pthread_yield, "sched_yield");
+ begin
+ pthread_yield;
+ return 0;
+ end sched_yield;
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ --------------------------
+ -- PTHREAD_PRIO_INHERIT --
+ --------------------------
+
+ AIX_Version : Integer := 0;
+ -- AIX version in the form xy for AIX version x.y (0 means not set)
+
+ SYS_NMLN : constant := 32;
+ -- AIX system constant used to define utsname, see sys/utsname.h
+
+ subtype String_NMLN is String (1 .. SYS_NMLN);
+
+ type utsname is record
+ sysname : String_NMLN;
+ nodename : String_NMLN;
+ release : String_NMLN;
+ version : String_NMLN;
+ machine : String_NMLN;
+ procserial : String_NMLN;
+ end record;
+ pragma Convention (C, utsname);
+
+ procedure uname (name : out utsname);
+ pragma Import (C, uname);
+
+ function PTHREAD_PRIO_INHERIT return int is
+ name : utsname;
+
+ function Val (C : Character) return Integer;
+ -- Transform a numeric character ('0' .. '9') to an integer
+
+ ---------
+ -- Val --
+ ---------
+
+ function Val (C : Character) return Integer is
+ begin
+ return Character'Pos (C) - Character'Pos ('0');
+ end Val;
+
+ -- Start of processing for PTHREAD_PRIO_INHERIT
+
+ begin
+ if AIX_Version = 0 then
+
+ -- Set AIX_Version
+
+ uname (name);
+ AIX_Version := Val (name.version (1)) * 10 + Val (name.release (1));
+ end if;
+
+ if AIX_Version < 53 then
+
+ -- Under AIX < 5.3, PTHREAD_PRIO_INHERIT is defined as 0 in pthread.h
+
+ return 0;
+
+ else
+ -- Under AIX >= 5.3, PTHREAD_PRIO_INHERIT is defined as 3
+
+ return 3;
+ end if;
+ end PTHREAD_PRIO_INHERIT;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1991-2017, Florida State University --
+-- 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 --
+-- <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 a AIX (Native THREADS) 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 Interfaces.C.Extensions;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-pthread");
+ -- This implies -lpthreads + other things depending on the GCC
+ -- configuration, such as the selection of a proper libgcc variant
+ -- for table-based exception handling when it is available.
+
+ pragma Linker_Options ("-lc_r");
+
+ subtype int is Interfaces.C.int;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype long_long is Interfaces.C.Extensions.long_long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIMEDOUT : constant := 78;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 63;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGPWR : constant := 29; -- power-fail restart
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGPOLL : constant := 23; -- pollable event occurred
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 34; -- virtual timer expired
+ SIGPROF : constant := 32; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGWAITING : constant := 39; -- m:n scheduling
+
+ -- The following signals are AIX specific
+
+ SIGMSG : constant := 27; -- input data is in the ring buffer
+ SIGDANGER : constant := 33; -- system crash imminent
+ SIGMIGRATE : constant := 35; -- migrate process
+ SIGPRE : constant := 36; -- programming exception
+ SIGVIRT : constant := 37; -- AIX virtual time alarm
+ SIGALRM1 : constant := 38; -- m:n condition variables
+ SIGCPUFAIL : constant := 59; -- Predictive De-configuration of Processors
+ SIGKAP : constant := 60; -- keep alive poll from native keyboard
+ SIGGRANT : constant := SIGKAP; -- monitor mode granted
+ SIGRETRACT : constant := 61; -- monitor mode should be relinquished
+ SIGSOUND : constant := 62; -- sound control has completed
+ SIGSAK : constant := 63; -- secure attention key
+
+ SIGADAABORT : constant := SIGEMT;
+ -- Note: on other targets, we usually use SIGABRT, but on AIX, it appears
+ -- that SIGABRT can't be used in sigwait(), so we use SIGEMT.
+ -- SIGEMT is "Emulator Trap Instruction" from the PDP-11, and does not
+ -- have a standardized usage.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF);
+ Reserved : constant Signal_Set :=
+ (SIGABRT, SIGKILL, SIGSTOP, SIGALRM1, SIGWAITING, SIGCPUFAIL);
+
+ 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 struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_SIGINFO : constant := 16#0100#;
+ SA_ONSTACK : constant := 16#0001#;
+
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ Time_Slice_Supported : constant Boolean := True;
+ -- Indicates whether time slicing is supported
+
+ type timespec is private;
+
+ type clockid_t is new long_long;
+
+ 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);
+
+ type struct_timezone is record
+ tz_minuteswest : int;
+ tz_dsttime : int;
+ end record;
+ pragma Convention (C, struct_timezone);
+ type struct_timezone_ptr is access all struct_timezone;
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+ SCHED_OTHER : constant := 0;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ pragma Import (C, lwp_self, "thread_self");
+
+ -------------
+ -- 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 private;
+ subtype Thread_Id is 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 AIX. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ 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_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- Returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ 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 --
+ ---------------------------------------
+
+ -- Though not documented, pthread_init *must* be called before any other
+ -- pthread call.
+
+ procedure pthread_init;
+ pragma Import (C, pthread_init, "pthread_init");
+
+ -------------------------
+ -- 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, "sigthreadmask");
+
+ --------------------------
+ -- 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 := 2;
+
+ function PTHREAD_PRIO_INHERIT return int;
+ -- Return value of C macro PTHREAD_PRIO_INHERIT. This function is needed
+ -- since the value is different between AIX versions.
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import (C, pthread_mutexattr_setprotocol);
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import (C, pthread_mutexattr_setprioceiling);
+
+ type Array_5_Int is array (0 .. 5) of int;
+ type struct_sched_param is record
+ sched_priority : int;
+ sched_policy : int;
+ sched_reserved : Array_5_Int;
+ end record;
+
+ 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;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import (C, pthread_attr_setinheritsched);
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy);
+
+ function pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : int) return int;
+ pragma Import (C, pthread_attr_setschedparam);
+
+ function sched_yield return int;
+ -- AIX have a nonstandard 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);
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize);
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address)
+ return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+ type sigset_t is record
+ losigs : unsigned_long;
+ hisigs : unsigned_long;
+ end record;
+ pragma Convention (C_Pass_By_Copy, sigset_t);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type pthread_attr_t is new System.Address;
+ pragma Convention (C, pthread_attr_t);
+ -- typedef struct __pt_attr *pthread_attr_t;
+
+ type pthread_condattr_t is new System.Address;
+ pragma Convention (C, pthread_condattr_t);
+ -- typedef struct __pt_attr *pthread_condattr_t;
+
+ type pthread_mutexattr_t is new System.Address;
+ pragma Convention (C, pthread_mutexattr_t);
+ -- typedef struct __pt_attr *pthread_mutexattr_t;
+
+ type pthread_t is new System.Address;
+ pragma Convention (C, pthread_t);
+ -- typedef void *pthread_t;
+
+ type ptq_queue;
+ type ptq_queue_ptr is access all ptq_queue;
+
+ type ptq_queue is record
+ ptq_next : ptq_queue_ptr;
+ ptq_prev : ptq_queue_ptr;
+ end record;
+
+ type Array_3_Int is array (0 .. 3) of int;
+ type pthread_mutex_t is record
+ link : ptq_queue;
+ ptmtx_lock : int;
+ ptmtx_flags : long;
+ protocol : int;
+ prioceiling : int;
+ ptmtx_owner : pthread_t;
+ mtx_id : int;
+ attr : pthread_attr_t;
+ mtx_kind : int;
+ lock_cpt : int;
+ reserved : Array_3_Int;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+ type pthread_mutex_t_ptr is access pthread_mutex_t;
+
+ type pthread_cond_t is record
+ link : ptq_queue;
+ ptcv_lock : int;
+ ptcv_flags : long;
+ ptcv_waiters : ptq_queue;
+ cv_id : int;
+ attr : pthread_attr_t;
+ mutex : pthread_mutex_t_ptr;
+ cptwait : int;
+ reserved : int;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1995-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- --
+-- 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 an Android version of this package.
+
+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.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+with Interfaces.C; use Interfaces.C;
+
+package body System.OS_Interface is
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <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 an Android version of this package which is based on the
+-- GNU/Linux version
+
+-- 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.Linux;
+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");
+
+ EAGAIN : constant := System.Linux.EAGAIN;
+ EINTR : constant := System.Linux.EINTR;
+ EINVAL : constant := System.Linux.EINVAL;
+ ENOMEM : constant := System.Linux.ENOMEM;
+ EPERM : constant := System.Linux.EPERM;
+ ETIMEDOUT : constant := System.Linux.ETIMEDOUT;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := System.Linux.SIGHUP;
+ SIGINT : constant := System.Linux.SIGINT;
+ SIGQUIT : constant := System.Linux.SIGQUIT;
+ SIGILL : constant := System.Linux.SIGILL;
+ SIGTRAP : constant := System.Linux.SIGTRAP;
+ SIGIOT : constant := System.Linux.SIGIOT;
+ SIGABRT : constant := System.Linux.SIGABRT;
+ SIGFPE : constant := System.Linux.SIGFPE;
+ SIGKILL : constant := System.Linux.SIGKILL;
+ SIGBUS : constant := System.Linux.SIGBUS;
+ SIGSEGV : constant := System.Linux.SIGSEGV;
+ SIGPIPE : constant := System.Linux.SIGPIPE;
+ SIGALRM : constant := System.Linux.SIGALRM;
+ SIGTERM : constant := System.Linux.SIGTERM;
+ SIGUSR1 : constant := System.Linux.SIGUSR1;
+ SIGUSR2 : constant := System.Linux.SIGUSR2;
+ SIGCLD : constant := System.Linux.SIGCLD;
+ SIGCHLD : constant := System.Linux.SIGCHLD;
+ SIGPWR : constant := System.Linux.SIGPWR;
+ SIGWINCH : constant := System.Linux.SIGWINCH;
+ SIGURG : constant := System.Linux.SIGURG;
+ SIGPOLL : constant := System.Linux.SIGPOLL;
+ SIGIO : constant := System.Linux.SIGIO;
+ SIGLOST : constant := System.Linux.SIGLOST;
+ SIGSTOP : constant := System.Linux.SIGSTOP;
+ SIGTSTP : constant := System.Linux.SIGTSTP;
+ SIGCONT : constant := System.Linux.SIGCONT;
+ SIGTTIN : constant := System.Linux.SIGTTIN;
+ SIGTTOU : constant := System.Linux.SIGTTOU;
+ SIGVTALRM : constant := System.Linux.SIGVTALRM;
+ SIGPROF : constant := System.Linux.SIGPROF;
+ SIGXCPU : constant := System.Linux.SIGXCPU;
+ SIGXFSZ : constant := System.Linux.SIGXFSZ;
+ SIGUNUSED : constant := System.Linux.SIGUNUSED;
+ SIGSTKFLT : constant := System.Linux.SIGSTKFLT;
+
+ 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 := (SIGVTALRM, SIGUNUSED);
+ -- Not clear why these two signals are reserved. Perhaps they are not
+ -- supported by this version of GNU/Linux ???
+
+ type sigset_t is private;
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "_sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "_sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "_sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "_sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "_sigemptyset");
+
+ type union_type_3 is new String (1 .. 116);
+ type siginfo_t is record
+ si_signo : int;
+ si_code : int;
+ si_errno : int;
+ X_data : union_type_3;
+ end record;
+ pragma Convention (C, siginfo_t);
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : Interfaces.C.unsigned_long;
+ sa_restorer : System.Address;
+ end record;
+ pragma Convention (C, struct_sigaction);
+
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_SIGINFO : constant := System.Linux.SA_SIGINFO;
+ SA_ONSTACK : constant := System.Linux.SA_ONSTACK;
+ SA_NODEFER : constant := System.Linux.SA_NODEFER;
+ SA_RESTART : constant := System.Linux.SA_RESTART;
+
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ 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 is (Interfaces.C.int (Prio));
+ -- 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;
+ pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
+ -- The alternate signal stack for stack overflows
+
+ Alternate_Stack_Size : constant := 16 * 1024;
+ -- This must be in keeping with init.c:__gnat_alternate_stack
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target
+
+ function Get_Stack_Base (thread : pthread_t)
+ return Address is (Null_Address);
+ -- 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 is null;
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "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, "__gnat_lwp_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
+
+ function pthread_setaffinity_np
+ (thread : pthread_t;
+ cpusetsize : size_t;
+ cpuset : cpu_set_t_ptr) return int;
+ pragma Import (C, pthread_setaffinity_np, "pthread_setaffinity_np");
+ pragma Weak_External (pthread_setaffinity_np);
+ -- Use a weak symbol because this function may be available or not,
+ -- depending on the version of the system.
+
+ function pthread_attr_setaffinity_np
+ (attr : access pthread_attr_t;
+ cpusetsize : size_t;
+ cpuset : cpu_set_t_ptr) return int;
+ pragma Import (C, pthread_attr_setaffinity_np,
+ "pthread_attr_setaffinity_np");
+ pragma Weak_External (pthread_attr_setaffinity_np);
+ -- Use a weak symbol because this function may be available or not,
+ -- depending on the version of the system.
+
+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;
+
+ pragma Warnings (Off);
+ for struct_sigaction use record
+ sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1;
+ sa_mask at Linux.sa_mask_pos range 0 .. sigset_t'Size - 1;
+ sa_flags at Linux.sa_flags_pos
+ range 0 .. Interfaces.C.unsigned_long'Size - 1;
+ end record;
+ -- We intentionally leave sa_restorer unspecified and let the compiler
+ -- append it after the last field, so disable corresponding warning.
+ pragma Warnings (On);
+
+ type pid_t is new int;
+
+ 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1999-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 --
+-- <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 a Darwin Threads version of this package
+
+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 Interfaces.C.Extensions;
+
+package body System.OS_Interface is
+ use Interfaces.C;
+ use Interfaces.C.Extensions;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ -------------------
+ -- clock_gettime --
+ -------------------
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int
+ is
+ pragma Unreferenced (clock_id);
+
+ -- Darwin Threads don't have clock_gettime, so use gettimeofday
+
+ use Interfaces;
+
+ type timeval is array (1 .. 3) of C.long;
+ -- The timeval array is sized to contain long_long sec and long usec.
+ -- If long_long'Size = long'Size then it will be overly large but that
+ -- won't effect the implementation since it's not accessed directly.
+
+ procedure timeval_to_duration
+ (T : not null access timeval;
+ sec : not null access C.Extensions.long_long;
+ usec : not null access C.long);
+ pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
+
+ Micro : constant := 10**6;
+ sec : aliased C.Extensions.long_long;
+ usec : aliased C.long;
+ TV : aliased timeval;
+ Result : int;
+
+ function gettimeofday
+ (Tv : access timeval;
+ Tz : System.Address := System.Null_Address) return int;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ begin
+ Result := gettimeofday (TV'Access, System.Null_Address);
+ pragma Assert (Result = 0);
+ timeval_to_duration (TV'Access, sec'Access, usec'Access);
+ tp.all := To_Timespec (Duration (sec) + Duration (usec) / Micro);
+ return Result;
+ end clock_gettime;
+
+ ------------------
+ -- clock_getres --
+ ------------------
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int
+ is
+ pragma Unreferenced (clock_id);
+
+ -- Darwin Threads don't have clock_getres.
+
+ Nano : constant := 10**9;
+ nsec : int := 0;
+ Result : int := -1;
+
+ function clock_get_res return int;
+ pragma Import (C, clock_get_res, "__gnat_clock_get_res");
+
+ begin
+ nsec := clock_get_res;
+ res.all := To_Timespec (Duration (0.0) + Duration (nsec) / Nano);
+
+ if nsec > 0 then
+ Result := 0;
+ end if;
+
+ return Result;
+ end clock_getres;
+
+ -----------------
+ -- sched_yield --
+ -----------------
+
+ function sched_yield return int is
+ procedure sched_yield_base (arg : System.Address);
+ pragma Import (C, sched_yield_base, "pthread_yield_np");
+
+ begin
+ sched_yield_base (System.Null_Address);
+ return 0;
+ end sched_yield;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ ----------------
+ -- Stack_Base --
+ ----------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Unreferenced (thread);
+ begin
+ return System.Null_Address;
+ end Get_Stack_Base;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1991-2017, Florida State University --
+-- 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 --
+-- <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 Darwin pthreads version of this package
+
+-- This package includes 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
+-- Elaborate_Body. It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+with System.OS_Constants;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ subtype int is Interfaces.C.int;
+ 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");
+
+ EINTR : constant := 4;
+ ENOMEM : constant := 12;
+ EINVAL : constant := 22;
+ EAGAIN : constant := 35;
+ ETIMEDOUT : constant := 60;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGINFO : constant := 29; -- information request
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGTTIN, SIGTTOU, SIGSTOP, SIGTSTP);
+
+ Reserved : constant Signal_Set :=
+ (SIGKILL, SIGSTOP);
+
+ Exception_Signals : constant Signal_Set :=
+ (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
+ -- These signals (when runtime or system) will be caught and converted
+ -- into an Ada exception.
+
+ 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 siginfo_t is private;
+ type ucontext_t is private;
+
+ type Signal_Handler is access procedure
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access ucontext_t);
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ SA_SIGINFO : constant := 16#0040#;
+ SA_ONSTACK : constant := 16#0001#;
+
+ 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;
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_OTHER : constant := 1;
+ SCHED_RR : constant := 2;
+ SCHED_FIFO : constant := 4;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ pragma Import (C, lwp_self, "__gnat_lwp_self");
+ -- Return the mach thread bound to the current thread. The value is not
+ -- used by the run-time library but made available to debuggers.
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ type pthread_t is private;
+ subtype Thread_Id is 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;
+
+ type pthread_mutex_ptr is access all pthread_mutex_t;
+ type pthread_cond_ptr is access all pthread_cond_t;
+
+ PTHREAD_CREATE_DETACHED : constant := 2;
+
+ PTHREAD_SCOPE_PROCESS : constant := 2;
+ PTHREAD_SCOPE_SYSTEM : constant := 1;
+
+ -- Read/Write lock not supported on Darwin. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ 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_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
+ -- The alternate signal stack for stack overflows
+
+ Alternate_Stack_Size : constant := 32 * 1024;
+ -- 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. This
+ -- allows us to share s-osinte.adb between all the FSU run time. Note that
+ -- this value can only be true if pthread_t has a complete definition that
+ -- corresponds exactly to the C header files.
+
+ function Get_Stack_Base (thread : pthread_t) return System.Address;
+ pragma Inline (Get_Stack_Base);
+ -- returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ 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_NONE;
+ PROT_OFF : constant := PROT_ALL;
+
+ function mprotect
+ (addr : System.Address;
+ len : size_t;
+ prot : int) return int;
+ pragma Import (C, mprotect);
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprioceiling,
+ "pthread_mutexattr_setprioceiling");
+
+ type padding is array (int range <>) of Interfaces.C.char;
+
+ type struct_sched_param is record
+ sched_priority : int; -- scheduling priority
+ opaque : padding (1 .. 4);
+ 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;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import
+ (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched");
+
+ function sched_yield return int;
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "pthread_attr_init");
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Import
+ (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import
+ (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type sigset_t is new unsigned;
+
+ type int32_t is new int;
+
+ type pid_t is new int32_t;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ --
+ -- Darwin specific signal implementation
+ --
+ type Pad_Type is array (1 .. 7) of unsigned_long;
+ type siginfo_t is record
+ si_signo : int; -- signal number
+ si_errno : int; -- errno association
+ si_code : int; -- signal code
+ si_pid : int; -- sending process
+ si_uid : unsigned; -- sender's ruid
+ si_status : int; -- exit value
+ si_addr : System.Address; -- faulting instruction
+ si_value : System.Address; -- signal value
+ si_band : long; -- band event for SIGPOLL
+ pad : Pad_Type; -- RFU
+ end record;
+ pragma Convention (C, siginfo_t);
+
+ type mcontext_t is new System.Address;
+
+ type ucontext_t is record
+ uc_onstack : int;
+ uc_sigmask : sigset_t; -- Signal Mask Used By This Context
+ uc_stack : stack_t; -- Stack Used By This Context
+ uc_link : System.Address; -- Pointer To Resuming Context
+ uc_mcsize : size_t; -- Size of The Machine Context
+ uc_mcontext : mcontext_t; -- Machine Specific Context
+ end record;
+ pragma Convention (C, ucontext_t);
+
+ --
+ -- Darwin specific pthread implementation
+ --
+ type pthread_t is new System.Address;
+
+ type pthread_attr_t is record
+ sig : long;
+ opaque : padding (1 .. System.OS_Constants.PTHREAD_ATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_mutexattr_t is record
+ sig : long;
+ opaque : padding (1 .. System.OS_Constants.PTHREAD_MUTEXATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type pthread_mutex_t is record
+ sig : long;
+ opaque : padding (1 .. System.OS_Constants.PTHREAD_MUTEX_SIZE);
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_condattr_t is record
+ sig : long;
+ opaque : padding (1 .. System.OS_Constants.PTHREAD_CONDATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_cond_t is record
+ sig : long;
+ opaque : padding (1 .. System.OS_Constants.PTHREAD_COND_SIZE);
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_once_t is record
+ sig : long;
+ opaque : padding (1 .. System.OS_Constants.PTHREAD_ONCE_SIZE);
+ end record;
+ pragma Convention (C, pthread_once_t);
+
+ type pthread_key_t is new unsigned_long;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2015, 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. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the DragonFly THREADS version of this package
+
+with Interfaces.C; use Interfaces.C;
+
+package body System.OS_Interface is
+
+ -----------
+ -- Errno --
+ -----------
+
+ function Errno return int is
+ type int_ptr is access all int;
+
+ function internal_errno return int_ptr;
+ pragma Import (C, internal_errno, "__get_errno");
+
+ begin
+ return (internal_errno.all);
+ end Errno;
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Unreferenced (thread);
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(ts_sec => S,
+ ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2015, 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the DragonFly BSD PTHREADS version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-pthread");
+
+ subtype int is Interfaces.C.int;
+ 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 Inline (Errno);
+
+ EAGAIN : constant := 35;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIMEDOUT : constant := 60;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGINFO : constant := 29; -- information request (BSD)
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ -- Interrupts that must be unmasked at all times. DragonFlyBSD
+ -- pthreads will not allow an application to mask out any
+ -- interrupt needed by the threads library.
+ Unmasked : constant Signal_Set :=
+ (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP);
+
+ -- DragonFlyBSD will uses SIGPROF for timing. Do not allow a
+ -- handler to attach to this signal.
+ Reserved : constant Signal_Set := (0 .. 0 => SIGPROF);
+
+ 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");
+
+ -- sigcontext is architecture dependent, so define it private
+ type struct_sigcontext is private;
+
+ type old_struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, old_struct_sigaction);
+
+ type new_struct_sigaction is record
+ sa_handler : System.Address;
+ sa_flags : int;
+ sa_mask : sigset_t;
+ end record;
+ pragma Convention (C, new_struct_sigaction);
+
+ subtype struct_sigaction is new_struct_sigaction;
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ SA_SIGINFO : constant := 16#0040#;
+ SA_ONSTACK : constant := 16#0001#;
+
+ 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 (i.e SCHED_RR is supported)
+
+ type timespec is private;
+
+ function nanosleep (rqtp, rmtp : access timespec) return int;
+ pragma Import (C, nanosleep, "nanosleep");
+
+ type clockid_t is new unsigned_long;
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec)
+ return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ type struct_timezone is record
+ tz_minuteswest : int;
+ tz_dsttime : int;
+ end record;
+ pragma Convention (C, struct_timezone);
+
+ procedure usleep (useconds : unsigned_long);
+ pragma Import (C, usleep, "usleep");
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_OTHER : constant := 2;
+ SCHED_RR : constant := 3;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ -- lwp_self does not exist on this thread library, revert to pthread_self
+ -- which is the closest approximation (with getpid). This function is
+ -- needed to share 7staprop.adb across POSIX-like targets.
+ pragma Import (C, lwp_self, "pthread_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ 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 private;
+ subtype Thread_Id is 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_CREATE_JOINABLE : constant := 0;
+
+ PTHREAD_SCOPE_PROCESS : constant := 0;
+ PTHREAD_SCOPE_SYSTEM : constant := 2;
+
+ -- Read/Write lock not supported on DragonFly. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ 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_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target. This
+ -- allows us to share s-osinte.adb between all the FSU run time. Note that
+ -- this value can only be true if pthread_t has a complete definition that
+ -- corresponds exactly to the C header files.
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ 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_NONE;
+ PROT_OFF : constant := PROT_ALL;
+
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ pragma Import (C, mprotect);
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ -- FSU_THREADS requires pthread_init, which is nonstandard and this should
+ -- be invoked during the elaboration of s-taprop.adb.
+
+ -- DragonFlyBSD does not require this so we provide an empty Ada body
+
+ procedure pthread_init;
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
+
+ function pthread_mutexattr_getprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : access int) return int;
+ pragma Import
+ (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol");
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprioceiling,
+ "pthread_mutexattr_setprioceiling");
+
+ function pthread_mutexattr_getprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : access int) return int;
+ pragma Import
+ (C, pthread_mutexattr_getprioceiling,
+ "pthread_mutexattr_getprioceiling");
+
+ type struct_sched_param is record
+ sched_priority : int;
+ end record;
+ pragma Convention (C, struct_sched_param);
+
+ function pthread_getschedparam
+ (thread : pthread_t;
+ policy : access int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_getschedparam, "pthread_getschedparam");
+
+ 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;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_getscope
+ (attr : access pthread_attr_t;
+ contentionscope : access int) return int;
+ pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import
+ (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
+
+ function pthread_attr_getinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : access int) return int;
+ pragma Import
+ (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy,
+ "pthread_attr_setschedpolicy");
+
+ function pthread_attr_getschedpolicy
+ (attr : access pthread_attr_t;
+ policy : access int) return int;
+ pragma Import (C, pthread_attr_getschedpolicy,
+ "pthread_attr_getschedpolicy");
+
+ function pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : int) return int;
+ pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
+
+ function pthread_attr_getschedparam
+ (attr : access pthread_attr_t;
+ sched_param : access int) return int;
+ pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam");
+
+ function sched_yield return int;
+ pragma Import (C, sched_yield, "pthread_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_getdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : access int) return int;
+ pragma Import
+ (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate");
+
+ function pthread_attr_getstacksize
+ (attr : access pthread_attr_t;
+ stacksize : access size_t) return int;
+ pragma Import
+ (C, pthread_attr_getstacksize, "pthread_attr_getstacksize");
+
+ 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");
+
+ function pthread_detach (thread : pthread_t) return int;
+ pragma Import (C, pthread_detach, "pthread_detach");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ ------------------------------------
+ -- Non-portable Pthread Functions --
+ ------------------------------------
+
+ function pthread_set_name_np
+ (thread : pthread_t;
+ name : System.Address) return int;
+ pragma Import (C, pthread_set_name_np, "pthread_set_name_np");
+
+private
+
+ type sigset_t is array (1 .. 4) of unsigned;
+
+ -- In DragonFlyBSD the component sa_handler turns out to
+ -- be one a union type, and the selector is a macro:
+ -- #define sa_handler __sigaction_u._handler
+ -- #define sa_sigaction __sigaction_u._sigaction
+
+ -- Should we add a signal_context type here ???
+ -- How could it be done independent of the CPU architecture ???
+ -- sigcontext type is opaque, so it is architecturally neutral.
+ -- It is always passed as an access type, so define it as an empty record
+ -- since the contents are not used anywhere.
+
+ type struct_sigcontext is null record;
+ pragma Convention (C, struct_sigcontext);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ ts_sec : time_t;
+ ts_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type pthread_t is new System.Address;
+ type pthread_attr_t is new System.Address;
+ type pthread_mutex_t is new System.Address;
+ type pthread_mutexattr_t is new System.Address;
+ type pthread_cond_t is new System.Address;
+ type pthread_condattr_t is new System.Address;
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1991-2017, Florida State University --
+-- 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 --
+-- <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 no tasking version
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 2;
+ type Signal is new Integer range 0 .. Max_Interrupt;
+
+ type sigset_t is new Integer;
+ type Thread_Id is new Integer;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the FreeBSD THREADS version of this package
+
+with Interfaces.C; use Interfaces.C;
+
+package body System.OS_Interface is
+
+ -----------
+ -- Errno --
+ -----------
+
+ function Errno return int is
+ type int_ptr is access all int;
+
+ function internal_errno return int_ptr;
+ pragma Import (C, internal_errno, "__get_errno");
+
+ begin
+ return (internal_errno.all);
+ end Errno;
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Unreferenced (thread);
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(ts_sec => S,
+ ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1991-2017, Florida State University --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the FreeBSD (POSIX Threads) version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-pthread");
+
+ subtype int is Interfaces.C.int;
+ 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 Inline (Errno);
+
+ EAGAIN : constant := 35;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIMEDOUT : constant := 60;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD)
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ -- Interrupts that must be unmasked at all times. FreeBSD
+ -- pthreads will not allow an application to mask out any
+ -- interrupt needed by the threads library.
+ Unmasked : constant Signal_Set :=
+ (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP);
+
+ -- FreeBSD will uses SIGPROF for timing. Do not allow a
+ -- handler to attach to this signal.
+ Reserved : constant Signal_Set := (0 .. 0 => SIGPROF);
+
+ 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");
+
+ -- sigcontext is architecture dependent, so define it private
+ type struct_sigcontext is private;
+
+ type old_struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, old_struct_sigaction);
+
+ type new_struct_sigaction is record
+ sa_handler : System.Address;
+ sa_flags : int;
+ sa_mask : sigset_t;
+ end record;
+ pragma Convention (C, new_struct_sigaction);
+
+ subtype struct_sigaction is new_struct_sigaction;
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ SA_SIGINFO : constant := 16#0040#;
+ SA_ONSTACK : constant := 16#0001#;
+
+ 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 (i.e SCHED_RR is supported)
+
+ type timespec is private;
+
+ function nanosleep (rqtp, rmtp : access timespec) return int;
+ pragma Import (C, nanosleep, "nanosleep");
+
+ type clockid_t is new int;
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec)
+ return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ type struct_timezone is record
+ tz_minuteswest : int;
+ tz_dsttime : int;
+ end record;
+ pragma Convention (C, struct_timezone);
+
+ procedure usleep (useconds : unsigned_long);
+ pragma Import (C, usleep, "usleep");
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_OTHER : constant := 2;
+ SCHED_RR : constant := 3;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ Self_PID : constant pid_t;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ -- lwp_self does not exist on this thread library, revert to pthread_self
+ -- which is the closest approximation (with getpid). This function is
+ -- needed to share 7staprop.adb across POSIX-like targets.
+ pragma Import (C, lwp_self, "pthread_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ 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 private;
+ subtype Thread_Id is 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_CREATE_JOINABLE : constant := 0;
+
+ PTHREAD_SCOPE_PROCESS : constant := 0;
+ PTHREAD_SCOPE_SYSTEM : constant := 2;
+
+ -- Read/Write lock not supported on freebsd. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ 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_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ 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_NONE;
+ PROT_OFF : constant := PROT_ALL;
+
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ pragma Import (C, mprotect);
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ -- FSU_THREADS requires pthread_init, which is nonstandard and this should
+ -- be invoked during the elaboration of s-taprop.adb.
+
+ -- FreeBSD does not require this so we provide an empty Ada body
+
+ procedure pthread_init;
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
+
+ function pthread_mutexattr_getprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : access int) return int;
+ pragma Import
+ (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol");
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprioceiling,
+ "pthread_mutexattr_setprioceiling");
+
+ function pthread_mutexattr_getprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : access int) return int;
+ pragma Import
+ (C, pthread_mutexattr_getprioceiling,
+ "pthread_mutexattr_getprioceiling");
+
+ type struct_sched_param is record
+ sched_priority : int;
+ end record;
+ pragma Convention (C, struct_sched_param);
+
+ function pthread_getschedparam
+ (thread : pthread_t;
+ policy : access int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_getschedparam, "pthread_getschedparam");
+
+ 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;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_getscope
+ (attr : access pthread_attr_t;
+ contentionscope : access int) return int;
+ pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import
+ (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
+
+ function pthread_attr_getinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : access int) return int;
+ pragma Import
+ (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy,
+ "pthread_attr_setschedpolicy");
+
+ function pthread_attr_getschedpolicy
+ (attr : access pthread_attr_t;
+ policy : access int) return int;
+ pragma Import (C, pthread_attr_getschedpolicy,
+ "pthread_attr_getschedpolicy");
+
+ function pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : int) return int;
+ pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
+
+ function pthread_attr_getschedparam
+ (attr : access pthread_attr_t;
+ sched_param : access int) return int;
+ pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam");
+
+ function sched_yield return int;
+ pragma Import (C, sched_yield, "pthread_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_getdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : access int) return int;
+ pragma Import
+ (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate");
+
+ function pthread_attr_getstacksize
+ (attr : access pthread_attr_t;
+ stacksize : access size_t) return int;
+ pragma Import
+ (C, pthread_attr_getstacksize, "pthread_attr_getstacksize");
+
+ 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");
+
+ function pthread_detach (thread : pthread_t) return int;
+ pragma Import (C, pthread_detach, "pthread_detach");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ ------------------------------------
+ -- Non-portable Pthread Functions --
+ ------------------------------------
+
+ function pthread_set_name_np
+ (thread : pthread_t;
+ name : System.Address) return int;
+ pragma Import (C, pthread_set_name_np, "pthread_set_name_np");
+
+private
+
+ type sigset_t is array (1 .. 4) of unsigned;
+
+ -- In FreeBSD the component sa_handler turns out to
+ -- be one a union type, and the selector is a macro:
+ -- #define sa_handler __sigaction_u._handler
+ -- #define sa_sigaction __sigaction_u._sigaction
+
+ -- Should we add a signal_context type here ???
+ -- How could it be done independent of the CPU architecture ???
+ -- sigcontext type is opaque, so it is architecturally neutral.
+ -- It is always passed as an access type, so define it as an empty record
+ -- since the contents are not used anywhere.
+
+ type struct_sigcontext is null record;
+ pragma Convention (C, struct_sigcontext);
+
+ type pid_t is new int;
+ Self_PID : constant pid_t := 0;
+
+ type time_t is new long;
+
+ type timespec is record
+ ts_sec : time_t;
+ ts_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type pthread_t is new System.Address;
+ type pthread_attr_t is new System.Address;
+ type pthread_mutex_t is new System.Address;
+ type pthread_mutexattr_t is new System.Address;
+ type pthread_cond_t is new System.Address;
+ type pthread_condattr_t is new System.Address;
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2015-2016, 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 --
+-- <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 GNU/Hurd version of this package.
+
+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.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+package body System.OS_Interface is
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ --------------------------------------
+ -- pthread_mutexattr_setprioceiling --
+ --------------------------------------
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int is
+ pragma Unreferenced (attr, prioceiling);
+ begin
+ return 0;
+ end pthread_mutexattr_setprioceiling;
+
+ --------------------------------------
+ -- pthread_mutexattr_getprioceiling --
+ --------------------------------------
+
+ function pthread_mutexattr_getprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : access int) return int is
+ pragma Unreferenced (attr, prioceiling);
+ begin
+ return 0;
+ end pthread_mutexattr_getprioceiling;
+
+ ---------------------------
+ -- pthread_setschedparam --
+ ---------------------------
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int is
+ pragma Unreferenced (thread, policy, param);
+ begin
+ return 0;
+ end pthread_setschedparam;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2016, 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 --
+-- <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 GNU/Hurd (POSIX Threads) version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package
+
+with Interfaces.C;
+with Unchecked_Conversion;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthread");
+ pragma Linker_Options ("-lrt");
+
+ 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 --
+ -----------
+ -- From /usr/include/i386-gnu/bits/errno.h
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 1073741859;
+ EINTR : constant := 1073741828;
+ EINVAL : constant := 1073741846;
+ ENOMEM : constant := 1073741836;
+ EPERM : constant := 1073741825;
+ ETIMEDOUT : constant := 1073741884;
+
+ -------------
+ -- Signals --
+ -------------
+ -- From /usr/include/i386-gnu/bits/signum.h
+
+ Max_Interrupt : constant := 32;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGPOLL : constant := 23; -- I/O possible (same as SIGIO?)
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD)
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+ SIGLOST : constant := 32; -- Resource lost (Sun); server died (GNU)
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (
+ SIGTRAP,
+ -- To enable debugging on multithreaded applications, mark SIGTRAP to
+ -- be kept unmasked.
+
+ SIGBUS,
+
+ SIGTTIN, SIGTTOU, SIGTSTP,
+ -- Keep these three signals unmasked so that background processes
+ -- and IO behaves as normal "C" applications
+
+ SIGPROF,
+ -- To avoid confusing the profiler
+
+ SIGKILL, SIGSTOP);
+ -- These two signals actually cannot be masked;
+ -- POSIX simply won't allow it.
+
+ Reserved : constant Signal_Set :=
+ -- I am not sure why the following signal is reserved.
+ -- I guess they are not supported by this version of GNU/Hurd.
+ (0 .. 0 => SIGVTALRM);
+
+ type sigset_t is private;
+
+ -- From /usr/include/signal.h /usr/include/i386-gnu/bits/sigset.h
+ 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");
+
+ -- sigcontext is architecture dependent, so define it private
+ type struct_sigcontext is private;
+
+ -- From /usr/include/i386-gnu/bits/sigaction.h: Note: arg. order differs
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ -- From /usr/include/i386-gnu/bits/sigaction.h
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ -- From /usr/include/i386-gnu/bits/signum.h
+ SIG_ERR : constant := 1;
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+ SIG_HOLD : constant := 2;
+
+ -- From /usr/include/i386-gnu/bits/sigaction.h
+ SA_SIGINFO : constant := 16#0040#;
+ SA_ONSTACK : constant := 16#0001#;
+
+ 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 (i.e SCHED_RR is supported)
+
+ type timespec is private;
+
+ function nanosleep (rqtp, rmtp : access timespec) return int;
+ pragma Import (C, nanosleep, "nanosleep");
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ -- From: /usr/include/time.h
+ 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);
+
+ -- From: /usr/include/unistd.h
+ function sysconf (name : int) return long;
+ pragma Import (C, sysconf);
+
+ -- From /usr/include/i386-gnu/bits/confname.h
+ SC_CLK_TCK : constant := 2;
+ SC_NPROCESSORS_ONLN : constant := 84;
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+ -- From /usr/include/i386-gnu/bits/sched.h
+
+ SCHED_OTHER : constant := 0;
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority.
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ -- From: /usr/include/signal.h
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ -- From: /usr/include/unistd.h
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ -- From: /usr/include/pthread/pthread.h
+ function lwp_self return System.Address;
+ -- lwp_self does not exist on this thread library, revert to pthread_self
+ -- which is the closest approximation (with getpid). This function is
+ -- needed to share 7staprop.adb across POSIX-like targets.
+ pragma Import (C, lwp_self, "pthread_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, Thread_Body);
+
+ -- From: /usr/include/bits/pthread.h:typedef int __pthread_t;
+ -- /usr/include/pthread/pthreadtypes.h:typedef __pthread_t pthread_t;
+ type pthread_t is new unsigned_long;
+ subtype Thread_Id is pthread_t;
+
+ function To_pthread_t is new Unchecked_Conversion
+ (unsigned_long, pthread_t);
+
+ type pthread_mutex_t is limited private;
+ type pthread_rwlock_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_rwlockattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ -- From /usr/include/pthread/pthreadtypes.h
+ PTHREAD_CREATE_DETACHED : constant := 1;
+ PTHREAD_CREATE_JOINABLE : constant := 0;
+
+ PTHREAD_SCOPE_PROCESS : constant := 1;
+ PTHREAD_SCOPE_SYSTEM : constant := 0;
+
+ -----------
+ -- Stack --
+ -----------
+
+ -- From: /usr/include/i386-gnu/bits/sigstack.h
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ -- From: /usr/include/i386-gnu/bits/shm.h
+ function Get_Page_Size return int;
+ pragma Import (C, Get_Page_Size, "getpagesize");
+ -- Returns the size of a page
+
+ -- From /usr/include/i386-gnu/bits/mman.h
+ PROT_NONE : constant := 0;
+ PROT_READ : constant := 4;
+ PROT_WRITE : constant := 2;
+ PROT_EXEC : constant := 1;
+ PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+ PROT_ON : constant := PROT_NONE;
+ PROT_OFF : constant := PROT_ALL;
+
+ -- From /usr/include/i386-gnu/bits/mman.h
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ pragma Import (C, mprotect);
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ -- From: /usr/include/signal.h:
+ -- sigwait (__const sigset_t *__restrict __set, int *__restrict __sig)
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ -- From: /usr/include/pthread/pthread.h:
+ -- extern int pthread_kill (pthread_t thread, int signo);
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ -- From: /usr/include/i386-gnu/bits/sigthread.h
+ -- extern int pthread_sigmask (int __how, __const __sigset_t *__newmask,
+ -- __sigset_t *__oldmask) __THROW;
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ -- From: /usr/include/pthread/pthread.h and
+ -- /usr/include/pthread/pthreadtypes.h
+ 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_rwlockattr_init
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init");
+
+ function pthread_rwlockattr_destroy
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy");
+ PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0;
+ PTHREAD_RWLOCK_PREFER_WRITER_NP : constant := 1;
+ PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 2;
+
+ function pthread_rwlockattr_setkind_np
+ (attr : access pthread_rwlockattr_t;
+ pref : int) return int;
+ pragma Import
+ (C, pthread_rwlockattr_setkind_np, "pthread_rwlockattr_setkind_np");
+
+ function pthread_rwlock_init
+ (mutex : access pthread_rwlock_t;
+ attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init");
+
+ function pthread_rwlock_destroy
+ (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy");
+
+ function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock");
+
+ function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock");
+
+ function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_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 --
+ --------------------------
+ -- From /usr/include/pthread/pthreadtypes.h
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ -- GNU/Hurd does not support Thread Priority Protection or Thread
+ -- Priority Inheritance and lacks some pthread_mutexattr_* functions.
+ -- Replace them with dummy versions.
+ -- From: /usr/include/pthread/pthread.h
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import (C, pthread_mutexattr_setprotocol,
+ "pthread_mutexattr_setprotocol");
+
+ function pthread_mutexattr_getprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : access int) return int;
+ pragma Import (C, pthread_mutexattr_getprotocol,
+ "pthread_mutexattr_getprotocol");
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+
+ function pthread_mutexattr_getprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : access int) return int;
+
+ 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;
+
+ function pthread_attr_setscope
+ (attr : access pthread_attr_t;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_getscope
+ (attr : access pthread_attr_t;
+ contentionscope : access int) return int;
+ pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import (C, pthread_attr_setinheritsched,
+ "pthread_attr_setinheritsched");
+
+ function pthread_attr_getinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : access int) return int;
+ pragma Import (C, pthread_attr_getinheritsched,
+ "pthread_attr_getinheritsched");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy, "pthread_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");
+
+ -- From: /usr/include/pthread/pthread.h
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ -- From /usr/include/i386-gnu/bits/sched.h
+ CPU_SETSIZE : constant := 1_024;
+
+ type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
+ for bit_field'Size use CPU_SETSIZE;
+ pragma Pack (bit_field);
+ pragma Convention (C, bit_field);
+
+ type cpu_set_t is record
+ bits : bit_field;
+ end record;
+ pragma Convention (C, cpu_set_t);
+
+private
+
+ type sigset_t is array (1 .. 4) of unsigned;
+
+ -- In GNU/Hurd the component sa_handler turns out to
+ -- be one a union type, and the selector is a macro:
+ -- #define sa_handler __sigaction_handler.sa_handler
+ -- #define sa_sigaction __sigaction_handler.sa_sigaction
+
+ -- Should we add a signal_context type here ?
+ -- How could it be done independent of the CPU architecture ?
+ -- sigcontext type is opaque, so it is architecturally neutral.
+ -- It is always passed as an access type, so define it as an empty record
+ -- since the contents are not used anywhere.
+ type struct_sigcontext is null record;
+ pragma Convention (C, struct_sigcontext);
+
+ 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);
+
+ -- From: /usr/include/pthread/pthreadtypes.h:
+ -- typedef struct __pthread_attr pthread_attr_t;
+ -- /usr/include/i386-gnu/bits/thread-attr.h: struct __pthread_attr...
+ -- /usr/include/pthread/pthreadtypes.h: enum __pthread_contentionscope
+ -- enum __pthread_detachstate detachstate;
+ -- enum __pthread_inheritsched inheritsched;
+ -- enum __pthread_contentionscope contentionscope;
+ -- Not used: schedpolicy : int;
+ type pthread_attr_t is record
+ schedparam : struct_sched_param;
+ stackaddr : System.Address;
+ stacksize : size_t;
+ guardsize : size_t;
+ detachstate : int;
+ inheritsched : int;
+ contentionscope : int;
+ schedpolicy : int;
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ -- From: /usr/include/pthread/pthreadtypes.h:
+ -- typedef struct __pthread_condattr pthread_condattr_t;
+ -- From: /usr/include/i386-gnu/bits/condition-attr.h:
+ -- struct __pthread_condattr {
+ -- enum __pthread_process_shared pshared;
+ -- __Clockid_T Clock;}
+ -- From: /usr/include/pthread/pthreadtypes.h:
+ -- enum __pthread_process_shared
+ type pthread_condattr_t is record
+ pshared : int;
+ clock : clockid_t;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ -- From: /usr/include/pthread/pthreadtypes.h:
+ -- typedef struct __pthread_mutexattr pthread_mutexattr_t; and
+ -- /usr/include/i386-gnu/bits/mutex-attr.h
+ -- struct __pthread_mutexattr {
+ -- int prioceiling;
+ -- enum __pthread_mutex_protocol protocol;
+ -- enum __pthread_process_shared pshared;
+ -- enum __pthread_mutex_type mutex_type;};
+ type pthread_mutexattr_t is record
+ prioceiling : int;
+ protocol : int;
+ pshared : int;
+ mutex_type : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ -- From: /usr/include/pthread/pthreadtypes.h
+ -- typedef struct __pthread_mutex pthread_mutex_t; and
+ -- /usr/include/i386-gnu/bits/mutex.h:
+ -- struct __pthread_mutex {
+ -- __pthread_spinlock_t __held;
+ -- __pthread_spinlock_t __lock;
+ -- /* in cthreads, mutex_init does not initialized the third
+ -- pointer, as such, we cannot rely on its value for anything. */
+ -- char *cthreadscompat1;
+ -- struct __pthread *__queue;
+ -- struct __pthread_mutexattr *attr;
+ -- void *data;
+ -- /* up to this point, we are completely compatible with cthreads
+ -- and what libc expects. */
+ -- void *owner;
+ -- unsigned locks;
+ -- /* if null then the default attributes apply. */
+ -- };
+
+ type pthread_mutex_t is record
+ held : int;
+ lock : int;
+ cthreadcompat : System.Address;
+ queue : System.Address;
+ attr : System.Address;
+ data : System.Address;
+ owner : System.Address;
+ locks : unsigned;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+ -- pointer needed?
+ -- type pthread_mutex_t_ptr is access pthread_mutex_t;
+
+ -- From: /usr/include/pthread/pthreadtypes.h:
+ -- typedef struct __pthread_cond pthread_cond_t;
+ -- typedef struct __pthread_condattr pthread_condattr_t;
+ -- /usr/include/i386-gnu/bits/condition.h:struct __pthread_cond{}
+ -- pthread_condattr_t: see above!
+ -- /usr/include/i386-gnu/bits/condition.h:
+ -- struct __pthread_condimpl *__impl;
+
+ type pthread_cond_t is record
+ lock : int;
+ queue : System.Address;
+ condattr : System.Address;
+ impl : System.Address;
+ data : System.Address;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ -- From: /usr/include/pthread/pthreadtypes.h:
+ -- typedef __pthread_key pthread_key_t; and
+ -- /usr/include/i386-gnu/bits/thread-specific.h:
+ -- typedef int __pthread_key;
+
+ type pthread_key_t is new int;
+
+ -- From: /usr/include/i386-gnu/bits/rwlock-attr.h:
+ -- struct __pthread_rwlockattr {
+ -- enum __pthread_process_shared pshared; };
+
+ type pthread_rwlockattr_t is record
+ pshared : int;
+ end record;
+ pragma Convention (C, pthread_rwlockattr_t);
+
+ -- From: /usr/include/i386-gnu/bits/rwlock.h:
+ -- struct __pthread_rwlock {
+ -- __pthread_spinlock_t __held;
+ -- __pthread_spinlock_t __lock;
+ -- int readers;
+ -- struct __pthread *readerqueue;
+ -- struct __pthread *writerqueue;
+ -- struct __pthread_rwlockattr *__attr;
+ -- void *__data; };
+
+ type pthread_rwlock_t is record
+ held : int;
+ lock : int;
+ readers : int;
+ readerqueue : System.Address;
+ writerqueue : System.Address;
+ attr : pthread_rwlockattr_t;
+ data : int;
+ end record;
+ pragma Convention (C, pthread_rwlock_t);
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2010, 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- --
+-- 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 a DCE version of this package.
+-- Currently HP-UX and SNI use this file
+
+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.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+with Interfaces.C; use Interfaces.C;
+
+package body System.OS_Interface is
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int
+ is
+ Result : int;
+
+ begin
+ Result := sigwait (set);
+
+ if Result = -1 then
+ sig.all := 0;
+ return errno;
+ end if;
+
+ sig.all := Signal (Result);
+ return 0;
+ end sigwait;
+
+ -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int is
+ pragma Unreferenced (thread, sig);
+ begin
+ return 0;
+ end pthread_kill;
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ -- For all following functions, DCE Threads has a non standard behavior.
+ -- It sets errno but the standard Posix requires it to be returned.
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int
+ is
+ function pthread_mutexattr_create
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create");
+
+ begin
+ if pthread_mutexattr_create (attr) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutexattr_init;
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int
+ is
+ function pthread_mutexattr_delete
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete");
+
+ begin
+ if pthread_mutexattr_delete (attr) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutexattr_destroy;
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int
+ is
+ function pthread_mutex_init_base
+ (mutex : access pthread_mutex_t;
+ attr : pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init");
+
+ begin
+ if pthread_mutex_init_base (mutex, attr.all) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutex_init;
+
+ function pthread_mutex_destroy
+ (mutex : access pthread_mutex_t) return int
+ is
+ function pthread_mutex_destroy_base
+ (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy");
+
+ begin
+ if pthread_mutex_destroy_base (mutex) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutex_destroy;
+
+ function pthread_mutex_lock
+ (mutex : access pthread_mutex_t) return int
+ is
+ function pthread_mutex_lock_base
+ (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock");
+
+ begin
+ if pthread_mutex_lock_base (mutex) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutex_lock;
+
+ function pthread_mutex_unlock
+ (mutex : access pthread_mutex_t) return int
+ is
+ function pthread_mutex_unlock_base
+ (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock");
+
+ begin
+ if pthread_mutex_unlock_base (mutex) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutex_unlock;
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int
+ is
+ function pthread_condattr_create
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_create, "pthread_condattr_create");
+
+ begin
+ if pthread_condattr_create (attr) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_condattr_init;
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int
+ is
+ function pthread_condattr_delete
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete");
+
+ begin
+ if pthread_condattr_delete (attr) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_condattr_destroy;
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int
+ is
+ function pthread_cond_init_base
+ (cond : access pthread_cond_t;
+ attr : pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init_base, "pthread_cond_init");
+
+ begin
+ if pthread_cond_init_base (cond, attr.all) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_cond_init;
+
+ function pthread_cond_destroy
+ (cond : access pthread_cond_t) return int
+ is
+ function pthread_cond_destroy_base
+ (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy");
+
+ begin
+ if pthread_cond_destroy_base (cond) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_cond_destroy;
+
+ function pthread_cond_signal
+ (cond : access pthread_cond_t) return int
+ is
+ function pthread_cond_signal_base
+ (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal");
+
+ begin
+ if pthread_cond_signal_base (cond) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_cond_signal;
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int
+ is
+ function pthread_cond_wait_base
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait");
+
+ begin
+ if pthread_cond_wait_base (cond, mutex) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_cond_wait;
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int
+ is
+ function pthread_cond_timedwait_base
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
+
+ begin
+ if pthread_cond_timedwait_base (cond, mutex, abstime) /= 0 then
+ return (if errno = EAGAIN then ETIMEDOUT else errno);
+ else
+ return 0;
+ end if;
+ end pthread_cond_timedwait;
+
+ ----------------------------
+ -- POSIX.1c Section 13 --
+ ----------------------------
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int
+ is
+ function pthread_setscheduler
+ (thread : pthread_t;
+ policy : int;
+ priority : int) return int;
+ pragma Import (C, pthread_setscheduler, "pthread_setscheduler");
+
+ begin
+ if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_setschedparam;
+
+ function sched_yield return int is
+ procedure pthread_yield;
+ pragma Import (C, pthread_yield, "pthread_yield");
+ begin
+ pthread_yield;
+ return 0;
+ end sched_yield;
+
+ -----------------------------
+ -- P1003.1c - Section 16 --
+ -----------------------------
+
+ function pthread_attr_init
+ (attributes : access pthread_attr_t) return int
+ is
+ function pthread_attr_create
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_create, "pthread_attr_create");
+
+ begin
+ if pthread_attr_create (attributes) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_attr_init;
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int
+ is
+ function pthread_attr_delete
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_delete, "pthread_attr_delete");
+
+ begin
+ if pthread_attr_delete (attributes) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_attr_destroy;
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int
+ is
+ function pthread_attr_setstacksize_base
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize_base,
+ "pthread_attr_setstacksize");
+
+ begin
+ if pthread_attr_setstacksize_base (attr, stacksize) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_attr_setstacksize;
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int
+ is
+ function pthread_create_base
+ (thread : access pthread_t;
+ attributes : pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create_base, "pthread_create");
+
+ begin
+ if pthread_create_base
+ (thread, attributes.all, start_routine, arg) /= 0
+ then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_create;
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int
+ is
+ function pthread_setspecific_base
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific_base, "pthread_setspecific");
+
+ begin
+ if pthread_setspecific_base (key, value) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_setspecific;
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address is
+ function pthread_getspecific_base
+ (key : pthread_key_t;
+ value : access System.Address) return int;
+ pragma Import (C, pthread_getspecific_base, "pthread_getspecific");
+ Addr : aliased System.Address;
+
+ begin
+ if pthread_getspecific_base (key, Addr'Access) /= 0 then
+ return System.Null_Address;
+ else
+ return Addr;
+ end if;
+ end pthread_getspecific;
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int
+ is
+ function pthread_keycreate
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_keycreate, "pthread_keycreate");
+
+ begin
+ if pthread_keycreate (key, destructor) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_key_create;
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ function intr_attach (sig : int; handler : isr_address) return long is
+ function c_signal (sig : int; handler : isr_address) return long;
+ pragma Import (C, c_signal, "signal");
+ begin
+ return c_signal (sig, handler);
+ end intr_attach;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2012, 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 --
+-- <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 HP-UX version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lcma");
+
+ subtype int is Interfaces.C.int;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIME : constant := 52;
+ ETIMEDOUT : constant := 238;
+
+ FUNC_ERR : constant := -1;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 44;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGVTALRM : constant := 20; -- virtual timer alarm
+ SIGPROF : constant := 21; -- profiling timer alarm
+ SIGIO : constant := 22; -- asynchronous I/O
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGWINCH : constant := 23; -- window size change
+ SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 25; -- user stop requested from tty
+ SIGCONT : constant := 26; -- stopped process has been continued
+ SIGTTIN : constant := 27; -- background tty read attempted
+ SIGTTOU : constant := 28; -- background tty write attempted
+ SIGURG : constant := 29; -- urgent condition on IO channel
+ SIGLOST : constant := 30; -- remote lock lost (NFS)
+ SIGDIL : constant := 32; -- DIL signal
+ SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit)
+ SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit)
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Note: on other targets, we usually use SIGABRT, but on HP/UX, it
+ -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP);
+
+ Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
+
+ type sigset_t is private;
+
+ type isr_address is access procedure (sig : int);
+ pragma Convention (C, isr_address);
+
+ function intr_attach (sig : int; handler : isr_address) return long;
+
+ Intr_Attach_Reset : constant Boolean := True;
+ -- True if intr_attach is reset after an interrupt handler is called
+
+ 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 Signal_Handler is access procedure (signo : Signal);
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_RESTART : constant := 16#40#;
+ SA_SIGINFO : constant := 16#10#;
+ SA_ONSTACK : constant := 16#01#;
+
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+ SIG_ERR : constant := -1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ type timespec is private;
+
+ function nanosleep (rqtp, rmtp : access timespec) return int;
+ pragma Import (C, nanosleep);
+
+ type clockid_t is new int;
+
+ function Clock_Gettime
+ (Clock_Id : clockid_t; Tp : access timespec) return int;
+ pragma Import (C, Clock_Gettime);
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 1;
+ SCHED_OTHER : constant := 2;
+
+ -------------
+ -- 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 private;
+ subtype Thread_Id is 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;
+
+ -- Read/Write lock not supported on HPUX. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ subtype pthread_rwlock_t is pthread_mutex_t;
+ subtype pthread_rwlockattr_t is pthread_mutexattr_t;
+
+ -----------
+ -- Stack --
+ -----------
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- This is a dummy procedure to share some GNULLI files
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t) return int;
+ pragma Import (C, sigwait, "cma_sigwait");
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Inline (sigwait);
+ -- DCE_THREADS has a nonstandard sigwait
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Inline (pthread_kill);
+ -- DCE_THREADS doesn't have pthread_kill
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ -- DCE THREADS does not have pthread_sigmask. Instead, it uses sigprocmask
+ -- to do the signal handling when the thread library is sucked in.
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ -- DCE_THREADS has a nonstandard pthread_mutexattr_init
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ -- DCE_THREADS has a nonstandard pthread_mutexattr_destroy
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ -- DCE_THREADS has a nonstandard pthread_mutex_init
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ -- DCE_THREADS has a nonstandard pthread_mutex_destroy
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_mutex_lock);
+ -- DCE_THREADS has nonstandard pthread_mutex_lock
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_mutex_unlock);
+ -- DCE_THREADS has nonstandard pthread_mutex_lock
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ -- DCE_THREADS has nonstandard pthread_condattr_init
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ -- DCE_THREADS has nonstandard pthread_condattr_destroy
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ -- DCE_THREADS has nonstandard pthread_cond_init
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ -- DCE_THREADS has nonstandard pthread_cond_destroy
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Inline (pthread_cond_signal);
+ -- DCE_THREADS has nonstandard pthread_cond_signal
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_cond_wait);
+ -- DCE_THREADS has a nonstandard pthread_cond_wait
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Inline (pthread_cond_timedwait);
+ -- DCE_THREADS has a nonstandard pthread_cond_timedwait
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ type struct_sched_param is record
+ sched_priority : int; -- scheduling priority
+ end record;
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ pragma Inline (pthread_setschedparam);
+ -- DCE_THREADS has a nonstandard pthread_setschedparam
+
+ function sched_yield return int;
+ pragma Inline (sched_yield);
+ -- DCE_THREADS has a nonstandard sched_yield
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init (attributes : access pthread_attr_t) return int;
+ pragma Inline (pthread_attr_init);
+ -- DCE_THREADS has a nonstandard pthread_attr_init
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Inline (pthread_attr_destroy);
+ -- DCE_THREADS has a nonstandard pthread_attr_destroy
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Inline (pthread_attr_setstacksize);
+ -- DCE_THREADS has a nonstandard 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 Inline (pthread_create);
+ -- DCE_THREADS has a nonstandard pthread_create
+
+ procedure pthread_detach (thread : access pthread_t);
+ pragma Import (C, pthread_detach);
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Inline (pthread_setspecific);
+ -- DCE_THREADS has a nonstandard pthread_setspecific
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Inline (pthread_getspecific);
+ -- DCE_THREADS has a nonstandard 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 Inline (pthread_key_create);
+ -- DCE_THREADS has a nonstandard pthread_key_create
+
+private
+
+ type array_type_1 is array (Integer range 0 .. 7) of unsigned_long;
+ type sigset_t is record
+ X_X_sigbits : array_type_1;
+ end record;
+ pragma Convention (C, sigset_t);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ CLOCK_REALTIME : constant clockid_t := 1;
+
+ type cma_t_address is new System.Address;
+
+ type cma_t_handle is record
+ field1 : cma_t_address;
+ field2 : Short_Integer;
+ field3 : Short_Integer;
+ end record;
+ for cma_t_handle'Size use 64;
+
+ type pthread_attr_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_attr_t);
+
+ type pthread_condattr_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_condattr_t);
+
+ type pthread_mutexattr_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_mutexattr_t);
+
+ type pthread_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_t);
+
+ type pthread_mutex_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_mutex_t);
+
+ type pthread_cond_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1991-2017, Florida State University --
+-- 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 --
+-- <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 a HPUX 11.0 (Native THREADS) version of this package
+
+-- This package encapsulates all direct interfaces to OS services that are
+-- needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthread");
+
+ subtype int is Interfaces.C.int;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIMEDOUT : constant := 238;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 44;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGVTALRM : constant := 20; -- virtual timer alarm
+ SIGPROF : constant := 21; -- profiling timer alarm
+ SIGIO : constant := 22; -- asynchronous I/O
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGWINCH : constant := 23; -- window size change
+ SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 25; -- user stop requested from tty
+ SIGCONT : constant := 26; -- stopped process has been continued
+ SIGTTIN : constant := 27; -- background tty read attempted
+ SIGTTOU : constant := 28; -- background tty write attempted
+ SIGURG : constant := 29; -- urgent condition on IO channel
+ SIGLOST : constant := 30; -- remote lock lost (NFS)
+ SIGDIL : constant := 32; -- DIL signal
+ SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit)
+ SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit)
+ SIGCANCEL : constant := 35; -- used for pthread cancellation.
+ SIGGFAULT : constant := 36; -- Graphics framebuffer fault
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Note: on other targets, we usually use SIGABRT, but on HPUX, it
+ -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM.
+ -- Do we use SIGTERM or SIGABRT???
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGABRT, SIGPIPE, SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF,
+ SIGALRM, SIGVTALRM, SIGIO, SIGCHLD);
+
+ Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
+
+ type sigset_t is private;
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_SIGINFO : constant := 16#10#;
+ SA_ONSTACK : constant := 16#01#;
+
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ 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);
+
+ type struct_timezone is record
+ tz_minuteswest : int;
+ tz_dsttime : int;
+ end record;
+ pragma Convention (C, struct_timezone);
+ type struct_timezone_ptr is access all struct_timezone;
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 1;
+ SCHED_OTHER : constant := 2;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ pragma Import (C, lwp_self, "_lwp_self");
+
+ -------------
+ -- 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 private;
+ subtype Thread_Id is 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 := 16#de#;
+
+ PTHREAD_SCOPE_PROCESS : constant := 2;
+ PTHREAD_SCOPE_SYSTEM : constant := 1;
+
+ -- Read/Write lock not supported on HPUX. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ 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;
+ pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
+ -- The alternate signal stack for stack overflows
+
+ Alternate_Stack_Size : constant := 128 * 1024;
+ -- 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 Address;
+ pragma Inline (Get_Stack_Base);
+ -- Returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ 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;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 16#100#;
+ PTHREAD_PRIO_PROTECT : constant := 16#200#;
+ PTHREAD_PRIO_INHERIT : constant := 16#400#;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import (C, pthread_mutexattr_setprotocol);
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import (C, pthread_mutexattr_setprioceiling);
+
+ type Array_7_Int is array (0 .. 6) of int;
+ type struct_sched_param is record
+ sched_priority : int;
+ sched_reserved : Array_7_Int;
+ end record;
+
+ 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;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import (C, pthread_attr_setinheritsched);
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, 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_system");
+
+ 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);
+
+ 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_system");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type unsigned_int_array_8 is array (0 .. 7) of unsigned;
+ type sigset_t is record
+ sigset : unsigned_int_array_8;
+ end record;
+ pragma Convention (C_Pass_By_Copy, sigset_t);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type pthread_attr_t is new int;
+ type pthread_condattr_t is new int;
+ type pthread_mutexattr_t is new int;
+ type pthread_t is new int;
+
+ type short_array is array (Natural range <>) of short;
+ type int_array is array (Natural range <>) of int;
+
+ type pthread_mutex_t is record
+ m_short : short_array (0 .. 1);
+ m_int : int;
+ m_int1 : int_array (0 .. 3);
+ m_pad : int;
+
+ m_ptr : int;
+ -- actually m_ptr is a void*, and on 32 bit ABI, m_pad is added so that
+ -- this field takes 64 bits. On 64 bit ABI, m_pad is gone, and m_ptr is
+ -- a 64 bit void*. Assume int'Size = 32.
+
+ m_int2 : int_array (0 .. 1);
+ m_int3 : int_array (0 .. 3);
+ m_short2 : short_array (0 .. 1);
+ m_int4 : int_array (0 .. 4);
+ m_int5 : int_array (0 .. 1);
+ end record;
+ for pthread_mutex_t'Alignment use System.Address'Alignment;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is record
+ c_short : short_array (0 .. 1);
+ c_int : int;
+ c_int1 : int_array (0 .. 3);
+ m_pad : int;
+ m_ptr : int; -- see comment in pthread_mutex_t
+ c_int2 : int_array (0 .. 1);
+ c_int3 : int_array (0 .. 1);
+ c_int4 : int_array (0 .. 1);
+ end record;
+ for pthread_cond_t'Alignment use System.Address'Alignment;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2016, 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 --
+-- <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 GNU/kFreeBSD (POSIX Threads) version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package
+
+with Interfaces.C;
+with Unchecked_Conversion;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthread");
+
+ subtype int is Interfaces.C.int;
+ subtype char is Interfaces.C.char;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 35;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 60;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 128;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD)
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (
+ SIGTRAP,
+ -- To enable debugging on multithreaded applications, mark SIGTRAP to
+ -- be kept unmasked.
+
+ SIGBUS,
+
+ SIGTTIN, SIGTTOU, SIGTSTP,
+ -- Keep these three signals unmasked so that background processes
+ -- and IO behaves as normal "C" applications
+
+ SIGPROF,
+ -- To avoid confusing the profiler
+
+ SIGKILL, SIGSTOP,
+ -- These two signals actually cannot be masked;
+ -- POSIX simply won't allow it.
+
+ SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG);
+ -- These three signals are used by GNU/LinuxThreads starting from
+ -- glibc 2.1 (future 2.2).
+
+ Reserved : constant Signal_Set :=
+ -- I am not sure why the following signal is reserved.
+ -- I guess they are not supported by this version of GNU/kFreeBSD.
+ (0 .. 0 => SIGVTALRM);
+
+ 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");
+
+ -- sigcontext is architecture dependent, so define it private
+ type struct_sigcontext is private;
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_flags : int;
+ sa_mask : sigset_t;
+ end record;
+ pragma Convention (C, struct_sigaction);
+
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ SA_SIGINFO : constant := 16#0040#;
+ SA_ONSTACK : constant := 16#0001#;
+
+ 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 (i.e SCHED_RR is supported)
+
+ type timespec is private;
+
+ function nanosleep (rqtp, rmtp : access timespec) return int;
+ pragma Import (C, nanosleep, "nanosleep");
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ 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_FIFO : constant := 1;
+ SCHED_OTHER : constant := 2;
+ SCHED_RR : constant := 3;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority.
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ -- lwp_self does not exist on this thread library, revert to pthread_self
+ -- which is the closest approximation (with getpid). This function is
+ -- needed to share 7staprop.adb across POSIX-like targets.
+ pragma Import (C, lwp_self, "pthread_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, Thread_Body);
+
+ type pthread_t is new unsigned_long;
+ subtype Thread_Id is pthread_t;
+
+ function To_pthread_t is new Unchecked_Conversion
+ (unsigned_long, pthread_t);
+
+ type pthread_mutex_t is limited private;
+ type pthread_cond_t is limited private;
+ type pthread_attr_t is limited private;
+ type pthread_mutexattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ PTHREAD_CREATE_DETACHED : constant := 1;
+ PTHREAD_CREATE_JOINABLE : constant := 0;
+
+ PTHREAD_SCOPE_PROCESS : constant := 0;
+ PTHREAD_SCOPE_SYSTEM : constant := 2;
+
+ -- Read/Write lock not supported on kfreebsd. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ 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_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ 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_NONE;
+ 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;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
+
+ function pthread_mutexattr_getprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : access int) return int;
+ pragma Import
+ (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol");
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprioceiling,
+ "pthread_mutexattr_setprioceiling");
+
+ function pthread_mutexattr_getprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : access int) return int;
+ pragma Import
+ (C, pthread_mutexattr_getprioceiling,
+ "pthread_mutexattr_getprioceiling");
+
+ 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;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_getscope
+ (attr : access pthread_attr_t;
+ contentionscope : access int) return int;
+ pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import
+ (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
+
+ function pthread_attr_getinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : access int) return int;
+ pragma Import
+ (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import
+ (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy");
+
+ function sched_yield return int;
+ pragma Import (C, sched_yield, "sched_yield");
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "pthread_attr_init");
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Import
+ (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ CPU_SETSIZE : constant := 1_024;
+
+ type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
+ for bit_field'Size use CPU_SETSIZE;
+ pragma Pack (bit_field);
+ pragma Convention (C, bit_field);
+
+ type cpu_set_t is record
+ bits : bit_field;
+ end record;
+ pragma Convention (C, cpu_set_t);
+
+ function pthread_setaffinity_np
+ (thread : pthread_t;
+ cpusetsize : size_t;
+ cpuset : access cpu_set_t) return int;
+ pragma Import (C, pthread_setaffinity_np, "__gnat_pthread_setaffinity_np");
+
+private
+
+ type sigset_t is array (1 .. 4) of unsigned;
+
+ -- In FreeBSD the component sa_handler turns out to
+ -- be one a union type, and the selector is a macro:
+ -- #define sa_handler __sigaction_u._handler
+ -- #define sa_sigaction __sigaction_u._sigaction
+
+ -- Should we add a signal_context type here ?
+ -- How could it be done independent of the CPU architecture ?
+ -- sigcontext type is opaque, so it is architecturally neutral.
+ -- It is always passed as an access type, so define it as an empty record
+ -- since the contents are not used anywhere.
+ type struct_sigcontext is null record;
+ pragma Convention (C, struct_sigcontext);
+
+ 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 clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type pthread_attr_t is record
+ detachstate : int;
+ schedpolicy : int;
+ schedparam : struct_sched_param;
+ inheritsched : int;
+ scope : int;
+ guardsize : size_t;
+ stackaddr_set : int;
+ stackaddr : System.Address;
+ stacksize : size_t;
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ dummy : int;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ mutexkind : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type struct_pthread_fast_lock is record
+ status : long;
+ spinlock : int;
+ end record;
+ pragma Convention (C, struct_pthread_fast_lock);
+
+ type pthread_mutex_t is record
+ m_reserved : int;
+ m_count : int;
+ m_owner : System.Address;
+ m_kind : int;
+ m_lock : struct_pthread_fast_lock;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is array (0 .. 47) of unsigned_char;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1991-2017, Florida State University --
+-- 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 --
+-- <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 a GNU/Linux (GNU/LinuxThreads) version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+with Interfaces.C;
+with System.Linux;
+with System.OS_Constants;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthread");
+ pragma Linker_Options ("-lrt");
+ -- Needed for clock_getres with glibc versions prior to 2.17
+
+ subtype int is Interfaces.C.int;
+ subtype char is Interfaces.C.char;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := System.Linux.EAGAIN;
+ EINTR : constant := System.Linux.EINTR;
+ EINVAL : constant := System.Linux.EINVAL;
+ ENOMEM : constant := System.Linux.ENOMEM;
+ EPERM : constant := System.Linux.EPERM;
+ ETIMEDOUT : constant := System.Linux.ETIMEDOUT;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 63;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := System.Linux.SIGHUP;
+ SIGINT : constant := System.Linux.SIGINT;
+ SIGQUIT : constant := System.Linux.SIGQUIT;
+ SIGILL : constant := System.Linux.SIGILL;
+ SIGTRAP : constant := System.Linux.SIGTRAP;
+ SIGIOT : constant := System.Linux.SIGIOT;
+ SIGABRT : constant := System.Linux.SIGABRT;
+ SIGFPE : constant := System.Linux.SIGFPE;
+ SIGKILL : constant := System.Linux.SIGKILL;
+ SIGBUS : constant := System.Linux.SIGBUS;
+ SIGSEGV : constant := System.Linux.SIGSEGV;
+ SIGPIPE : constant := System.Linux.SIGPIPE;
+ SIGALRM : constant := System.Linux.SIGALRM;
+ SIGTERM : constant := System.Linux.SIGTERM;
+ SIGUSR1 : constant := System.Linux.SIGUSR1;
+ SIGUSR2 : constant := System.Linux.SIGUSR2;
+ SIGCLD : constant := System.Linux.SIGCLD;
+ SIGCHLD : constant := System.Linux.SIGCHLD;
+ SIGPWR : constant := System.Linux.SIGPWR;
+ SIGWINCH : constant := System.Linux.SIGWINCH;
+ SIGURG : constant := System.Linux.SIGURG;
+ SIGPOLL : constant := System.Linux.SIGPOLL;
+ SIGIO : constant := System.Linux.SIGIO;
+ SIGLOST : constant := System.Linux.SIGLOST;
+ SIGSTOP : constant := System.Linux.SIGSTOP;
+ SIGTSTP : constant := System.Linux.SIGTSTP;
+ SIGCONT : constant := System.Linux.SIGCONT;
+ SIGTTIN : constant := System.Linux.SIGTTIN;
+ SIGTTOU : constant := System.Linux.SIGTTOU;
+ SIGVTALRM : constant := System.Linux.SIGVTALRM;
+ SIGPROF : constant := System.Linux.SIGPROF;
+ SIGXCPU : constant := System.Linux.SIGXCPU;
+ SIGXFSZ : constant := System.Linux.SIGXFSZ;
+ SIGUNUSED : constant := System.Linux.SIGUNUSED;
+ SIGSTKFLT : constant := System.Linux.SIGSTKFLT;
+ SIGLTHRRES : constant := System.Linux.SIGLTHRRES;
+ SIGLTHRCAN : constant := System.Linux.SIGLTHRCAN;
+ SIGLTHRDBG : constant := System.Linux.SIGLTHRDBG;
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this 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)
+
+ SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG);
+ -- These three signals are used by GNU/LinuxThreads starting from glibc
+ -- 2.1 (future 2.2).
+
+ Reserved : constant Signal_Set := (SIGVTALRM, SIGUNUSED);
+ -- Not clear why these two signals are reserved. Perhaps they are not
+ -- supported by this version of GNU/Linux ???
+
+ type sigset_t is private;
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ type union_type_3 is new String (1 .. 116);
+ type siginfo_t is record
+ si_signo : int;
+ si_code : int;
+ si_errno : int;
+ X_data : union_type_3;
+ end record;
+ pragma Convention (C, siginfo_t);
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ sa_restorer : System.Address;
+ end record;
+ pragma Convention (C, struct_sigaction);
+
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ type Machine_State is record
+ eip : unsigned_long;
+ ebx : unsigned_long;
+ esp : unsigned_long;
+ ebp : unsigned_long;
+ esi : unsigned_long;
+ edi : unsigned_long;
+ end record;
+ type Machine_State_Ptr is access all Machine_State;
+
+ SA_SIGINFO : constant := System.Linux.SA_SIGINFO;
+ SA_ONSTACK : constant := System.Linux.SA_ONSTACK;
+
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ subtype time_t is System.Linux.time_t;
+ subtype timespec is System.Linux.timespec;
+ subtype timeval is System.Linux.timeval;
+ subtype clockid_t is System.Linux.clockid_t;
+
+ 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;
+ -- 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");
+
+ PR_SET_NAME : constant := 15;
+ PR_GET_NAME : constant := 16;
+
+ function prctl
+ (option : int;
+ arg2, arg3, arg4, arg5 : unsigned_long := 0) return int;
+ pragma Import (C, prctl);
+
+ -------------
+ -- 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_rwlock_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_rwlockattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ PTHREAD_CREATE_DETACHED : constant := 1;
+
+ -----------
+ -- Stack --
+ -----------
+
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_flags : int;
+ ss_size : size_t;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
+ -- The alternate signal stack for stack overflows
+
+ Alternate_Stack_Size : constant := 16 * 1024;
+ -- This must be in keeping with init.c:__gnat_alternate_stack
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- This is a dummy procedure to share some GNULLI files
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_rwlockattr_init
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init");
+
+ function pthread_rwlockattr_destroy
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy");
+
+ PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0;
+ PTHREAD_RWLOCK_PREFER_WRITER_NP : constant := 1;
+ PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 2;
+
+ function pthread_rwlockattr_setkind_np
+ (attr : access pthread_rwlockattr_t;
+ pref : int) return int;
+ pragma Import
+ (C, pthread_rwlockattr_setkind_np, "pthread_rwlockattr_setkind_np");
+
+ function pthread_rwlock_init
+ (mutex : access pthread_rwlock_t;
+ attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init");
+
+ function pthread_rwlock_destroy
+ (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy");
+
+ function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock");
+
+ function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock");
+
+ function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import (C, pthread_mutexattr_setprotocol);
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import (C, pthread_mutexattr_setprioceiling);
+
+ type struct_sched_param is record
+ sched_priority : int; -- scheduling priority
+ end record;
+ pragma Convention (C, struct_sched_param);
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import
+ (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy");
+
+ function sched_yield return int;
+ pragma Import (C, sched_yield, "sched_yield");
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "pthread_attr_init");
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Import
+ (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ function lwp_self return System.Address;
+ pragma Import (C, lwp_self, "__gnat_lwp_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");
+
+ ----------------
+ -- Extensions --
+ ----------------
+
+ 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
+
+ function pthread_setaffinity_np
+ (thread : pthread_t;
+ cpusetsize : size_t;
+ cpuset : cpu_set_t_ptr) return int;
+ pragma Import (C, pthread_setaffinity_np, "pthread_setaffinity_np");
+ pragma Weak_External (pthread_setaffinity_np);
+ -- Use a weak symbol because this function may be available or not,
+ -- depending on the version of the system.
+
+ function pthread_attr_setaffinity_np
+ (attr : access pthread_attr_t;
+ cpusetsize : size_t;
+ cpuset : cpu_set_t_ptr) return int;
+ pragma Import (C, pthread_attr_setaffinity_np,
+ "pthread_attr_setaffinity_np");
+ pragma Weak_External (pthread_attr_setaffinity_np);
+ -- Use a weak symbol because this function may be available or not,
+ -- depending on the version of the system.
+
+private
+
+ type sigset_t is
+ array (0 .. OS_Constants.SIZEOF_sigset - 1) of unsigned_char;
+ pragma Convention (C, sigset_t);
+ for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+ pragma Warnings (Off);
+ for struct_sigaction use record
+ sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1;
+ sa_mask at Linux.sa_mask_pos range 0 .. 1023;
+ sa_flags at Linux.sa_flags_pos range 0 .. int'Size - 1;
+ end record;
+ -- We intentionally leave sa_restorer unspecified and let the compiler
+ -- append it after the last field, so disable corresponding warning.
+ pragma Warnings (On);
+
+ type pid_t is new int;
+
+ 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_rwlockattr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCKATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_rwlockattr_t);
+ for pthread_rwlockattr_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+ type pthread_rwlock_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCK_SIZE);
+ end record;
+ pragma Convention (C, pthread_rwlock_t);
+ for pthread_rwlock_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 Interfaces.Unsigned_64'Alignment;
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001-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- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Version of System.OS_Interface for LynxOS-178 (POSIX Threads)
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It may cause infinite loops and other problems.
+
+package body System.OS_Interface is
+
+ use Interfaces.C;
+
+ ------------------
+ -- Current_CPU --
+ ------------------
+
+ function Current_CPU return Multiprocessors.CPU is
+ begin
+ -- No multiprocessor support, always return the first CPU Id
+
+ return Multiprocessors.CPU'First;
+ end Current_CPU;
+
+ --------------------
+ -- Get_Affinity --
+ --------------------
+
+ function Get_Affinity (Id : Thread_Id) return Multiprocessors.CPU_Range is
+ pragma Unreferenced (Id);
+
+ begin
+ -- No multiprocessor support, always return Not_A_Specific_CPU
+
+ return Multiprocessors.Not_A_Specific_CPU;
+ end Get_Affinity;
+
+ ---------------
+ -- Get_CPU --
+ ---------------
+
+ function Get_CPU (Id : Thread_Id) return Multiprocessors.CPU is
+ pragma Unreferenced (Id);
+
+ begin
+ -- No multiprocessor support, always return the first CPU Id
+
+ return Multiprocessors.CPU'First;
+ end Get_CPU;
+
+ -------------------
+ -- Get_Page_Size --
+ -------------------
+
+ SC_PAGESIZE : constant := 17;
+ -- C macro to get pagesize value from sysconf
+
+ function sysconf (name : int) return long;
+ pragma Import (C, sysconf, "sysconf");
+
+ function Get_Page_Size return int is
+ begin
+ return int (sysconf (SC_PAGESIZE));
+ end Get_Page_Size;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F is negative due to a round-up, adjust for positive F value
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ -------------
+ -- sigwait --
+ -------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal)
+ return int
+ is
+ function sigwaitinfo
+ (set : access sigset_t;
+ info : System.Address) return Signal;
+ pragma Import (C, sigwaitinfo, "sigwaitinfo");
+
+ begin
+ sig.all := sigwaitinfo (set, Null_Address);
+
+ if sig.all = -1 then
+ return errno;
+ end if;
+
+ return 0;
+ end sigwait;
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1991-1994, Florida State University --
+-- 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 --
+-- <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 a LynxOS-178 Elf (POSIX-8 Threads) 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.Multiprocessors;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-mthreads");
+ -- Selects the POSIX 1.c runtime, rather than the non-threading runtime or
+ -- the deprecated legacy threads library.
+
+ subtype int is Interfaces.C.int;
+ 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;
+ subtype int64 is Interfaces.Integer_64;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIMEDOUT : constant := 60;
+ -- Error codes
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 63;
+ -- Max_Interrupt is the number of OS signals, as defined in:
+ --
+ -- /usr/include/sys/signal.h
+ --
+ -- The lowest numbered signal is 1, but 0 is a valid argument to some
+ -- library functions, e.g. kill(2). However, 0 is not just another signal:
+ -- For instance 'I in Signal' and similar should be used with caution.
+
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGBRK : constant := 6; -- break
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in future
+ SIGCORE : constant := 7; -- kill with core dump
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGPOLL : constant := 23; -- pollable event occurred
+ SIGTHREADKILL : constant := 24; -- Reserved by LynxOS runtime
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGLOST : constant := 29; -- SUN 4.1 compatibility
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGPRIO : constant := 32;
+ -- Sent to a process with its priority or group is changed
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort. SIGTERM
+ -- might be a good one.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGTHREADKILL);
+ Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO);
+
+ 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 struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_SIGINFO : constant := 16#80#;
+
+ SA_ONSTACK : constant := 16#00#;
+ -- SA_ONSTACK is not defined on LynxOS, but it is referred to in the POSIX
+ -- implementation of System.Interrupt_Management. Therefore we define a
+ -- dummy value of zero here so that setting this flag is a nop.
+
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ 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);
+
+ type struct_timezone is record
+ tz_minuteswest : int;
+ tz_dsttime : int;
+ end record;
+ pragma Convention (C, struct_timezone);
+ type struct_timezone_ptr is access all struct_timezone;
+
+ type struct_timeval is private;
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_RR : constant := 16#100_000#;
+ SCHED_FIFO : constant := 16#200_000#;
+ SCHED_OTHER : constant := 16#400_000#;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ type pthread_t is private;
+
+ function lwp_self return pthread_t;
+ pragma Import (C, lwp_self, "pthread_self");
+
+ -------------
+ -- 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);
+
+ subtype Thread_Id is 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_CREATE_JOINABLE : constant := 0;
+
+ PTHREAD_SCOPE_PROCESS : constant := 0; -- not supported by LynxOS178
+ PTHREAD_SCOPE_SYSTEM : constant := 1;
+
+ -- Read/Write lock not supported on LynxOS. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ 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");
+ -- Neither stack_t nor sigaltstack are available on LynxOS-178
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is 0)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- Returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ function Get_Page_Size return int;
+ -- Returns the size of a page in bytes
+
+ PROT_NONE : constant := 1;
+ PROT_READ : constant := 2;
+ PROT_WRITE : constant := 4;
+ PROT_EXEC : constant := 8;
+ 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;
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Inline (sigwait);
+ -- LynxOS has non standard sigwait
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ ----------------------------
+ -- POSIX.1c Section 11 --
+ ----------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import (C, pthread_mutexattr_setprotocol);
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import (C, pthread_mutexattr_setprioceiling);
+
+ type struct_sched_param is record
+ sched_priority : int;
+ 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;
+ contentionscope : int) return int is (0);
+ -- pthread_attr_setscope is not implemented in production mode
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import (C, pthread_attr_setinheritsched);
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, 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);
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize);
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific
+ (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer
+ ) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ ---------------------
+ -- Multiprocessors --
+ ---------------------
+
+ function Current_CPU return Multiprocessors.CPU;
+ -- Return the id of the current CPU
+
+ function Get_Affinity (Id : Thread_Id) return Multiprocessors.CPU_Range;
+ -- Return CPU affinity of the given thread (maybe Not_A_Specific_CPU)
+
+ function Get_CPU (Id : Thread_Id) return Multiprocessors.CPU;
+ -- Return the CPU in charge of the given thread (always a valid CPU)
+
+private
+
+ type sigset_t is array (1 .. 2) of long;
+ pragma Convention (C, sigset_t);
+
+ type pid_t is new long;
+
+ type time_t is new int64;
+
+ type suseconds_t is new int;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type struct_timeval is record
+ tv_sec : time_t;
+ tv_usec : suseconds_t;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ type st_attr is record
+ stksize : int;
+ prio : int;
+ inheritsched : int;
+ state : int;
+ sched : int;
+ detachstate : int;
+ guardsize : int;
+ end record;
+ pragma Convention (C, st_attr);
+ subtype st_attr_t is st_attr;
+
+ type pthread_attr_t is record
+ pthread_attr_magic : unsigned;
+ st : st_attr_t;
+ pthread_attr_scope : int;
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ cv_magic : unsigned;
+ cv_pshared : unsigned;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ m_flags : unsigned;
+ m_prio_c : int;
+ m_pshared : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type tid_t is new short;
+ type pthread_t is new tid_t;
+
+ type block_obj_t is record
+ b_head : int;
+ end record;
+ pragma Convention (C, block_obj_t);
+
+ type pthread_mutex_t is record
+ m_flags : unsigned;
+ m_owner : tid_t;
+ m_wait : block_obj_t;
+ m_prio_c : int;
+ m_oldprio : int;
+ m_count : int;
+ m_referenced : int;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+ type pthread_mutex_t_ptr is access all pthread_mutex_t;
+
+ type pthread_cond_t is record
+ cv_magic : unsigned;
+ cv_wait : block_obj_t;
+ cv_mutex : pthread_mutex_t_ptr;
+ cv_refcnt : int;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1991-2017, Florida State University --
+-- 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 --
+-- <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 a NT (native) version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by the tasking run-time (libgnarl). For non tasking
+-- oriented services consider declaring them into system-win32.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+with Interfaces.C.Strings;
+with System.Win32;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-mthreads");
+
+ subtype int is Interfaces.C.int;
+ subtype long is Interfaces.C.long;
+
+ subtype LARGE_INTEGER is System.Win32.LARGE_INTEGER;
+
+ -------------------
+ -- General Types --
+ -------------------
+
+ subtype PSZ is Interfaces.C.Strings.chars_ptr;
+
+ Null_Void : constant Win32.PVOID := System.Null_Address;
+
+ -------------------------
+ -- Handles for objects --
+ -------------------------
+
+ subtype Thread_Id is Win32.HANDLE;
+
+ -----------
+ -- Errno --
+ -----------
+
+ NO_ERROR : constant := 0;
+ FUNC_ERR : constant := -1;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGINT : constant := 2; -- interrupt (Ctrl-C)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGFPE : constant := 8; -- floating point exception
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGBREAK : constant := 21; -- break (Ctrl-Break)
+ SIGABRT : constant := 22; -- used by abort, replace SIGIOT in the future
+
+ type sigset_t is private;
+
+ type isr_address is access procedure (sig : int);
+ pragma Convention (C, isr_address);
+
+ function intr_attach (sig : int; handler : isr_address) return long;
+ pragma Import (C, intr_attach, "signal");
+
+ Intr_Attach_Reset : constant Boolean := True;
+ -- True if intr_attach is reset after an interrupt handler is called
+
+ procedure kill (sig : Signal);
+ pragma Import (C, kill, "raise");
+
+ ------------
+ -- Clock --
+ ------------
+
+ procedure QueryPerformanceFrequency
+ (lpPerformanceFreq : access LARGE_INTEGER);
+ pragma Import
+ (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency");
+
+ -- According to the spec, on XP and later than function cannot fail,
+ -- so we ignore the return value and import it as a procedure.
+
+ -------------
+ -- 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);
+
+ procedure SwitchToThread;
+ pragma Import (Stdcall, SwitchToThread, "SwitchToThread");
+
+ function GetThreadTimes
+ (hThread : Win32.HANDLE;
+ lpCreationTime : access Long_Long_Integer;
+ lpExitTime : access Long_Long_Integer;
+ lpKernelTime : access Long_Long_Integer;
+ lpUserTime : access Long_Long_Integer) return Win32.BOOL;
+ pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes");
+
+ -----------------------
+ -- Critical sections --
+ -----------------------
+
+ type CRITICAL_SECTION is private;
+
+ -------------------------------------------------------------
+ -- Thread Creation, Activation, Suspension And Termination --
+ -------------------------------------------------------------
+
+ type PTHREAD_START_ROUTINE is access function
+ (pThreadParameter : Win32.PVOID) return Win32.DWORD;
+ pragma Convention (Stdcall, PTHREAD_START_ROUTINE);
+
+ function To_PTHREAD_START_ROUTINE is new
+ Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);
+
+ function CreateThread
+ (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
+ dwStackSize : Win32.DWORD;
+ pStartAddress : PTHREAD_START_ROUTINE;
+ pParameter : Win32.PVOID;
+ dwCreationFlags : Win32.DWORD;
+ pThreadId : access Win32.DWORD) return Win32.HANDLE;
+ pragma Import (Stdcall, CreateThread, "CreateThread");
+
+ function BeginThreadEx
+ (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
+ dwStackSize : Win32.DWORD;
+ pStartAddress : PTHREAD_START_ROUTINE;
+ pParameter : Win32.PVOID;
+ dwCreationFlags : Win32.DWORD;
+ pThreadId : not null access Win32.DWORD) return Win32.HANDLE;
+ pragma Import (C, BeginThreadEx, "_beginthreadex");
+
+ Debug_Process : constant := 16#00000001#;
+ Debug_Only_This_Process : constant := 16#00000002#;
+ Create_Suspended : constant := 16#00000004#;
+ Detached_Process : constant := 16#00000008#;
+ Create_New_Console : constant := 16#00000010#;
+
+ Create_New_Process_Group : constant := 16#00000200#;
+
+ Create_No_window : constant := 16#08000000#;
+
+ Profile_User : constant := 16#10000000#;
+ Profile_Kernel : constant := 16#20000000#;
+ Profile_Server : constant := 16#40000000#;
+
+ Stack_Size_Param_Is_A_Reservation : constant := 16#00010000#;
+
+ function GetExitCodeThread
+ (hThread : Win32.HANDLE;
+ pExitCode : not null access Win32.DWORD) return Win32.BOOL;
+ pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread");
+
+ function ResumeThread (hThread : Win32.HANDLE) return Win32.DWORD;
+ pragma Import (Stdcall, ResumeThread, "ResumeThread");
+
+ function SuspendThread (hThread : Win32.HANDLE) return Win32.DWORD;
+ pragma Import (Stdcall, SuspendThread, "SuspendThread");
+
+ procedure ExitThread (dwExitCode : Win32.DWORD);
+ pragma Import (Stdcall, ExitThread, "ExitThread");
+
+ procedure EndThreadEx (dwExitCode : Win32.DWORD);
+ pragma Import (C, EndThreadEx, "_endthreadex");
+
+ function TerminateThread
+ (hThread : Win32.HANDLE;
+ dwExitCode : Win32.DWORD) return Win32.BOOL;
+ pragma Import (Stdcall, TerminateThread, "TerminateThread");
+
+ function GetCurrentThread return Win32.HANDLE;
+ pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread");
+
+ function GetCurrentProcess return Win32.HANDLE;
+ pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess");
+
+ function GetCurrentThreadId return Win32.DWORD;
+ pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId");
+
+ function TlsAlloc return Win32.DWORD;
+ pragma Import (Stdcall, TlsAlloc, "TlsAlloc");
+
+ function TlsGetValue (dwTlsIndex : Win32.DWORD) return Win32.PVOID;
+ pragma Import (Stdcall, TlsGetValue, "TlsGetValue");
+
+ function TlsSetValue
+ (dwTlsIndex : Win32.DWORD; pTlsValue : Win32.PVOID) return Win32.BOOL;
+ pragma Import (Stdcall, TlsSetValue, "TlsSetValue");
+
+ function TlsFree (dwTlsIndex : Win32.DWORD) return Win32.BOOL;
+ pragma Import (Stdcall, TlsFree, "TlsFree");
+
+ TLS_Nothing : constant := Win32.DWORD'Last;
+
+ procedure ExitProcess (uExitCode : Interfaces.C.unsigned);
+ pragma Import (Stdcall, ExitProcess, "ExitProcess");
+
+ function WaitForSingleObject
+ (hHandle : Win32.HANDLE;
+ dwMilliseconds : Win32.DWORD) return Win32.DWORD;
+ pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject");
+
+ function WaitForSingleObjectEx
+ (hHandle : Win32.HANDLE;
+ dwMilliseconds : Win32.DWORD;
+ fAlertable : Win32.BOOL) return Win32.DWORD;
+ pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx");
+
+ Wait_Infinite : constant := Win32.DWORD'Last;
+ WAIT_TIMEOUT : constant := 16#0000_0102#;
+ WAIT_FAILED : constant := 16#FFFF_FFFF#;
+
+ ------------------------------------
+ -- Semaphores, Events and Mutexes --
+ ------------------------------------
+
+ function CreateSemaphore
+ (pSemaphoreAttributes : access Win32.SECURITY_ATTRIBUTES;
+ lInitialCount : Interfaces.C.long;
+ lMaximumCount : Interfaces.C.long;
+ pName : PSZ) return Win32.HANDLE;
+ pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA");
+
+ function OpenSemaphore
+ (dwDesiredAccess : Win32.DWORD;
+ bInheritHandle : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
+ pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA");
+
+ function ReleaseSemaphore
+ (hSemaphore : Win32.HANDLE;
+ lReleaseCount : Interfaces.C.long;
+ pPreviousCount : access Win32.LONG) return Win32.BOOL;
+ pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore");
+
+ function CreateEvent
+ (pEventAttributes : access Win32.SECURITY_ATTRIBUTES;
+ bManualReset : Win32.BOOL;
+ bInitialState : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
+ pragma Import (Stdcall, CreateEvent, "CreateEventA");
+
+ function OpenEvent
+ (dwDesiredAccess : Win32.DWORD;
+ bInheritHandle : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
+ pragma Import (Stdcall, OpenEvent, "OpenEventA");
+
+ function SetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
+ pragma Import (Stdcall, SetEvent, "SetEvent");
+
+ function ResetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
+ pragma Import (Stdcall, ResetEvent, "ResetEvent");
+
+ function PulseEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
+ pragma Import (Stdcall, PulseEvent, "PulseEvent");
+
+ function CreateMutex
+ (pMutexAttributes : access Win32.SECURITY_ATTRIBUTES;
+ bInitialOwner : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
+ pragma Import (Stdcall, CreateMutex, "CreateMutexA");
+
+ function OpenMutex
+ (dwDesiredAccess : Win32.DWORD;
+ bInheritHandle : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
+ pragma Import (Stdcall, OpenMutex, "OpenMutexA");
+
+ function ReleaseMutex (hMutex : Win32.HANDLE) return Win32.BOOL;
+ pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex");
+
+ ---------------------------------------------------
+ -- Accessing properties of Threads and Processes --
+ ---------------------------------------------------
+
+ -----------------
+ -- Priorities --
+ -----------------
+
+ function SetThreadPriority
+ (hThread : Win32.HANDLE;
+ nPriority : Interfaces.C.int) return Win32.BOOL;
+ pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority");
+
+ function GetThreadPriority (hThread : Win32.HANDLE) return Interfaces.C.int;
+ pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority");
+
+ function SetPriorityClass
+ (hProcess : Win32.HANDLE;
+ dwPriorityClass : Win32.DWORD) return Win32.BOOL;
+ pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass");
+
+ procedure SetThreadPriorityBoost
+ (hThread : Win32.HANDLE;
+ DisablePriorityBoost : Win32.BOOL);
+ pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost");
+
+ Normal_Priority_Class : constant := 16#00000020#;
+ Idle_Priority_Class : constant := 16#00000040#;
+ High_Priority_Class : constant := 16#00000080#;
+ Realtime_Priority_Class : constant := 16#00000100#;
+
+ Thread_Priority_Idle : constant := -15;
+ Thread_Priority_Lowest : constant := -2;
+ Thread_Priority_Below_Normal : constant := -1;
+ Thread_Priority_Normal : constant := 0;
+ Thread_Priority_Above_Normal : constant := 1;
+ Thread_Priority_Highest : constant := 2;
+ Thread_Priority_Time_Critical : constant := 15;
+ Thread_Priority_Error_Return : constant := Interfaces.C.long'Last;
+
+private
+
+ type sigset_t is new Interfaces.C.unsigned_long;
+
+ type CRITICAL_SECTION is record
+ DebugInfo : System.Address;
+
+ LockCount : Long_Integer;
+ RecursionCount : Long_Integer;
+ OwningThread : Win32.HANDLE;
+ -- The above three fields control entering and exiting the critical
+ -- section for the resource.
+
+ LockSemaphore : Win32.HANDLE;
+ SpinCount : Win32.DWORD;
+ end record;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-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- --
+-- 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 version is for POSIX-like operating systems
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+with Interfaces.C; use Interfaces.C;
+package body System.OS_Interface is
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2009 Florida State University --
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+-- The GNARL files that were developed for RTEMS are maintained by On-Line --
+-- Applications Research Corporation (http://www.oarcorp.com) in coopera- --
+-- tion with Ada Core Technologies Inc. and Florida State University. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the RTEMS version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+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 Interfaces.C; use Interfaces.C;
+package body System.OS_Interface is
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to round-up, adjust for positive F value
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ -----------------
+ -- sigaltstack --
+ -----------------
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int is
+ pragma Unreferenced (ss);
+ pragma Unreferenced (oss);
+ begin
+ return 0;
+ end sigaltstack;
+
+ -----------------------------------
+ -- pthread_rwlockattr_setkind_np --
+ -----------------------------------
+
+ function pthread_rwlockattr_setkind_np
+ (attr : access pthread_rwlockattr_t;
+ pref : int) return int is
+ pragma Unreferenced (attr);
+ pragma Unreferenced (pref);
+ begin
+ return 0;
+ end pthread_rwlockattr_setkind_np;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1997-2016 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. --
+-- --
+-- The GNARL files that were developed for RTEMS are maintained by On-Line --
+-- Applications Research Corporation (http://www.oarcorp.com) in coopera- --
+-- tion with Ada Core Technologies Inc. and Florida State University. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the RTEMS version of this package.
+--
+-- RTEMS target names are of the form CPU-rtems.
+-- This implementation is designed to work on ALL RTEMS targets.
+-- The RTEMS implementation is primarily based upon the POSIX threads
+-- API but there are also bindings to GNAT/RTEMS support routines
+-- to insulate this code from C API specific details and, in some
+-- cases, obtain target architecture and BSP specific information
+-- that is unavailable at the time this package is built.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Preelaborate.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+with System.OS_Constants;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ -- This interface assumes that "unsigned" is a 32-bit entity. This
+ -- will correspond to RTEMS object ids.
+
+ subtype rtems_id is Interfaces.C.unsigned;
+
+ subtype int is Interfaces.C.int;
+ subtype char is Interfaces.C.char;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := System.OS_Constants.EAGAIN;
+ EINTR : constant := System.OS_Constants.EINTR;
+ EINVAL : constant := System.OS_Constants.EINVAL;
+ ENOMEM : constant := System.OS_Constants.ENOMEM;
+ ETIMEDOUT : constant := System.OS_Constants.ETIMEDOUT;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Num_HW_Interrupts : constant := 256;
+
+ Max_HW_Interrupt : constant := Num_HW_Interrupts - 1;
+ 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;
+
+ SIGXCPU : constant := 0; -- XCPU
+ 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
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+
+ SIGADAABORT : constant := SIGABRT;
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (SIGTRAP, SIGALRM, SIGEMT);
+ Reserved : constant Signal_Set := (1 .. 1 => SIGKILL);
+
+ 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 struct_sigaction is record
+ sa_flags : int;
+ sa_mask : sigset_t;
+ sa_handler : System.Address;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_SIGINFO : constant := 16#02#;
+
+ SA_ONSTACK : constant := 16#00#;
+ -- SA_ONSTACK is not defined on RTEMS, but it is referred to in the POSIX
+ -- implementation of System.Interrupt_Management. Therefore we define a
+ -- dummy value of zero here so that setting this flag is a nop.
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ 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 (i.e SCHED_RR is supported)
+
+ type timespec is private;
+
+ type clockid_t is new int;
+
+ CLOCK_REALTIME : constant clockid_t;
+ CLOCK_MONOTONIC : constant clockid_t;
+
+ 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);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+ SCHED_OTHER : constant := 0;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ -- lwp_self does not exist on this thread library, revert to pthread_self
+ -- which is the closest approximation (with getpid). This function is
+ -- needed to share 7staprop.adb across POSIX-like targets.
+ pragma Import (C, lwp_self, "pthread_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ type pthread_t is private;
+ subtype Thread_Id is pthread_t;
+
+ type pthread_mutex_t is limited private;
+ type pthread_rwlock_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_rwlockattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ No_Key : constant pthread_key_t;
+
+ PTHREAD_CREATE_DETACHED : constant := 0;
+
+ PTHREAD_SCOPE_PROCESS : constant := 0;
+ PTHREAD_SCOPE_SYSTEM : constant := 1;
+
+ -----------
+ -- Stack --
+ -----------
+
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_flags : int;
+ ss_size : size_t;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target.
+ -- This allows us to share s-osinte.adb between all the FSU/RTEMS
+ -- run time.
+ -- Note that this value can only be true if pthread_t has a complete
+ -- definition that corresponds exactly to the C header files.
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- returns the stack base of the specified thread.
+ -- Only call this function when Stack_Base_Available is True.
+
+ -- These two functions are only needed to share s-taprop.adb with
+ -- FSU threads.
+
+ function Get_Page_Size return int;
+ pragma Import (C, Get_Page_Size, "getpagesize");
+ -- Returns the size of a page
+
+ PROT_ON : constant := 0;
+ PROT_OFF : constant := 0;
+
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ pragma Import (C, mprotect);
+
+ -----------------------------------------
+ -- Nonstandard Thread Initialization --
+ -----------------------------------------
+
+ procedure pthread_init;
+ -- FSU_THREADS requires pthread_init, which is nonstandard
+ -- and this should be invoked during the elaboration of s-taprop.adb
+ --
+ -- RTEMS does not require this so we provide an empty Ada body.
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ ----------------------------
+ -- POSIX.1c Section 11 --
+ ----------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_rwlockattr_init
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init");
+
+ function pthread_rwlockattr_destroy
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy");
+
+ PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0;
+ PTHREAD_RWLOCK_PREFER_WRITER_NP : constant := 1;
+ PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 2;
+
+ function pthread_rwlockattr_setkind_np
+ (attr : access pthread_rwlockattr_t;
+ pref : int) return int;
+
+ function pthread_rwlock_init
+ (mutex : access pthread_rwlock_t;
+ attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init");
+
+ function pthread_rwlock_destroy
+ (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy");
+
+ function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock");
+
+ function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock");
+
+ function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_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_NONE : constant := 0;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import (C, pthread_mutexattr_setprotocol);
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprioceiling,
+ "pthread_mutexattr_setprioceiling");
+
+ type struct_sched_param is record
+ sched_priority : int;
+ ss_low_priority : int;
+ ss_replenish_period : timespec;
+ ss_initial_budget : timespec;
+ sched_ss_max_repl : int;
+ 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;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import (C, pthread_attr_setinheritsched);
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy);
+
+ function pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : int) return int;
+ pragma Import (C, pthread_attr_setschedparam);
+
+ 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);
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ ------------------------------------------------------------
+ -- Binary Semaphore Wrapper to Support Interrupt Tasks --
+ ------------------------------------------------------------
+
+ 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");
+
+ function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int;
+ pragma Import (
+ C,
+ Binary_Semaphore_Delete,
+ "__gnat_binary_semaphore_delete");
+
+ function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int;
+ pragma Import (
+ C,
+ Binary_Semaphore_Obtain,
+ "__gnat_binary_semaphore_obtain");
+
+ function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int;
+ pragma Import (
+ C,
+ Binary_Semaphore_Release,
+ "__gnat_binary_semaphore_release");
+
+ function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int;
+ pragma Import (
+ C,
+ Binary_Semaphore_Flush,
+ "__gnat_binary_semaphore_flush");
+
+ ------------------------------------------------------------
+ -- Hardware Interrupt Wrappers to Support Interrupt Tasks --
+ ------------------------------------------------------------
+
+ 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");
+ -- 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
+
+ type sigset_t is new int;
+
+ 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);
+
+ CLOCK_REALTIME : constant clockid_t := System.OS_Constants.CLOCK_REALTIME;
+ CLOCK_MONOTONIC : constant clockid_t := System.OS_Constants.CLOCK_MONOTONIC;
+
+ 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.double'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.double'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.double'Alignment;
+
+ type pthread_rwlockattr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCKATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_rwlockattr_t);
+ for pthread_rwlockattr_t'Alignment use Interfaces.C.double'Alignment;
+
+ type pthread_t is new rtems_id;
+
+ type pthread_mutex_t is new rtems_id;
+
+ type pthread_rwlock_t is new rtems_id;
+
+ type pthread_cond_t is new rtems_id;
+
+ type pthread_key_t is new rtems_id;
+
+ No_Key : constant pthread_key_t := 0;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-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- --
+-- 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 a Solaris version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+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 Interfaces.C; use Interfaces.C;
+
+package body System.OS_Interface is
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1991-2017, Florida State University --
+-- 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 --
+-- <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 a Solaris (native) version of this package
+
+-- This package includes 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 Interfaces.C;
+
+with Ada.Unchecked_Conversion;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lposix4");
+ pragma Linker_Options ("-lthread");
+
+ subtype int is Interfaces.C.int;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIME : constant := 62;
+ ETIMEDOUT : constant := 145;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 45;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ 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 possible (Solaris SIGPOLL alias)
+ 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
+ SIGWAITING : constant := 32; -- process's lwps blocked (Solaris)
+ SIGLWP : constant := 33; -- used by thread library (Solaris)
+ SIGFREEZE : constant := 34; -- used by CPR (Solaris)
+ SIGTHAW : constant := 35; -- used by CPR (Solaris)
+ SIGCANCEL : constant := 36; -- thread cancellation signal (libthread)
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF);
+
+ -- Following signals should not be disturbed.
+ -- See c-posix-signals.c in FLORIST.
+
+ Reserved : constant Signal_Set :=
+ (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL, SIGTRAP, 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);
+
+ -- The types mcontext_t and gregset_t are part of the ucontext_t
+ -- information, which is specific to Solaris2.4 for SPARC
+ -- The ucontext_t info seems to be used by the handler
+ -- for SIGSEGV to decide whether it is a Storage_Error (stack overflow) or
+ -- a Constraint_Error (bad pointer). The original code that did this
+ -- is suspect, so it is not clear whether we really need this part of
+ -- the signal context information, or perhaps something else.
+ -- More analysis is needed, after which these declarations may need to
+ -- be changed.
+
+ type greg_t is new int;
+
+ type gregset_t is array (0 .. 18) of greg_t;
+
+ type union_type_2 is new String (1 .. 128);
+ type record_type_1 is record
+ fpu_fr : union_type_2;
+ fpu_q : System.Address;
+ fpu_fsr : unsigned;
+ fpu_qcnt : unsigned_char;
+ fpu_q_entrysize : unsigned_char;
+ fpu_en : unsigned_char;
+ end record;
+ pragma Convention (C, record_type_1);
+
+ type array_type_7 is array (Integer range 0 .. 20) of long;
+ type mcontext_t is record
+ gregs : gregset_t;
+ gwins : System.Address;
+ fpregs : record_type_1;
+ filler : array_type_7;
+ end record;
+ pragma Convention (C, mcontext_t);
+
+ type record_type_2 is record
+ ss_sp : System.Address;
+ ss_size : int;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, record_type_2);
+
+ type array_type_8 is array (Integer range 0 .. 22) of long;
+ type ucontext_t is record
+ uc_flags : unsigned_long;
+ uc_link : System.Address;
+ uc_sigmask : sigset_t;
+ uc_stack : record_type_2;
+ uc_mcontext : mcontext_t;
+ uc_filler : array_type_8;
+ end record;
+ pragma Convention (C, ucontext_t);
+
+ type Signal_Handler is access procedure
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access ucontext_t);
+
+ type union_type_1 is new plain_char;
+ type array_type_2 is array (Integer range 0 .. 1) of int;
+ type struct_sigaction is record
+ sa_flags : int;
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_resv : array_type_2;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ type timespec is private;
+
+ 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);
+
+ -------------
+ -- 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);
+
+ THR_DETACHED : constant := 64;
+ THR_BOUND : constant := 1;
+ THR_NEW_LWP : constant := 2;
+ USYNC_THREAD : constant := 0;
+
+ type thread_t is new unsigned;
+ subtype Thread_Id is thread_t;
+ -- These types should be commented ???
+
+ function To_thread_t is new Ada.Unchecked_Conversion (Integer, thread_t);
+
+ type mutex_t is limited private;
+
+ type cond_t is limited private;
+
+ type thread_key_t is private;
+
+ function thr_create
+ (stack_base : System.Address;
+ stack_size : size_t;
+ start_routine : Thread_Body;
+ arg : System.Address;
+ flags : int;
+ new_thread : access thread_t) return int;
+ pragma Import (C, thr_create, "thr_create");
+
+ function thr_min_stack return size_t;
+ pragma Import (C, thr_min_stack, "thr_min_stack");
+
+ function thr_self return thread_t;
+ pragma Import (C, thr_self, "thr_self");
+
+ function mutex_init
+ (mutex : access mutex_t;
+ mtype : int;
+ arg : System.Address) return int;
+ pragma Import (C, mutex_init, "mutex_init");
+
+ function mutex_destroy (mutex : access mutex_t) return int;
+ pragma Import (C, mutex_destroy, "mutex_destroy");
+
+ function mutex_lock (mutex : access mutex_t) return int;
+ pragma Import (C, mutex_lock, "mutex_lock");
+
+ function mutex_unlock (mutex : access mutex_t) return int;
+ pragma Import (C, mutex_unlock, "mutex_unlock");
+
+ function cond_init
+ (cond : access cond_t;
+ ctype : int;
+ arg : int) return int;
+ pragma Import (C, cond_init, "cond_init");
+
+ function cond_wait
+ (cond : access cond_t; mutex : access mutex_t) return int;
+ pragma Import (C, cond_wait, "cond_wait");
+
+ function cond_timedwait
+ (cond : access cond_t;
+ mutex : access mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, cond_timedwait, "cond_timedwait");
+
+ function cond_signal (cond : access cond_t) return int;
+ pragma Import (C, cond_signal, "cond_signal");
+
+ function cond_destroy (cond : access cond_t) return int;
+ pragma Import (C, cond_destroy, "cond_destroy");
+
+ function thr_setspecific
+ (key : thread_key_t; value : System.Address) return int;
+ pragma Import (C, thr_setspecific, "thr_setspecific");
+
+ function thr_getspecific
+ (key : thread_key_t;
+ value : access System.Address) return int;
+ pragma Import (C, thr_getspecific, "thr_getspecific");
+
+ function thr_keycreate
+ (key : access thread_key_t; destructor : System.Address) return int;
+ pragma Import (C, thr_keycreate, "thr_keycreate");
+
+ function thr_setprio (thread : thread_t; priority : int) return int;
+ pragma Import (C, thr_setprio, "thr_setprio");
+
+ procedure thr_exit (status : System.Address);
+ pragma Import (C, thr_exit, "thr_exit");
+
+ function thr_setconcurrency (new_level : int) return int;
+ pragma Import (C, thr_setconcurrency, "thr_setconcurrency");
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "__posix_sigwait");
+
+ function thr_kill (thread : thread_t; sig : Signal) return int;
+ pragma Import (C, thr_kill, "thr_kill");
+
+ function thr_sigsetmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, thr_sigsetmask, "thr_sigsetmask");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "thr_sigsetmask");
+
+ function thr_suspend (target_thread : thread_t) return int;
+ pragma Import (C, thr_suspend, "thr_suspend");
+
+ function thr_continue (target_thread : thread_t) return int;
+ pragma Import (C, thr_continue, "thr_continue");
+
+ procedure thr_yield;
+ pragma Import (C, thr_yield, "thr_yield");
+
+ ---------
+ -- LWP --
+ ---------
+
+ P_PID : constant := 0;
+ P_LWPID : constant := 8;
+
+ PC_GETCID : constant := 0;
+ PC_GETCLINFO : constant := 1;
+ PC_SETPARMS : constant := 2;
+ PC_GETPARMS : constant := 3;
+ PC_ADMIN : constant := 4;
+
+ PC_CLNULL : constant := -1;
+
+ RT_NOCHANGE : constant := -1;
+ RT_TQINF : constant := -2;
+ RT_TQDEF : constant := -3;
+
+ PC_CLNMSZ : constant := 16;
+
+ PC_VERSION : constant := 1;
+
+ type lwpid_t is new int;
+
+ type pri_t is new short;
+
+ type id_t is new long;
+
+ P_MYID : constant := -1;
+ -- The specified LWP or process is the current one
+
+ type struct_pcinfo is record
+ pc_cid : id_t;
+ pc_clname : String (1 .. PC_CLNMSZ);
+ rt_maxpri : short;
+ end record;
+ pragma Convention (C, struct_pcinfo);
+
+ type struct_pcparms is record
+ pc_cid : id_t;
+ rt_pri : pri_t;
+ rt_tqsecs : long;
+ rt_tqnsecs : long;
+ end record;
+ pragma Convention (C, struct_pcparms);
+
+ function priocntl
+ (ver : int;
+ id_type : int;
+ id : lwpid_t;
+ cmd : int;
+ arg : System.Address) return Interfaces.C.long;
+ pragma Import (C, priocntl, "__priocntl");
+
+ function lwp_self return lwpid_t;
+ pragma Import (C, lwp_self, "_lwp_self");
+
+ type processorid_t is new int;
+ type processorid_t_ptr is access all processorid_t;
+
+ -- Constants for function processor_bind
+
+ PBIND_QUERY : constant processorid_t := -2;
+ -- The processor bindings are not changed
+
+ PBIND_NONE : constant processorid_t := -1;
+ -- The processor bindings of the specified LWPs are cleared
+
+ -- Flags for function p_online
+
+ PR_OFFLINE : constant int := 1;
+ -- Processor is offline, as quiet as possible
+
+ PR_ONLINE : constant int := 2;
+ -- Processor online
+
+ PR_STATUS : constant int := 3;
+ -- Value passed to p_online to request status
+
+ function p_online (processorid : processorid_t; flag : int) return int;
+ pragma Import (C, p_online, "p_online");
+
+ function processor_bind
+ (id_type : int;
+ id : id_t;
+ proc_id : processorid_t;
+ obind : processorid_t_ptr) return int;
+ pragma Import (C, processor_bind, "processor_bind");
+
+ type psetid_t is new int;
+
+ function pset_create (pset : access psetid_t) return int;
+ pragma Import (C, pset_create, "pset_create");
+
+ function pset_assign
+ (pset : psetid_t;
+ proc_id : processorid_t;
+ opset : access psetid_t) return int;
+ pragma Import (C, pset_assign, "pset_assign");
+
+ function pset_bind
+ (pset : psetid_t;
+ id_type : int;
+ id : id_t;
+ opset : access psetid_t) return int;
+ pragma Import (C, pset_bind, "pset_bind");
+
+ procedure pthread_init;
+ -- Dummy procedure to share s-intman.adb with other Solaris targets
+
+private
+
+ type array_type_1 is array (0 .. 3) of unsigned_long;
+ type sigset_t is record
+ X_X_sigbits : array_type_1;
+ end record;
+ pragma Convention (C, sigset_t);
+
+ type pid_t is new long;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type array_type_9 is array (0 .. 3) of unsigned_char;
+ type record_type_3 is record
+ flag : array_type_9;
+ Xtype : unsigned_long;
+ end record;
+ pragma Convention (C, record_type_3);
+
+ type mutex_t is record
+ flags : record_type_3;
+ lock : String (1 .. 8);
+ data : String (1 .. 8);
+ end record;
+ pragma Convention (C, mutex_t);
+
+ type cond_t is record
+ flag : array_type_9;
+ Xtype : unsigned_long;
+ data : String (1 .. 8);
+ end record;
+ pragma Convention (C, cond_t);
+
+ type thread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1997-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 --
+-- <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 VxWorks version
+
+-- This package encapsulates all direct interfaces to OS services that are
+-- needed by children of System.
+
+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.
+
+package body System.OS_Interface is
+
+ use type Interfaces.C.int;
+
+ Low_Priority : constant := 255;
+ -- VxWorks native (default) lowest scheduling priority
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
+ end To_Duration;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F is negative due to a round-up, adjust for positive F value
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(ts_sec => S,
+ ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ -------------------------
+ -- To_VxWorks_Priority --
+ -------------------------
+
+ function To_VxWorks_Priority (Priority : int) return int is
+ begin
+ return Low_Priority - Priority;
+ end To_VxWorks_Priority;
+
+ --------------------
+ -- To_Clock_Ticks --
+ --------------------
+
+ -- ??? - For now, we'll always get the system clock rate since it is
+ -- allowed to be changed during run-time in VxWorks. A better method would
+ -- be to provide an operation to set it that so we can always know its
+ -- value.
+
+ -- Another thing we should probably allow for is a resultant tick count
+ -- greater than int'Last. This should probably be a procedure with two
+ -- output parameters, one in the range 0 .. int'Last, and another
+ -- representing the overflow count.
+
+ function To_Clock_Ticks (D : Duration) return int is
+ Ticks : Long_Long_Integer;
+ Rate_Duration : Duration;
+ Ticks_Duration : Duration;
+
+ begin
+ if D < 0.0 then
+ return ERROR;
+ end if;
+
+ -- Ensure that the duration can be converted to ticks
+ -- at the current clock tick rate without overflowing.
+
+ Rate_Duration := Duration (sysClkRateGet);
+
+ if D > (Duration'Last / Rate_Duration) then
+ Ticks := Long_Long_Integer (int'Last);
+ else
+ Ticks_Duration := D * Rate_Duration;
+ Ticks := Long_Long_Integer (Ticks_Duration);
+
+ if Ticks_Duration > Duration (Ticks) then
+ Ticks := Ticks + 1;
+ end if;
+
+ if Ticks > Long_Long_Integer (int'Last) then
+ Ticks := Long_Long_Integer (int'Last);
+ end if;
+ end if;
+
+ return int (Ticks);
+ end To_Clock_Ticks;
+
+ -----------------------------
+ -- Binary_Semaphore_Create --
+ -----------------------------
+
+ function Binary_Semaphore_Create return Binary_Semaphore_Id is
+ begin
+ return Binary_Semaphore_Id (semBCreate (SEM_Q_FIFO, SEM_EMPTY));
+ end Binary_Semaphore_Create;
+
+ -----------------------------
+ -- Binary_Semaphore_Delete --
+ -----------------------------
+
+ function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int is
+ begin
+ return semDelete (SEM_ID (ID));
+ end Binary_Semaphore_Delete;
+
+ -----------------------------
+ -- Binary_Semaphore_Obtain --
+ -----------------------------
+
+ function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int is
+ begin
+ return semTake (SEM_ID (ID), WAIT_FOREVER);
+ end Binary_Semaphore_Obtain;
+
+ ------------------------------
+ -- Binary_Semaphore_Release --
+ ------------------------------
+
+ function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int is
+ begin
+ return semGive (SEM_ID (ID));
+ end Binary_Semaphore_Release;
+
+ ----------------------------
+ -- Binary_Semaphore_Flush --
+ ----------------------------
+
+ function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int is
+ begin
+ return semFlush (SEM_ID (ID));
+ end Binary_Semaphore_Flush;
+
+ ----------
+ -- kill --
+ ----------
+
+ function kill (pid : t_id; sig : Signal) return int is
+ begin
+ return System.VxWorks.Ext.kill (pid, int (sig));
+ end kill;
+
+ -----------------------
+ -- Interrupt_Connect --
+ -----------------------
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int is
+ begin
+ return
+ System.VxWorks.Ext.Interrupt_Connect
+ (System.VxWorks.Ext.Interrupt_Vector (Vector),
+ System.VxWorks.Ext.Interrupt_Handler (Handler),
+ Parameter);
+ end Interrupt_Connect;
+
+ -----------------------
+ -- Interrupt_Context --
+ -----------------------
+
+ function Interrupt_Context return int is
+ begin
+ return System.VxWorks.Ext.Interrupt_Context;
+ end Interrupt_Context;
+
+ --------------------------------
+ -- Interrupt_Number_To_Vector --
+ --------------------------------
+
+ function Interrupt_Number_To_Vector
+ (intNum : int) return Interrupt_Vector
+ is
+ begin
+ return Interrupt_Vector
+ (System.VxWorks.Ext.Interrupt_Number_To_Vector (intNum));
+ end Interrupt_Number_To_Vector;
+
+ -----------------
+ -- Current_CPU --
+ -----------------
+
+ function Current_CPU return Multiprocessors.CPU is
+ begin
+ -- ??? Should use vxworks multiprocessor interface
+
+ return Multiprocessors.CPU'First;
+ end Current_CPU;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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) 1991-2017, Florida State University --
+-- Copyright (C) 1995-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. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- 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 VxWorks 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 Interfaces.C;
+with System.VxWorks;
+with System.VxWorks.Ext;
+with System.Multiprocessors;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ subtype int is Interfaces.C.int;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype short is Short_Integer;
+ type unsigned_int is mod 2 ** int'Size;
+ type long is new Long_Integer;
+ type unsigned_long is mod 2 ** long'Size;
+ type long_long is new Long_Long_Integer;
+ type unsigned_long_long is mod 2 ** long_long'Size;
+ type size_t is mod 2 ** Standard'Address_Size;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "errnoGet");
+
+ EINTR : constant := 4;
+ EAGAIN : constant := 35;
+ ENOMEM : constant := 12;
+ EINVAL : constant := 22;
+ ETIMEDOUT : constant := 60;
+
+ FUNC_ERR : constant := -1;
+
+ ----------------------------
+ -- Signals and interrupts --
+ ----------------------------
+
+ 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 := System.VxWorks.Num_HW_Interrupts - 1;
+ type HW_Interrupt is new int range 0 .. Max_HW_Interrupt;
+
+ Max_Interrupt : constant := Max_HW_Interrupt;
+ subtype Interrupt_Range is Natural range 0 .. Max_HW_Interrupt;
+ -- For s-interr
+
+ -- Signals common to Vxworks 5.x and 6.x
+
+ SIGILL : constant := 4; -- illegal instruction (not reset when caught)
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGFPE : constant := 8; -- floating point exception
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+
+ -- Signals specific to VxWorks 6.x
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt
+ SIGQUIT : constant := 3; -- quit
+ SIGTRAP : constant := 5; -- trace trap (not reset when caught)
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGKILL : constant := 9; -- kill
+ SIGFMT : constant := 12; -- STACK FORMAT ERROR (not posix)
+ 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
+ SIGCNCL : constant := 16; -- pthreads cancellation signal
+ SIGSTOP : constant := 17; -- sendable stop signal not from tty
+ SIGTSTP : constant := 18; -- stop signal from tty
+ SIGCONT : constant := 19; -- continue a stopped process
+ SIGCHLD : constant := 20; -- to parent on child stop or exit
+ SIGTTIN : constant := 21; -- to readers pgrp upon background tty read
+ SIGTTOU : constant := 22; -- like TTIN for output
+
+ SIGRES1 : constant := 23; -- reserved signal number (Not POSIX)
+ SIGRES2 : constant := 24; -- reserved signal number (Not POSIX)
+ SIGRES3 : constant := 25; -- reserved signal number (Not POSIX)
+ SIGRES4 : constant := 26; -- reserved signal number (Not POSIX)
+ SIGRES5 : constant := 27; -- reserved signal number (Not POSIX)
+ SIGRES6 : constant := 28; -- reserved signal number (Not POSIX)
+ SIGRES7 : constant := 29; -- reserved signal number (Not POSIX)
+
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGPOLL : constant := 32; -- pollable event
+ SIGPROF : constant := 33; -- profiling timer expired
+ SIGSYS : constant := 34; -- bad system call
+ SIGURG : constant := 35; -- high bandwidth data is available at socket
+ SIGVTALRM : constant := 36; -- virtual timer expired
+ SIGXCPU : constant := 37; -- CPU time limit exceeded
+ SIGXFSZ : constant := 38; -- file size time limit exceeded
+
+ SIGEVTS : constant := 39; -- signal event thread send
+ SIGEVTD : constant := 40; -- signal event thread delete
+
+ SIGRTMIN : constant := 48; -- Realtime signal min
+ SIGRTMAX : constant := 63; -- Realtime signal max
+
+ -----------------------------------
+ -- Signal processing definitions --
+ -----------------------------------
+
+ -- The how in sigprocmask()
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ -- The sa_flags in struct sigaction
+
+ SA_SIGINFO : constant := 16#0002#;
+ SA_ONSTACK : constant := 16#0004#;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ type sigset_t is private;
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ 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");
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ type isr_address is access procedure (sig : int);
+ pragma Convention (C, isr_address);
+
+ function c_signal (sig : Signal; handler : isr_address) return isr_address;
+ pragma Import (C, c_signal, "signal");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+
+ subtype t_id is System.VxWorks.Ext.t_id;
+ subtype Thread_Id is t_id;
+ -- Thread_Id and t_id are VxWorks identifiers for tasks. This value,
+ -- although represented as a Long_Integer, is in fact an address. With
+ -- some BSPs, this address can have a value sufficiently high that the
+ -- Thread_Id becomes negative: this should not be considered as an error.
+
+ function kill (pid : t_id; sig : Signal) return int;
+ pragma Inline (kill);
+
+ function getpid return t_id renames System.VxWorks.Ext.getpid;
+
+ function Task_Stop (tid : t_id) return int
+ renames System.VxWorks.Ext.Task_Stop;
+ -- If we are in the kernel space, stop the task whose t_id is given in
+ -- parameter in such a way that it can be examined by the debugger. This
+ -- typically maps to taskSuspend on VxWorks 5 and to taskStop on VxWorks 6.
+
+ function Task_Cont (tid : t_id) return int
+ renames System.VxWorks.Ext.Task_Cont;
+ -- If we are in the kernel space, continue the task whose t_id is given
+ -- in parameter if it has been stopped previously to be examined by the
+ -- debugger (e.g. by taskStop). It typically maps to taskResume on VxWorks
+ -- 5 and to taskCont on VxWorks 6.
+
+ function Int_Lock return int renames System.VxWorks.Ext.Int_Lock;
+ -- If we are in the kernel space, lock interrupts. It typically maps to
+ -- intLock.
+
+ function Int_Unlock (Old : int) return int
+ renames System.VxWorks.Ext.Int_Unlock;
+ -- If we are in the kernel space, unlock interrupts. It typically maps to
+ -- intUnlock. The parameter Old is only used on PowerPC where it contains
+ -- the returned value from Int_Lock (the old MPSR).
+
+ ----------
+ -- Time --
+ ----------
+
+ type time_t is new unsigned_long;
+
+ type timespec is record
+ ts_sec : time_t;
+ ts_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+ -- Convert a Duration value to a timespec value. Note that in VxWorks,
+ -- timespec is always non-negative (since time_t is defined above as
+ -- unsigned long). This means that there is a potential problem if a
+ -- negative argument is passed for D. However, in actual usage, the
+ -- value of the input argument D is always non-negative, so no problem
+ -- arises in practice.
+
+ function To_Clock_Ticks (D : Duration) return int;
+ -- Convert a duration value (in seconds) into clock ticks
+
+ function clock_gettime
+ (clock_id : clockid_t; tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ ----------------------
+ -- Utility Routines --
+ ----------------------
+
+ function To_VxWorks_Priority (Priority : int) return int;
+ pragma Inline (To_VxWorks_Priority);
+ -- Convenience routine to convert between VxWorks priority and Ada priority
+
+ --------------------------
+ -- VxWorks specific API --
+ --------------------------
+
+ subtype STATUS is int;
+ -- Equivalent of the C type STATUS
+
+ OK : constant STATUS := 0;
+ ERROR : constant STATUS := Interfaces.C.int (-1);
+
+ function taskIdVerify (tid : t_id) return STATUS;
+ pragma Import (C, taskIdVerify, "taskIdVerify");
+
+ function taskIdSelf return t_id;
+ pragma Import (C, taskIdSelf, "taskIdSelf");
+
+ function taskOptionsGet (tid : t_id; pOptions : access int) return int;
+ pragma Import (C, taskOptionsGet, "taskOptionsGet");
+
+ function taskSuspend (tid : t_id) return int;
+ pragma Import (C, taskSuspend, "taskSuspend");
+
+ function taskResume (tid : t_id) return int;
+ pragma Import (C, taskResume, "taskResume");
+
+ function taskIsSuspended (tid : t_id) return int;
+ pragma Import (C, taskIsSuspended, "taskIsSuspended");
+
+ function taskDelay (ticks : int) return int;
+ pragma Import (C, taskDelay, "taskDelay");
+
+ function sysClkRateGet return int;
+ pragma Import (C, sysClkRateGet, "sysClkRateGet");
+
+ -- VxWorks 5.x specific functions
+ -- Must not be called from run-time for versions that do not support
+ -- taskVarLib: eg VxWorks 6 RTPs
+
+ function taskVarAdd
+ (tid : t_id; pVar : access System.Address) return int;
+ pragma Import (C, taskVarAdd, "taskVarAdd");
+
+ function taskVarDelete
+ (tid : t_id; pVar : access System.Address) return int;
+ pragma Import (C, taskVarDelete, "taskVarDelete");
+
+ function taskVarSet
+ (tid : t_id;
+ pVar : access System.Address;
+ value : System.Address) return int;
+ pragma Import (C, taskVarSet, "taskVarSet");
+
+ function taskVarGet
+ (tid : t_id;
+ pVar : access System.Address) return int;
+ pragma Import (C, taskVarGet, "taskVarGet");
+
+ -- VxWorks 6.x specific functions
+
+ -- Can only be called from the VxWorks 6 run-time libary that supports
+ -- tlsLib, and not by the VxWorks 6.6 SMP library
+
+ function tlsKeyCreate return int;
+ pragma Import (C, tlsKeyCreate, "tlsKeyCreate");
+
+ function tlsValueGet (key : int) return System.Address;
+ pragma Import (C, tlsValueGet, "tlsValueGet");
+
+ function tlsValueSet (key : int; value : System.Address) return STATUS;
+ pragma Import (C, tlsValueSet, "tlsValueSet");
+
+ -- Option flags for taskSpawn
+
+ VX_UNBREAKABLE : constant := 16#0002#;
+ VX_FP_PRIVATE_ENV : constant := 16#0080#;
+ VX_NO_STACK_FILL : constant := 16#0100#;
+
+ function taskSpawn
+ (name : System.Address; -- Pointer to task name
+ priority : int;
+ options : int;
+ stacksize : size_t;
+ start_routine : System.Address;
+ arg1 : System.Address;
+ arg2 : int := 0;
+ arg3 : int := 0;
+ arg4 : int := 0;
+ arg5 : int := 0;
+ arg6 : int := 0;
+ arg7 : int := 0;
+ arg8 : int := 0;
+ arg9 : int := 0;
+ arg10 : int := 0) return t_id;
+ pragma Import (C, taskSpawn, "taskSpawn");
+
+ procedure taskDelete (tid : t_id);
+ pragma Import (C, taskDelete, "taskDelete");
+
+ function Set_Time_Slice (ticks : int) return int
+ renames System.VxWorks.Ext.Set_Time_Slice;
+ -- Calls kernelTimeSlice under VxWorks 5.x, VxWorks 653, or in VxWorks 6
+ -- kernel apps. Returns ERROR for RTPs, VxWorks 5 /CERT
+
+ function taskPriorityGet (tid : t_id; pPriority : access int) return int;
+ pragma Import (C, taskPriorityGet, "taskPriorityGet");
+
+ function taskPrioritySet (tid : t_id; newPriority : int) return int;
+ pragma Import (C, taskPrioritySet, "taskPrioritySet");
+
+ -- Semaphore creation flags
+
+ SEM_Q_FIFO : constant := 0;
+ SEM_Q_PRIORITY : constant := 1;
+ SEM_DELETE_SAFE : constant := 4; -- only valid for binary semaphore
+ SEM_INVERSION_SAFE : constant := 8; -- only valid for binary semaphore
+
+ -- Semaphore initial state flags
+
+ SEM_EMPTY : constant := 0;
+ SEM_FULL : constant := 1;
+
+ -- Semaphore take (semTake) time constants
+
+ WAIT_FOREVER : constant := -1;
+ NO_WAIT : constant := 0;
+
+ -- Error codes (errno). The lower level 16 bits are the error code, with
+ -- the upper 16 bits representing the module number in which the error
+ -- occurred. By convention, the module number is 0 for UNIX errors. VxWorks
+ -- reserves module numbers 1-500, with the remaining module numbers being
+ -- available for user applications.
+
+ M_objLib : constant := 61 * 2**16;
+ -- semTake() failure with ticks = NO_WAIT
+ S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2;
+ -- semTake() timeout with ticks > NO_WAIT
+ S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4;
+
+ subtype SEM_ID is System.VxWorks.Ext.SEM_ID;
+ -- typedef struct semaphore *SEM_ID;
+
+ -- We use two different kinds of VxWorks semaphores: mutex and binary
+ -- semaphores. A null ID is returned when a semaphore cannot be created.
+
+ function semBCreate (options : int; initial_state : int) return SEM_ID;
+ pragma Import (C, semBCreate, "semBCreate");
+ -- Create a binary semaphore. Return ID, or 0 if memory could not
+ -- be allocated.
+
+ function semMCreate (options : int) return SEM_ID;
+ pragma Import (C, semMCreate, "semMCreate");
+
+ function semDelete (Sem : SEM_ID) return int
+ renames System.VxWorks.Ext.semDelete;
+ -- Delete a semaphore
+
+ function semGive (Sem : SEM_ID) return int;
+ pragma Import (C, semGive, "semGive");
+
+ function semTake (Sem : SEM_ID; timeout : int) return int;
+ pragma Import (C, semTake, "semTake");
+ -- Attempt to take binary semaphore. Error is returned if operation
+ -- times out
+
+ function semFlush (SemID : SEM_ID) return STATUS;
+ pragma Import (C, semFlush, "semFlush");
+ -- Release all threads blocked on the semaphore
+
+ ------------------------------------------------------------
+ -- Binary Semaphore Wrapper to Support interrupt Tasks --
+ ------------------------------------------------------------
+
+ type Binary_Semaphore_Id is new Long_Integer;
+
+ function Binary_Semaphore_Create return Binary_Semaphore_Id;
+ pragma Inline (Binary_Semaphore_Create);
+
+ function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int;
+ pragma Inline (Binary_Semaphore_Delete);
+
+ function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int;
+ pragma Inline (Binary_Semaphore_Obtain);
+
+ function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int;
+ pragma Inline (Binary_Semaphore_Release);
+
+ function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int;
+ pragma Inline (Binary_Semaphore_Flush);
+
+ ------------------------------------------------------------
+ -- Hardware Interrupt Wrappers to Support Interrupt Tasks --
+ ------------------------------------------------------------
+
+ 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 Inline (Interrupt_Connect);
+ -- Use this to set up an user handler. The routine installs a user handler
+ -- which is invoked after the OS has saved enough context for a high-level
+ -- language routine to be safely invoked.
+
+ function Interrupt_Context return int;
+ pragma Inline (Interrupt_Context);
+ -- Return 1 if executing in an interrupt context; return 0 if executing in
+ -- a task context.
+
+ function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector;
+ pragma Inline (Interrupt_Number_To_Vector);
+ -- Convert a logical interrupt number to the hardware interrupt vector
+ -- number used to connect the interrupt.
+
+ --------------------------------
+ -- Processor Affinity for SMP --
+ --------------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int
+ renames System.VxWorks.Ext.taskCpuAffinitySet;
+ -- For SMP run-times the affinity to CPU.
+ -- For uniprocessor systems return ERROR status.
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int
+ renames System.VxWorks.Ext.taskMaskAffinitySet;
+ -- For SMP run-times the affinity to CPU_Set.
+ -- For uniprocessor systems return ERROR status.
+
+ ---------------------
+ -- Multiprocessors --
+ ---------------------
+
+ function Current_CPU return Multiprocessors.CPU;
+ -- Return the id of the current CPU
+
+private
+ type pid_t is new int;
+
+ ERROR_PID : constant pid_t := -1;
+
+ type sigset_t is new System.VxWorks.Ext.sigset_t;
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-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- --
+-- 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 version is for Linux/x32
+
+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.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+with Interfaces.C; use Interfaces.C;
+package body System.OS_Interface is
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ use type System.Linux.time_t;
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => Long_Long_Integer (F * 10#1#E9));
+ end To_Timespec;
+
+end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . 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 --
--- <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 a no tasking version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-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.
-
-package body System.Task_Primitives.Operations is
-
- use System.Tasking;
- use System.Parameters;
-
- pragma Warnings (Off);
- -- Turn off warnings since so many unreferenced parameters
-
- --------------
- -- Specific --
- --------------
-
- -- Package Specific contains target specific routines, and the body of
- -- this package is target specific.
-
- package Specific is
- procedure Set (Self_Id : Task_Id);
- pragma Inline (Set);
- -- Set the self id for the current task
- end Specific;
-
- package body Specific is
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- begin
- null;
- end Set;
- end Specific;
-
- ----------------------------------
- -- ATCB allocation/deallocation --
- ----------------------------------
-
- package body ATCB_Allocation is separate;
- -- The body of this package is shared across several targets
-
- ----------------
- -- Abort_Task --
- ----------------
-
- procedure Abort_Task (T : Task_Id) is
- begin
- null;
- end Abort_Task;
-
- ----------------
- -- Check_Exit --
- ----------------
-
- function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
- begin
- return True;
- end Check_Exit;
-
- --------------------
- -- Check_No_Locks --
- --------------------
-
- function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
- begin
- return True;
- end Check_No_Locks;
-
- -------------------
- -- Continue_Task --
- -------------------
-
- function Continue_Task (T : ST.Task_Id) return Boolean is
- begin
- return False;
- end Continue_Task;
-
- -------------------
- -- Current_State --
- -------------------
-
- function Current_State (S : Suspension_Object) return Boolean is
- begin
- return False;
- end Current_State;
-
- ----------------------
- -- Environment_Task --
- ----------------------
-
- function Environment_Task return Task_Id is
- begin
- return null;
- end Environment_Task;
-
- -----------------
- -- 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
- begin
- Succeeded := False;
- end Create_Task;
-
- ----------------
- -- Enter_Task --
- ----------------
-
- procedure Enter_Task (Self_ID : Task_Id) is
- begin
- null;
- end Enter_Task;
-
- ---------------
- -- Exit_Task --
- ---------------
-
- procedure Exit_Task is
- begin
- null;
- end Exit_Task;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (S : in out Suspension_Object) is
- begin
- null;
- end Finalize;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : not null access Lock) is
- begin
- null;
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : not null access RTS_Lock) is
- begin
- null;
- end Finalize_Lock;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- begin
- null;
- end Finalize_TCB;
-
- ------------------
- -- Get_Priority --
- ------------------
-
- function Get_Priority (T : Task_Id) return System.Any_Priority is
- begin
- return 0;
- end Get_Priority;
-
- --------------------
- -- Get_Thread_Id --
- --------------------
-
- function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
- begin
- return OSI.Thread_Id (T.Common.LL.Thread);
- end Get_Thread_Id;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- No_Tasking : Boolean;
- begin
- raise Program_Error with "tasking not implemented on this configuration";
- end Initialize;
-
- procedure Initialize (S : in out Suspension_Object) is
- begin
- null;
- end Initialize;
-
- ---------------------
- -- Initialize_Lock --
- ---------------------
-
- procedure Initialize_Lock
- (Prio : System.Any_Priority;
- L : not null access Lock)
- is
- begin
- null;
- end Initialize_Lock;
-
- procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level) is
- begin
- null;
- end Initialize_Lock;
-
- --------------------
- -- Initialize_TCB --
- --------------------
-
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- begin
- Succeeded := False;
- end Initialize_TCB;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- begin
- return False;
- end Is_Valid_Task;
-
- --------------
- -- Lock_RTS --
- --------------
-
- procedure Lock_RTS is
- begin
- null;
- end Lock_RTS;
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- function Monotonic_Clock return Duration is
- begin
- return 0.0;
- end Monotonic_Clock;
-
- ---------------
- -- Read_Lock --
- ---------------
-
- procedure Read_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- begin
- Ceiling_Violation := False;
- end Read_Lock;
-
- -----------------------------
- -- Register_Foreign_Thread --
- -----------------------------
-
- function Register_Foreign_Thread return Task_Id is
- begin
- return null;
- end Register_Foreign_Thread;
-
- -----------------
- -- Resume_Task --
- -----------------
-
- function Resume_Task
- (T : ST.Task_Id;
- Thread_Self : OSI.Thread_Id) return Boolean
- is
- begin
- return False;
- end Resume_Task;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- begin
- return 10#1.0#E-6;
- end RT_Resolution;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_Id is
- begin
- return Null_Task;
- end Self;
-
- -----------------
- -- Set_Ceiling --
- -----------------
-
- procedure Set_Ceiling
- (L : not null access Lock;
- Prio : System.Any_Priority)
- is
- begin
- null;
- end Set_Ceiling;
-
- ---------------
- -- Set_False --
- ---------------
-
- procedure Set_False (S : in out Suspension_Object) is
- begin
- null;
- end Set_False;
-
- ------------------
- -- Set_Priority --
- ------------------
-
- procedure Set_Priority
- (T : Task_Id;
- Prio : System.Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- begin
- null;
- end Set_Priority;
-
- -----------------------
- -- Set_Task_Affinity --
- -----------------------
-
- procedure Set_Task_Affinity (T : ST.Task_Id) is
- begin
- null;
- end Set_Task_Affinity;
-
- --------------
- -- Set_True --
- --------------
-
- procedure Set_True (S : in out Suspension_Object) is
- begin
- null;
- end Set_True;
-
- -----------
- -- Sleep --
- -----------
-
- procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
- begin
- null;
- end Sleep;
-
- -----------------
- -- Stack_Guard --
- -----------------
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- begin
- null;
- end Stack_Guard;
-
- ------------------
- -- Suspend_Task --
- ------------------
-
- function Suspend_Task
- (T : ST.Task_Id;
- Thread_Self : OSI.Thread_Id) return Boolean
- is
- begin
- return False;
- end Suspend_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;
-
- ------------------------
- -- Suspend_Until_True --
- ------------------------
-
- procedure Suspend_Until_True (S : in out Suspension_Object) is
- begin
- null;
- end Suspend_Until_True;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- begin
- null;
- end Timed_Delay;
-
- -----------------
- -- Timed_Sleep --
- -----------------
-
- procedure Timed_Sleep
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes;
- Reason : System.Tasking.Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- begin
- Timedout := False;
- Yielded := False;
- end Timed_Sleep;
-
- ------------
- -- Unlock --
- ------------
-
- procedure Unlock (L : not null access Lock) is
- begin
- null;
- end Unlock;
-
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- begin
- null;
- end Unlock;
-
- procedure Unlock (T : Task_Id) is
- begin
- null;
- end Unlock;
-
- ----------------
- -- Unlock_RTS --
- ----------------
-
- procedure Unlock_RTS is
- begin
- null;
- end Unlock_RTS;
- ------------
- -- Wakeup --
- ------------
-
- procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
- begin
- null;
- end Wakeup;
-
- ----------------
- -- Write_Lock --
- ----------------
-
- procedure Write_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- begin
- Ceiling_Violation := False;
- end Write_Lock;
-
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- begin
- null;
- end Write_Lock;
-
- procedure Write_Lock (T : Task_Id) is
- begin
- null;
- end Write_Lock;
-
- -----------
- -- Yield --
- -----------
-
- procedure Yield (Do_Yield : Boolean := True) is
- begin
- null;
- end Yield;
-
-end System.Task_Primitives.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2011, 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 a HP-UX DCE threads (HPUX 10) version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-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_Primitives.Interrupt_Operations;
-
-pragma Warnings (Off);
-with System.Interrupt_Management.Operations;
-pragma Elaborate_All (System.Interrupt_Management.Operations);
-pragma Warnings (On);
-
-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;
-
- package PIO renames System.Task_Primitives.Interrupt_Operations;
-
- ----------------
- -- 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 unblocked in all tasks
-
- 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");
-
- -- Note: the reason that Locking_Policy is not needed is that this
- -- is not implemented for DCE threads. The HPUX 10 port is at this
- -- stage considered dead, and no further work is planned on it.
-
- Foreign_Task_Elaborated : aliased Boolean := True;
- -- Used to identified fake tasks (i.e., non-Ada Threads)
-
- --------------------
- -- 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 the 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) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread
-
- function Register_Foreign_Thread
- (Thread : Thread_Id) return Task_Id is separate;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Abort_Handler (Sig : Signal);
-
- function To_Address is
- new Ada.Unchecked_Conversion (Task_Id, System.Address);
-
- -------------------
- -- Abort_Handler --
- -------------------
-
- procedure Abort_Handler (Sig : Signal) is
- pragma Unreferenced (Sig);
-
- Self_Id : constant Task_Id := Self;
- Result : Interfaces.C.int;
- Old_Set : aliased sigset_t;
-
- begin
- if Self_Id.Deferral_Level = 0
- and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
- and then not Self_Id.Aborting
- then
- Self_Id.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;
-
- -----------------
- -- Stack_Guard --
- -----------------
-
- -- The underlying thread system sets a guard page at the bottom of a thread
- -- stack, so nothing is needed.
- -- ??? Check the comment above
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- pragma Unreferenced (T, On);
- begin
- null;
- 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;
-
- L.Priority := Prio;
-
- Result := pthread_mutex_init (L.L'Access, Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- 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;
-
- Result := pthread_mutex_init (L, Attributes'Access);
-
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- 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.L'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
- L.Owner_Priority := Get_Priority (Self);
-
- if L.Priority < L.Owner_Priority then
- Ceiling_Violation := True;
- return;
- end if;
-
- Result := pthread_mutex_lock (L.L'Access);
- pragma Assert (Result = 0);
- Ceiling_Violation := False;
- 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.L'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 --
- -----------------
-
- procedure Timed_Sleep
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes;
- Reason : System.Tasking.Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- pragma Unreferenced (Reason);
-
- Check_Time : constant Duration := Monotonic_Clock;
- Abs_Time : Duration;
- Request : aliased timespec;
- Result : Interfaces.C.int;
-
- begin
- Timedout := True;
- Yielded := False;
-
- Abs_Time :=
- (if Mode = Relative
- then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (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);
-
- exit when Abs_Time <= Monotonic_Clock;
-
- 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 --
- -----------------
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Check_Time : constant Duration := Monotonic_Clock;
- Abs_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);
-
- Abs_Time :=
- (if Mode = Relative
- then Time + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (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);
-
- exit when Abs_Time <= Monotonic_Clock;
-
- 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 (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
- pragma Assert (Result = 0);
- return To_Duration (TS);
- end Monotonic_Clock;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- begin
- return 10#1.0#E-6;
- 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 --
- ------------------
-
- type Prio_Array_Type is array (System.Any_Priority) of Integer;
- pragma Atomic_Components (Prio_Array_Type);
-
- Prio_Array : Prio_Array_Type;
- -- Global array containing the id of the currently running task for
- -- each priority.
- --
- -- Note: assume we are on single processor with run-til-blocked scheduling
-
- procedure Set_Priority
- (T : Task_Id;
- Prio : System.Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- Result : Interfaces.C.int;
- Array_Item : Integer;
- 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
- Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
-
- if 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);
-
- if Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' then
-
- -- Annex D requirement [RM D.2.2 par. 9]:
- -- If the task drops its priority due to the loss of inherited
- -- priority, it is added at the head of the ready queue for its
- -- new active priority.
-
- if Loss_Of_Inheritance
- and then Prio < T.Common.Current_Priority
- then
- Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
- Prio_Array (T.Common.Base_Priority) := Array_Item;
-
- loop
- -- Let some processes a chance to arrive
-
- Yield;
-
- -- Then wait for our turn to proceed
-
- exit when Array_Item = Prio_Array (T.Common.Base_Priority)
- or else Prio_Array (T.Common.Base_Priority) = 1;
- end loop;
-
- Prio_Array (T.Common.Base_Priority) :=
- Prio_Array (T.Common.Base_Priority) - 1;
- end if;
- end if;
-
- T.Common.Current_Priority := Prio;
- 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;
- Specific.Set (Self_ID);
- 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
- if not Single_Lock then
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = 0 then
- 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 :=
- 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;
- Result : Interfaces.C.int;
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- begin
- 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_setstacksize
- (Attributes'Access, Interfaces.C.size_t (Stack_Size));
- pragma Assert (Result = 0);
-
- -- 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.
-
- Result := pthread_create
- (T.Common.LL.Thread'Access,
- Attributes'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
- pragma Assert (Result = 0 or else Result = EAGAIN);
-
- Succeeded := Result = 0;
-
- pthread_detach (T.Common.LL.Thread'Access);
- -- Detach the thread using pthread_detach, since DCE threads do not have
- -- pthread_attr_set_detachstate.
-
- Result := pthread_attr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
-
- Set_Priority (T, Priority);
- 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
- Specific.Set (null);
- end Exit_Task;
-
- ----------------
- -- Abort_Task --
- ----------------
-
- procedure Abort_Task (T : Task_Id) is
- begin
- -- Interrupt Server_Tasks may be waiting on an "event" flag (signal)
-
- if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
- System.Interrupt_Management.Operations.Interrupt_Self_Process
- (PIO.Get_Interrupt_ID (T));
- 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 (ARM D.10(6)))
-
- S.State := False;
- S.Waiting := False;
-
- -- Initialize internal mutex
-
- Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- -- Initialize internal condition variable
-
- 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);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
- end if;
- 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 ARM D.10 par. 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
- -- (ARM D.10 par. 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
- pragma Unreferenced (T);
- pragma Unreferenced (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);
- pragma Unreferenced (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);
-
- -- 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);
-
- -- Install the abort-signal handler
-
- 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);
- end if;
- end Initialize;
-
- -- NOTE: Unlike other pthread implementations, we do *not* mask all
- -- signals here since we handle signals using the process-wide primitive
- -- signal, rather than using sigthreadmask and sigwait. The reason of
- -- this difference is that sigwait doesn't work when some critical
- -- signals (SIGABRT, SIGPIPE) are masked.
-
- -----------------------
- -- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA 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 --
--- <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 a GNU/Linux (GNU/LinuxThreads) version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-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 Interfaces.C; use Interfaces; use type Interfaces.C.int;
-
-with System.Task_Info;
-with System.Tasking.Debug;
-with System.Interrupt_Management;
-with System.OS_Constants;
-with System.OS_Primitives;
-with System.Multiprocessors;
-
-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 System.OS_Interface;
- use System.Parameters;
- use System.OS_Primitives;
- use System.Task_Info;
-
- ----------------
- -- 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
-
- Null_Thread_Id : constant pthread_t := pthread_t'Last;
- -- Constant to indicate that the thread identifier has not yet been
- -- initialized.
-
- --------------------
- -- 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) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread
-
- function Register_Foreign_Thread
- (Thread : Thread_Id) return Task_Id is separate;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Abort_Handler (signo : Signal);
-
- function GNAT_pthread_condattr_setup
- (attr : access pthread_condattr_t) return C.int;
- pragma Import
- (C, GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
-
- function GNAT_has_cap_sys_nice return C.int;
- pragma Import
- (C, GNAT_has_cap_sys_nice, "__gnat_has_cap_sys_nice");
- -- We do not have pragma Linker_Options ("-lcap"); here, because this
- -- library is not present on many Linux systems. 'libcap' is the Linux
- -- "capabilities" library, called by __gnat_has_cap_sys_nice.
-
- function Prio_To_Linux_Prio (Prio : Any_Priority) return C.int is
- (C.int (Prio) + 1);
- -- Convert Ada priority to Linux priority. Priorities are 1 .. 99 on
- -- GNU/Linux, so we map 0 .. 98 to 1 .. 99.
-
- function Get_Ceiling_Support return Boolean;
- -- Get the value of the Ceiling_Support constant (see below).
- -- Note well: If this function or related code is modified, it should be
- -- tested by hand, because automated testing doesn't exercise it.
-
- function Get_Ceiling_Support return Boolean is
- Ceiling_Support : Boolean := False;
- begin
- if Locking_Policy /= 'C' then
- return False;
- end if;
-
- declare
- function geteuid return Integer;
- pragma Import (C, geteuid, "geteuid");
- Superuser : constant Boolean := geteuid = 0;
- Has_Cap : constant C.int := GNAT_has_cap_sys_nice;
- pragma Assert (Has_Cap in 0 | 1);
- begin
- Ceiling_Support := Superuser or else Has_Cap = 1;
- end;
-
- return Ceiling_Support;
- end Get_Ceiling_Support;
-
- pragma Warnings (Off, "non-static call not allowed in preelaborated unit");
- Ceiling_Support : constant Boolean := Get_Ceiling_Support;
- pragma Warnings (On, "non-static call not allowed in preelaborated unit");
- -- True if the locking policy is Ceiling_Locking, and the current process
- -- has permission to use this policy. The process has permission if it is
- -- running as 'root', or if the capability was set by the setcap command,
- -- as in "sudo /sbin/setcap cap_sys_nice=ep exe_file". If it doesn't have
- -- permission, then a request for Ceiling_Locking is ignored.
-
- type RTS_Lock_Ptr is not null access all RTS_Lock;
-
- function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int;
- -- Initialize the mutex L. If Ceiling_Support is True, then set the ceiling
- -- to Prio. Returns 0 for success, or ENOMEM for out-of-memory.
-
- -------------------
- -- Abort_Handler --
- -------------------
-
- procedure Abort_Handler (signo : Signal) is
- pragma Unreferenced (signo);
-
- Self_Id : constant Task_Id := Self;
- Result : C.int;
- Old_Set : aliased sigset_t;
-
- 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 Self_Id.Deferral_Level = 0
- and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
- and then not Self_Id.Aborting
- then
- Self_Id.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;
-
- --------------
- -- 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;
-
- -----------------
- -- Stack_Guard --
- -----------------
-
- -- The underlying thread system extends the memory (up to 2MB) when needed
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- pragma Unreferenced (T);
- pragma Unreferenced (On);
- begin
- null;
- 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;
-
- ----------------
- -- Init_Mutex --
- ----------------
-
- function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int is
- Mutex_Attr : aliased pthread_mutexattr_t;
- Result, Result_2 : C.int;
-
- begin
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result in 0 | ENOMEM);
-
- if Result = ENOMEM then
- return Result;
- end if;
-
- if Ceiling_Support then
- Result := pthread_mutexattr_setprotocol
- (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
- pragma Assert (Result = 0);
-
- Result := pthread_mutexattr_setprioceiling
- (Mutex_Attr'Access, Prio_To_Linux_Prio (Prio));
- 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 (L, Mutex_Attr'Access);
- pragma Assert (Result in 0 | ENOMEM);
-
- Result_2 := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result_2 = 0);
- return Result; -- of pthread_mutex_init, not pthread_mutexattr_destroy
- end Init_Mutex;
-
- ---------------------
- -- 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 : Any_Priority;
- L : not null access Lock)
- is
- begin
- if Locking_Policy = 'R' then
- declare
- RWlock_Attr : aliased pthread_rwlockattr_t;
- Result : C.int;
-
- begin
- -- Set the rwlock to prefer writer to avoid writers starvation
-
- Result := pthread_rwlockattr_init (RWlock_Attr'Access);
- pragma Assert (Result = 0);
-
- Result := pthread_rwlockattr_setkind_np
- (RWlock_Attr'Access,
- PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP);
- pragma Assert (Result = 0);
-
- Result := pthread_rwlock_init (L.RW'Access, RWlock_Attr'Access);
-
- pragma Assert (Result in 0 | ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error with "Failed to allocate a lock";
- end if;
- end;
-
- else
- if Init_Mutex (L.WO'Access, Prio) = ENOMEM then
- raise Storage_Error with "Failed to allocate a lock";
- end if;
- end if;
- end Initialize_Lock;
-
- procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level)
- is
- pragma Unreferenced (Level);
- begin
- if Init_Mutex (L.all'Access, Any_Priority'Last) = ENOMEM then
- raise Storage_Error with "Failed to allocate a lock";
- end if;
- end Initialize_Lock;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : not null access Lock) is
- Result : C.int;
- begin
- if Locking_Policy = 'R' then
- Result := pthread_rwlock_destroy (L.RW'Access);
- else
- Result := pthread_mutex_destroy (L.WO'Access);
- end if;
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : not null access RTS_Lock) is
- Result : 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 : C.int;
- begin
- if Locking_Policy = 'R' then
- Result := pthread_rwlock_wrlock (L.RW'Access);
- else
- Result := pthread_mutex_lock (L.WO'Access);
- end if;
-
- -- The cause of EINVAL is a priority ceiling violation
-
- pragma Assert (Result in 0 | EINVAL);
- Ceiling_Violation := Result = EINVAL;
- end Write_Lock;
-
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : 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 : 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
- Result : C.int;
- begin
- if Locking_Policy = 'R' then
- Result := pthread_rwlock_rdlock (L.RW'Access);
- else
- Result := pthread_mutex_lock (L.WO'Access);
- end if;
-
- -- The cause of EINVAL is a priority ceiling violation
-
- pragma Assert (Result in 0 | EINVAL);
- Ceiling_Violation := Result = EINVAL;
- end Read_Lock;
-
- ------------
- -- Unlock --
- ------------
-
- procedure Unlock (L : not null access Lock) is
- Result : C.int;
- begin
- if Locking_Policy = 'R' then
- Result := pthread_rwlock_unlock (L.RW'Access);
- else
- Result := pthread_mutex_unlock (L.WO'Access);
- end if;
- pragma Assert (Result = 0);
- end Unlock;
-
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : 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 : 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 : 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 : C.int;
-
- begin
- pragma Assert (Self_ID = Self);
-
- 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 in 0 | 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 : System.Tasking.Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- pragma Unreferenced (Reason);
-
- Base_Time : constant Duration := Monotonic_Clock;
- Check_Time : Duration := Base_Time;
- Abs_Time : Duration;
- Request : aliased timespec;
- Result : C.int;
-
- begin
- Timedout := True;
- Yielded := False;
-
- Abs_Time :=
- (if Mode = Relative
- then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (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 in 0 | 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 : constant Duration := Monotonic_Clock;
- Check_Time : Duration := Base_Time;
- Abs_Time : Duration;
- Request : aliased timespec;
-
- Result : C.int;
- pragma Warnings (Off, Result);
-
- begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
- Write_Lock (Self_ID);
-
- Abs_Time :=
- (if Mode = Relative
- then Time + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (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 in 0 | ETIMEDOUT | 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 : 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 : 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 : 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 : 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 : Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- pragma Unreferenced (Loss_Of_Inheritance);
-
- Result : C.int;
- Param : aliased struct_sched_param;
-
- function Get_Policy (Prio : 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 := Prio_To_Linux_Prio (Prio);
-
- if 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
- Param.sched_priority := 0;
- Result :=
- pthread_setschedparam
- (T.Common.LL.Thread,
- SCHED_OTHER, Param'Access);
- end if;
-
- pragma Assert (Result in 0 | EPERM | EINVAL);
- end Set_Priority;
-
- ------------------
- -- Get_Priority --
- ------------------
-
- function Get_Priority (T : Task_Id) return Any_Priority is
- begin
- return T.Common.Current_Priority;
- end Get_Priority;
-
- ----------------
- -- Enter_Task --
- ----------------
-
- procedure Enter_Task (Self_ID : Task_Id) is
- begin
- if Self_ID.Common.Task_Info /= null
- and then Self_ID.Common.Task_Info.CPU_Affinity = No_CPU
- then
- raise Invalid_CPU_Number;
- end if;
-
- Self_ID.Common.LL.Thread := pthread_self;
- Self_ID.Common.LL.LWP := lwp_self;
-
- -- Set thread name to ease debugging. If the name of the task is
- -- "foreign thread" (as set by Register_Foreign_Thread) retrieve
- -- the name of the thread and update the name of the task instead.
-
- if Self_ID.Common.Task_Image_Len = 14
- and then Self_ID.Common.Task_Image (1 .. 14) = "foreign thread"
- then
- declare
- Thread_Name : String (1 .. 16);
- -- PR_GET_NAME returns a string of up to 16 bytes
-
- Len : Natural := 0;
- -- Length of the task name contained in Task_Name
-
- Result : C.int;
- -- Result from the prctl call
- begin
- Result := prctl (PR_GET_NAME, unsigned_long (Thread_Name'Address));
- pragma Assert (Result = 0);
-
- -- Find the length of the given name
-
- for J in Thread_Name'Range loop
- if Thread_Name (J) /= ASCII.NUL then
- Len := Len + 1;
- else
- exit;
- end if;
- end loop;
-
- -- Cover the odd situation where someone decides to change
- -- Parameters.Max_Task_Image_Length to less than 16 characters.
-
- if Len > Parameters.Max_Task_Image_Length then
- Len := Parameters.Max_Task_Image_Length;
- end if;
-
- -- Copy the name of the thread to the task's ATCB
-
- Self_ID.Common.Task_Image (1 .. Len) := Thread_Name (1 .. Len);
- Self_ID.Common.Task_Image_Len := Len;
- end;
-
- elsif Self_ID.Common.Task_Image_Len > 0 then
- declare
- Task_Name : String (1 .. Parameters.Max_Task_Image_Length + 1);
- Result : C.int;
-
- begin
- Task_Name (1 .. Self_ID.Common.Task_Image_Len) :=
- Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len);
- Task_Name (Self_ID.Common.Task_Image_Len + 1) := ASCII.NUL;
-
- Result := prctl (PR_SET_NAME, unsigned_long (Task_Name'Address));
- pragma Assert (Result = 0);
- end;
- end if;
-
- Specific.Set (Self_ID);
-
- if Use_Alternate_Stack
- and then Self_ID.Common.Task_Alternate_Stack /= Null_Address
- then
- declare
- Stack : aliased stack_t;
- Result : 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
- Result : 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);
-
- Self_ID.Common.LL.Thread := Null_Thread_Id;
-
- if not Single_Lock then
- if Init_Mutex
- (Self_ID.Common.LL.L'Access, Any_Priority'Last) /= 0
- then
- Succeeded := False;
- return;
- end if;
- end if;
-
- Result := pthread_condattr_init (Cond_Attr'Access);
- pragma Assert (Result in 0 | 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 in 0 | 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 : Any_Priority;
- Succeeded : out Boolean)
- is
- Thread_Attr : aliased pthread_attr_t;
- Adjusted_Stack_Size : C.size_t;
- Result : C.int;
-
- use type Multiprocessors.CPU_Range, Interfaces.C.size_t;
-
- begin
- -- Check whether both Dispatching_Domain and CPU are specified for
- -- the task, and the CPU value is not contained within the range of
- -- processors for the domain.
-
- if T.Common.Domain /= null
- and then T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU
- and then
- (T.Common.Base_CPU not in T.Common.Domain'Range
- or else not T.Common.Domain (T.Common.Base_CPU))
- then
- Succeeded := False;
- return;
- end if;
-
- Adjusted_Stack_Size := C.size_t (Stack_Size + Alternate_Stack_Size);
-
- Result := pthread_attr_init (Thread_Attr'Access);
- pragma Assert (Result in 0 | ENOMEM);
-
- if Result /= 0 then
- Succeeded := False;
- return;
- end if;
-
- Result :=
- pthread_attr_setstacksize (Thread_Attr'Access, Adjusted_Stack_Size);
- pragma Assert (Result = 0);
-
- Result :=
- pthread_attr_setdetachstate
- (Thread_Attr'Access, PTHREAD_CREATE_DETACHED);
- pragma Assert (Result = 0);
-
- -- Set the required attributes for the creation of the thread
-
- -- Note: Previously, we called pthread_setaffinity_np (after thread
- -- creation but before thread activation) to set the affinity but it was
- -- not behaving as expected. Setting the required attributes for the
- -- creation of the thread works correctly and it is more appropriate.
-
- -- Do nothing if required support not provided by the operating system
-
- if pthread_attr_setaffinity_np'Address = Null_Address then
- null;
-
- -- Support is available
-
- elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
- declare
- CPUs : constant size_t :=
- C.size_t (Multiprocessors.Number_Of_CPUs);
- CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
- Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
-
- begin
- CPU_ZERO (Size, CPU_Set);
- System.OS_Interface.CPU_SET
- (int (T.Common.Base_CPU), Size, CPU_Set);
- Result :=
- pthread_attr_setaffinity_np (Thread_Attr'Access, Size, CPU_Set);
- pragma Assert (Result = 0);
-
- CPU_FREE (CPU_Set);
- end;
-
- -- Handle Task_Info
-
- elsif T.Common.Task_Info /= null then
- Result :=
- pthread_attr_setaffinity_np
- (Thread_Attr'Access,
- CPU_SETSIZE / 8,
- T.Common.Task_Info.CPU_Affinity'Access);
- pragma Assert (Result = 0);
-
- -- Handle dispatching domains
-
- -- To avoid changing CPU affinities when not needed, we set the
- -- affinity only when assigning to a domain other than the default
- -- one, or when the default one has been modified.
-
- elsif T.Common.Domain /= null and then
- (T.Common.Domain /= ST.System_Domain
- or else T.Common.Domain.all /=
- (Multiprocessors.CPU'First ..
- Multiprocessors.Number_Of_CPUs => True))
- then
- declare
- CPUs : constant size_t :=
- C.size_t (Multiprocessors.Number_Of_CPUs);
- CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
- Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
-
- begin
- CPU_ZERO (Size, CPU_Set);
-
- -- Set the affinity to all the processors belonging to the
- -- dispatching domain.
-
- for Proc in T.Common.Domain'Range loop
- if T.Common.Domain (Proc) then
- System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
- end if;
- end loop;
-
- Result :=
- pthread_attr_setaffinity_np (Thread_Attr'Access, Size, CPU_Set);
- pragma Assert (Result = 0);
-
- CPU_FREE (CPU_Set);
- end;
- 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,
- Thread_Attr'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
-
- pragma Assert (Result in 0 | EAGAIN | ENOMEM);
-
- if Result /= 0 then
- Succeeded := False;
- Result := pthread_attr_destroy (Thread_Attr'Access);
- pragma Assert (Result = 0);
- return;
- end if;
-
- Succeeded := True;
-
- Result := pthread_attr_destroy (Thread_Attr'Access);
- pragma Assert (Result = 0);
-
- Set_Priority (T, Priority);
- end Create_Task;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- Result : 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
- Specific.Set (null);
- end Exit_Task;
-
- ----------------
- -- Abort_Task --
- ----------------
-
- procedure Abort_Task (T : Task_Id) is
- Result : C.int;
-
- ESRCH : constant := 3; -- No such process
- -- It can happen that T has already vanished, in which case pthread_kill
- -- returns ESRCH, so we don't consider that to be an error.
-
- begin
- if Abort_Handler_Installed then
- Result :=
- pthread_kill
- (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
- pragma Assert (Result in 0 | ESRCH);
- end if;
- end Abort_Task;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (S : in out Suspension_Object) is
- Result : C.int;
-
- begin
- -- Initialize internal state (always to False (RM D.10(6)))
-
- S.State := False;
- S.Waiting := False;
-
- -- Initialize internal mutex
-
- Result := pthread_mutex_init (S.L'Access, null);
-
- pragma Assert (Result in 0 | ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- -- Initialize internal condition variable
-
- Result := pthread_cond_init (S.CV'Access, null);
-
- pragma Assert (Result in 0 | ENOMEM);
-
- if Result /= 0 then
- Result := pthread_mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
- end if;
- end Initialize;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (S : in out Suspension_Object) is
- Result : 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 : 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 : 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 ARM D.10 par. 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 : 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). This should not
- -- happen with the current Linux implementation of pthread, but
- -- POSIX does not guarantee it so this may change in future.
-
- Result := pthread_cond_wait (S.CV'Access, S.L'Access);
- pragma Assert (Result in 0 | 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;
-
- ------------------
- -- 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 : C.int;
- -- Whether to use an alternate signal stack for stack overflows
-
- 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 be 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_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- -- Initialize the global RTS lock
-
- 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 (Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
- Abort_Handler_Installed := True;
- end if;
-
- -- pragma CPU and dispatching domains for the environment task
-
- Set_Task_Affinity (Environment_Task);
- end Initialize;
-
- -----------------------
- -- Set_Task_Affinity --
- -----------------------
-
- procedure Set_Task_Affinity (T : ST.Task_Id) is
- use type Multiprocessors.CPU_Range;
-
- begin
- -- Do nothing if there is no support for setting affinities or the
- -- underlying thread has not yet been created. If the thread has not
- -- yet been created then the proper affinity will be set during its
- -- creation.
-
- if pthread_setaffinity_np'Address /= Null_Address
- and then T.Common.LL.Thread /= Null_Thread_Id
- then
- declare
- CPUs : constant size_t :=
- C.size_t (Multiprocessors.Number_Of_CPUs);
- CPU_Set : cpu_set_t_ptr := null;
- Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
-
- Result : C.int;
-
- begin
- -- We look at the specific CPU (Base_CPU) first, then at the
- -- Task_Info field, and finally at the assigned dispatching
- -- domain, if any.
-
- if T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
-
- -- Set the affinity to an unique CPU
-
- CPU_Set := CPU_ALLOC (CPUs);
- System.OS_Interface.CPU_ZERO (Size, CPU_Set);
- System.OS_Interface.CPU_SET
- (int (T.Common.Base_CPU), Size, CPU_Set);
-
- -- Handle Task_Info
-
- elsif T.Common.Task_Info /= null then
- CPU_Set := T.Common.Task_Info.CPU_Affinity'Access;
-
- -- Handle dispatching domains
-
- elsif T.Common.Domain /= null and then
- (T.Common.Domain /= ST.System_Domain
- or else T.Common.Domain.all /=
- (Multiprocessors.CPU'First ..
- Multiprocessors.Number_Of_CPUs => True))
- then
- -- Set the affinity to all the processors belonging to the
- -- dispatching domain. To avoid changing CPU affinities when
- -- not needed, we set the affinity only when assigning to a
- -- domain other than the default one, or when the default one
- -- has been modified.
-
- CPU_Set := CPU_ALLOC (CPUs);
- System.OS_Interface.CPU_ZERO (Size, CPU_Set);
-
- for Proc in T.Common.Domain'Range loop
- if T.Common.Domain (Proc) then
- System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
- end if;
- end loop;
- end if;
-
- -- We set the new affinity if needed. Otherwise, the new task
- -- will inherit its creator's CPU affinity mask (according to
- -- the documentation of pthread_setaffinity_np), which is
- -- consistent with Ada's required semantics.
-
- if CPU_Set /= null then
- Result :=
- pthread_setaffinity_np (T.Common.LL.Thread, Size, CPU_Set);
- pragma Assert (Result = 0);
-
- CPU_FREE (CPU_Set);
- end if;
- end;
- end if;
- end Set_Task_Affinity;
-
-end System.Task_Primitives.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . 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 --
--- <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 a NT (native) version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-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 Interfaces.C;
-with Interfaces.C.Strings;
-
-with System.Float_Control;
-with System.Interrupt_Management;
-with System.Multiprocessors;
-with System.OS_Primitives;
-with System.Task_Info;
-with System.Tasking.Debug;
-with System.Win32.Ext;
-
-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 SSL renames System.Soft_Links;
-
- use Interfaces.C;
- use Interfaces.C.Strings;
- use System.OS_Interface;
- use System.OS_Primitives;
- use System.Parameters;
- use System.Task_Info;
- use System.Tasking;
- use System.Tasking.Debug;
- use System.Win32;
- use System.Win32.Ext;
-
- pragma Link_With ("-Xlinker --stack=0x200000,0x1000");
- -- Change the default stack size (2 MB) for tasking programs on Windows.
- -- This allows about 1000 tasks running at the same time. Note that
- -- we set the stack size for non tasking programs on System unit.
- -- Also note that under Windows XP, we use a Windows XP extension to
- -- specify the stack size on a per task basis, as done under other OSes.
-
- ---------------------
- -- Local Functions --
- ---------------------
-
- procedure InitializeCriticalSection (pCriticalSection : access RTS_Lock);
- procedure InitializeCriticalSection
- (pCriticalSection : access CRITICAL_SECTION);
- pragma Import
- (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
-
- procedure EnterCriticalSection (pCriticalSection : access RTS_Lock);
- procedure EnterCriticalSection
- (pCriticalSection : access CRITICAL_SECTION);
- pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
-
- procedure LeaveCriticalSection (pCriticalSection : access RTS_Lock);
- procedure LeaveCriticalSection (pCriticalSection : access CRITICAL_SECTION);
- pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
-
- procedure DeleteCriticalSection (pCriticalSection : access RTS_Lock);
- procedure DeleteCriticalSection
- (pCriticalSection : access CRITICAL_SECTION);
- pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
-
- ----------------
- -- Local Data --
- ----------------
-
- Environment_Task_Id : Task_Id;
- -- A variable to hold Task_Id for the environment task
-
- 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
-
- 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");
-
- function Get_Policy (Prio : System.Any_Priority) return Character;
- pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
- -- Get priority specific dispatching policy
-
- Foreign_Task_Elaborated : aliased Boolean := True;
- -- Used to identified fake tasks (i.e., non-Ada Threads)
-
- Null_Thread_Id : constant Thread_Id := 0;
- -- Constant to indicate that the thread identifier has not yet been
- -- initialized.
-
- ------------------------------------
- -- The thread local storage index --
- ------------------------------------
-
- TlsIndex : DWORD;
- pragma Export (Ada, TlsIndex);
- -- To ensure that this variable won't be local to this package, since
- -- in some cases, inlining forces this variable to be global anyway.
-
- --------------------
- -- Local Packages --
- --------------------
-
- package Specific is
-
- 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
-
- end Specific;
-
- package body Specific is
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- begin
- return TlsGetValue (TlsIndex) /= System.Null_Address;
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- Succeeded : BOOL;
- begin
- Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
- pragma Assert (Succeeded = Win32.TRUE);
- end Set;
-
- end 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) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread
-
- function Register_Foreign_Thread
- (Thread : Thread_Id) return Task_Id is separate;
-
- ----------------------------------
- -- Condition Variable Functions --
- ----------------------------------
-
- procedure Initialize_Cond (Cond : not null access Condition_Variable);
- -- Initialize given condition variable Cond
-
- procedure Finalize_Cond (Cond : not null access Condition_Variable);
- -- Finalize given condition variable Cond
-
- procedure Cond_Signal (Cond : not null access Condition_Variable);
- -- Signal condition variable Cond
-
- procedure Cond_Wait
- (Cond : not null access Condition_Variable;
- L : not null access RTS_Lock);
- -- Wait on conditional variable Cond, using lock L
-
- procedure Cond_Timed_Wait
- (Cond : not null access Condition_Variable;
- L : not null access RTS_Lock;
- Rel_Time : Duration;
- Timed_Out : out Boolean;
- Status : out Integer);
- -- Do timed wait on condition variable Cond using lock L. The duration
- -- of the timed wait is given by Rel_Time. When the condition is
- -- signalled, Timed_Out shows whether or not a time out occurred.
- -- Status is only valid if Timed_Out is False, in which case it
- -- shows whether Cond_Timed_Wait completed successfully.
-
- ---------------------
- -- Initialize_Cond --
- ---------------------
-
- procedure Initialize_Cond (Cond : not null access Condition_Variable) is
- hEvent : HANDLE;
- begin
- hEvent := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
- pragma Assert (hEvent /= 0);
- Cond.all := Condition_Variable (hEvent);
- end Initialize_Cond;
-
- -------------------
- -- Finalize_Cond --
- -------------------
-
- -- No such problem here, DosCloseEventSem has been derived.
- -- What does such refer to in above comment???
-
- procedure Finalize_Cond (Cond : not null access Condition_Variable) is
- Result : BOOL;
- begin
- Result := CloseHandle (HANDLE (Cond.all));
- pragma Assert (Result = Win32.TRUE);
- end Finalize_Cond;
-
- -----------------
- -- Cond_Signal --
- -----------------
-
- procedure Cond_Signal (Cond : not null access Condition_Variable) is
- Result : BOOL;
- begin
- Result := SetEvent (HANDLE (Cond.all));
- pragma Assert (Result = Win32.TRUE);
- end Cond_Signal;
-
- ---------------
- -- Cond_Wait --
- ---------------
-
- -- Pre-condition: Cond is posted
- -- L is locked.
-
- -- Post-condition: Cond is posted
- -- L is locked.
-
- procedure Cond_Wait
- (Cond : not null access Condition_Variable;
- L : not null access RTS_Lock)
- is
- Result : DWORD;
- Result_Bool : BOOL;
-
- begin
- -- Must reset Cond BEFORE L is unlocked
-
- Result_Bool := ResetEvent (HANDLE (Cond.all));
- pragma Assert (Result_Bool = Win32.TRUE);
- Unlock (L, Global_Lock => True);
-
- -- No problem if we are interrupted here: if the condition is signaled,
- -- WaitForSingleObject will simply not block
-
- Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
- pragma Assert (Result = 0);
-
- Write_Lock (L, Global_Lock => True);
- end Cond_Wait;
-
- ---------------------
- -- Cond_Timed_Wait --
- ---------------------
-
- -- Pre-condition: Cond is posted
- -- L is locked.
-
- -- Post-condition: Cond is posted
- -- L is locked.
-
- procedure Cond_Timed_Wait
- (Cond : not null access Condition_Variable;
- L : not null access RTS_Lock;
- Rel_Time : Duration;
- Timed_Out : out Boolean;
- Status : out Integer)
- is
- Time_Out_Max : constant DWORD := 16#FFFF0000#;
- -- NT 4 can't handle excessive timeout values (e.g. DWORD'Last - 1)
-
- Time_Out : DWORD;
- Result : BOOL;
- Wait_Result : DWORD;
-
- begin
- -- Must reset Cond BEFORE L is unlocked
-
- Result := ResetEvent (HANDLE (Cond.all));
- pragma Assert (Result = Win32.TRUE);
- Unlock (L, Global_Lock => True);
-
- -- No problem if we are interrupted here: if the condition is signaled,
- -- WaitForSingleObject will simply not block.
-
- if Rel_Time <= 0.0 then
- Timed_Out := True;
- Wait_Result := 0;
-
- else
- Time_Out :=
- (if Rel_Time >= Duration (Time_Out_Max) / 1000
- then Time_Out_Max
- else DWORD (Rel_Time * 1000));
-
- Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
-
- if Wait_Result = WAIT_TIMEOUT then
- Timed_Out := True;
- Wait_Result := 0;
- else
- Timed_Out := False;
- end if;
- end if;
-
- Write_Lock (L, Global_Lock => True);
-
- -- Ensure post-condition
-
- if Timed_Out then
- Result := SetEvent (HANDLE (Cond.all));
- pragma Assert (Result = Win32.TRUE);
- end if;
-
- Status := Integer (Wait_Result);
- end Cond_Timed_Wait;
-
- ------------------
- -- Stack_Guard --
- ------------------
-
- -- The underlying thread system sets a guard page at the bottom of a thread
- -- stack, so nothing is needed.
- -- ??? Check the comment above
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- pragma Unreferenced (T, On);
- begin
- null;
- 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 is
- Self_Id : constant Task_Id := To_Task_Id (TlsGetValue (TlsIndex));
- begin
- if Self_Id = null then
- return Register_Foreign_Thread (GetCurrentThread);
- else
- return Self_Id;
- end if;
- end 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 the 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
- begin
- InitializeCriticalSection (L.Mutex'Access);
- L.Owner_Priority := 0;
- L.Priority := Prio;
- end Initialize_Lock;
-
- procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level)
- is
- pragma Unreferenced (Level);
- begin
- InitializeCriticalSection (L);
- end Initialize_Lock;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : not null access Lock) is
- begin
- DeleteCriticalSection (L.Mutex'Access);
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : not null access RTS_Lock) is
- begin
- DeleteCriticalSection (L);
- end Finalize_Lock;
-
- ----------------
- -- Write_Lock --
- ----------------
-
- procedure Write_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean) is
- begin
- L.Owner_Priority := Get_Priority (Self);
-
- if L.Priority < L.Owner_Priority then
- Ceiling_Violation := True;
- return;
- end if;
-
- EnterCriticalSection (L.Mutex'Access);
-
- Ceiling_Violation := False;
- end Write_Lock;
-
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- begin
- if not Single_Lock or else Global_Lock then
- EnterCriticalSection (L);
- end if;
- end Write_Lock;
-
- procedure Write_Lock (T : Task_Id) is
- begin
- if not Single_Lock then
- EnterCriticalSection (T.Common.LL.L'Access);
- 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
- begin
- LeaveCriticalSection (L.Mutex'Access);
- end Unlock;
-
- procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False) is
- begin
- if not Single_Lock or else Global_Lock then
- LeaveCriticalSection (L);
- end if;
- end Unlock;
-
- procedure Unlock (T : Task_Id) is
- begin
- if not Single_Lock then
- LeaveCriticalSection (T.Common.LL.L'Access);
- 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);
-
- begin
- pragma Assert (Self_ID = Self);
-
- if Single_Lock then
- Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
- else
- Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
- end if;
-
- if Self_ID.Deferral_Level = 0
- and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- then
- Unlock (Self_ID);
- raise Standard'Abort_Signal;
- end if;
- 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 : System.Tasking.Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- pragma Unreferenced (Reason);
- Check_Time : Duration := Monotonic_Clock;
- Rel_Time : Duration;
- Abs_Time : Duration;
-
- Result : Integer;
- pragma Unreferenced (Result);
-
- Local_Timedout : Boolean;
-
- begin
- Timedout := True;
- Yielded := False;
-
- if Mode = Relative then
- Rel_Time := Time;
- Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
- else
- Rel_Time := Time - Check_Time;
- Abs_Time := Time;
- end if;
-
- if Rel_Time > 0.0 then
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- if Single_Lock then
- Cond_Timed_Wait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Rel_Time, Local_Timedout, Result);
- else
- Cond_Timed_Wait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access,
- Rel_Time, Local_Timedout, Result);
- end if;
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time;
-
- if not Local_Timedout then
-
- -- Somebody may have called Wakeup for us
-
- Timedout := False;
- exit;
- end if;
-
- Rel_Time := Abs_Time - Check_Time;
- end loop;
- end if;
- end Timed_Sleep;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Check_Time : Duration := Monotonic_Clock;
- Rel_Time : Duration;
- Abs_Time : Duration;
-
- Timedout : Boolean;
- Result : Integer;
- pragma Unreferenced (Timedout, Result);
-
- begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
- Write_Lock (Self_ID);
-
- if Mode = Relative then
- Rel_Time := Time;
- Abs_Time := Time + Check_Time;
- else
- Rel_Time := Time - Check_Time;
- Abs_Time := Time;
- end if;
-
- if Rel_Time > 0.0 then
- Self_ID.Common.State := Delay_Sleep;
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- if Single_Lock then
- Cond_Timed_Wait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Rel_Time, Timedout, Result);
- else
- Cond_Timed_Wait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access,
- Rel_Time, Timedout, Result);
- end if;
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time;
-
- Rel_Time := Abs_Time - Check_Time;
- end loop;
-
- Self_ID.Common.State := Runnable;
- end if;
-
- Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
- Yield;
- end Timed_Delay;
-
- ------------
- -- Wakeup --
- ------------
-
- procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
- pragma Unreferenced (Reason);
- begin
- Cond_Signal (T.Common.LL.CV'Access);
- end Wakeup;
-
- -----------
- -- Yield --
- -----------
-
- procedure Yield (Do_Yield : Boolean := True) is
- begin
- -- Note: in a previous implementation if Do_Yield was False, then we
- -- introduced a delay of 1 millisecond in an attempt to get closer to
- -- annex D semantics, and in particular to make ACATS CXD8002 pass. But
- -- this change introduced a huge performance regression evaluating the
- -- Count attribute. So we decided to remove this processing.
-
- -- Moreover, CXD8002 appears to pass on Windows (although we do not
- -- guarantee full Annex D compliance on Windows in any case).
-
- if Do_Yield then
- SwitchToThread;
- end if;
- end Yield;
-
- ------------------
- -- Set_Priority --
- ------------------
-
- procedure Set_Priority
- (T : Task_Id;
- Prio : System.Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- Res : BOOL;
- pragma Unreferenced (Loss_Of_Inheritance);
-
- begin
- Res :=
- SetThreadPriority
- (T.Common.LL.Thread,
- Interfaces.C.int (Underlying_Priorities (Prio)));
- pragma Assert (Res = Win32.TRUE);
-
- -- Note: Annex D (RM D.2.3(5/2)) requires the task to be placed at the
- -- head of its priority queue when decreasing its priority as a result
- -- of a loss of inherited priority. This is not the case, but we
- -- consider it an acceptable variation (RM 1.1.3(6)), given this is
- -- the built-in behavior offered by the Windows operating system.
-
- -- In older versions we attempted to better approximate the Annex D
- -- required behavior, but this simulation was not entirely accurate,
- -- and it seems better to live with the standard Windows semantics.
-
- T.Common.Current_Priority := Prio;
- 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 --
- ----------------
-
- -- There were two paths were we needed to call Enter_Task :
- -- 1) from System.Task_Primitives.Operations.Initialize
- -- 2) from System.Tasking.Stages.Task_Wrapper
-
- -- The pseudo handle (LL.Thread) need not be closed when it is no
- -- longer needed. Calling the CloseHandle function with this handle
- -- has no effect.
-
- procedure Enter_Task (Self_ID : Task_Id) is
- procedure Get_Stack_Bounds (Base : Address; Limit : Address);
- pragma Import (C, Get_Stack_Bounds, "__gnat_get_stack_bounds");
- -- Get stack boundaries
- begin
- Specific.Set (Self_ID);
-
- -- Properly initializes the FPU for x86 systems
-
- System.Float_Control.Reset;
-
- if Self_ID.Common.Task_Info /= null
- and then
- Self_ID.Common.Task_Info.CPU >= CPU_Number (Number_Of_Processors)
- then
- raise Invalid_CPU_Number;
- end if;
-
- Self_ID.Common.LL.Thread := GetCurrentThread;
- Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
-
- Get_Stack_Bounds
- (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base'Address,
- Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address);
- 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 (GetCurrentThread);
- end if;
- end Register_Foreign_Thread;
-
- --------------------
- -- Initialize_TCB --
- --------------------
-
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- begin
- -- Initialize thread ID to 0, this is needed to detect threads that
- -- are not yet activated.
-
- Self_ID.Common.LL.Thread := Null_Thread_Id;
-
- Initialize_Cond (Self_ID.Common.LL.CV'Access);
-
- if not Single_Lock then
- Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
- end if;
-
- Succeeded := True;
- 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
- Initial_Stack_Size : constant := 1024;
- -- We set the initial stack size to 1024. On Windows version prior to XP
- -- there is no way to fix a task stack size. Only the initial stack size
- -- can be set, the operating system will raise the task stack size if
- -- needed.
-
- function Is_Windows_XP return Integer;
- pragma Import (C, Is_Windows_XP, "__gnat_is_windows_xp");
- -- Returns 1 if running on Windows XP
-
- hTask : HANDLE;
- TaskId : aliased DWORD;
- pTaskParameter : Win32.PVOID;
- Result : DWORD;
- Entry_Point : PTHREAD_START_ROUTINE;
-
- use type System.Multiprocessors.CPU_Range;
-
- begin
- -- Check whether both Dispatching_Domain and CPU are specified for the
- -- task, and the CPU value is not contained within the range of
- -- processors for the domain.
-
- if T.Common.Domain /= null
- and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
- and then
- (T.Common.Base_CPU not in T.Common.Domain'Range
- or else not T.Common.Domain (T.Common.Base_CPU))
- then
- Succeeded := False;
- return;
- end if;
-
- pTaskParameter := To_Address (T);
-
- Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
-
- if Is_Windows_XP = 1 then
- hTask := CreateThread
- (null,
- DWORD (Stack_Size),
- Entry_Point,
- pTaskParameter,
- DWORD (Create_Suspended)
- or DWORD (Stack_Size_Param_Is_A_Reservation),
- TaskId'Unchecked_Access);
- else
- hTask := CreateThread
- (null,
- Initial_Stack_Size,
- Entry_Point,
- pTaskParameter,
- DWORD (Create_Suspended),
- TaskId'Unchecked_Access);
- end if;
-
- -- Step 1: Create the thread in blocked mode
-
- if hTask = 0 then
- Succeeded := False;
- return;
- end if;
-
- -- Step 2: set its TCB
-
- T.Common.LL.Thread := hTask;
-
- -- Note: it would be useful to initialize Thread_Id right away to avoid
- -- a race condition in gdb where Thread_ID may not have the right value
- -- yet, but GetThreadId is a Vista specific API, not available under XP:
- -- T.Common.LL.Thread_Id := GetThreadId (hTask); so instead we set the
- -- field to 0 to avoid having a random value. Thread_Id is initialized
- -- in Enter_Task anyway.
-
- T.Common.LL.Thread_Id := 0;
-
- -- Step 3: set its priority (child has inherited priority from parent)
-
- Set_Priority (T, Priority);
-
- if Time_Slice_Val = 0
- or else Dispatching_Policy = 'F'
- or else Get_Policy (Priority) = 'F'
- then
- -- Here we need Annex D semantics so we disable the NT priority
- -- boost. A priority boost is temporarily given by the system to
- -- a thread when it is taken out of a wait state.
-
- SetThreadPriorityBoost (hTask, DisablePriorityBoost => Win32.TRUE);
- end if;
-
- -- Step 4: Handle pragma CPU and Task_Info
-
- Set_Task_Affinity (T);
-
- -- Step 5: Now, start it for good
-
- Result := ResumeThread (hTask);
- pragma Assert (Result = 1);
-
- Succeeded := Result = 1;
- end Create_Task;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- Succeeded : BOOL;
- pragma Unreferenced (Succeeded);
-
- begin
- if not Single_Lock then
- Finalize_Lock (T.Common.LL.L'Access);
- end if;
-
- Finalize_Cond (T.Common.LL.CV'Access);
-
- if T.Known_Tasks_Index /= -1 then
- Known_Tasks (T.Known_Tasks_Index) := null;
- end if;
-
- if T.Common.LL.Thread /= 0 then
-
- -- This task has been activated. Close the thread handle. This
- -- is needed to release system resources.
-
- Succeeded := CloseHandle (T.Common.LL.Thread);
- -- Note that we do not check for the returned value, this is
- -- because the above call will fail for a foreign thread. But
- -- we still need to call it to properly close Ada tasks created
- -- with CreateThread() in Create_Task above.
- end if;
-
- ATCB_Allocation.Free_ATCB (T);
- end Finalize_TCB;
-
- ---------------
- -- Exit_Task --
- ---------------
-
- procedure Exit_Task is
- begin
- Specific.Set (null);
- end Exit_Task;
-
- ----------------
- -- Abort_Task --
- ----------------
-
- procedure Abort_Task (T : Task_Id) is
- pragma Unreferenced (T);
- begin
- null;
- end Abort_Task;
-
- ----------------------
- -- 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;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- Discard : BOOL;
-
- begin
- Environment_Task_Id := Environment_Task;
- OS_Primitives.Initialize;
- Interrupt_Management.Initialize;
-
- if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
- -- Here we need Annex D semantics, switch the current process to the
- -- Realtime_Priority_Class.
-
- Discard := OS_Interface.SetPriorityClass
- (GetCurrentProcess, Realtime_Priority_Class);
- end if;
-
- TlsIndex := TlsAlloc;
-
- -- Initialize the lock used to synchronize chain of all ATCBs
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- Environment_Task.Common.LL.Thread := GetCurrentThread;
-
- -- 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);
-
- -- pragma CPU and dispatching domains for the environment task
-
- Set_Task_Affinity (Environment_Task);
- end Initialize;
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- function Monotonic_Clock return Duration is
- function Internal_Clock return Duration;
- pragma Import (Ada, Internal_Clock, "__gnat_monotonic_clock");
- begin
- return Internal_Clock;
- end Monotonic_Clock;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- Ticks_Per_Second : aliased LARGE_INTEGER;
- begin
- QueryPerformanceFrequency (Ticks_Per_Second'Access);
- return Duration (1.0 / Ticks_Per_Second);
- end RT_Resolution;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (S : in out Suspension_Object) is
- begin
- -- Initialize internal state. It is always initialized to False (ARM
- -- D.10 par. 6).
-
- S.State := False;
- S.Waiting := False;
-
- -- Initialize internal mutex
-
- InitializeCriticalSection (S.L'Access);
-
- -- Initialize internal condition variable
-
- S.CV := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
- pragma Assert (S.CV /= 0);
- end Initialize;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (S : in out Suspension_Object) is
- Result : BOOL;
-
- begin
- -- Destroy internal mutex
-
- DeleteCriticalSection (S.L'Access);
-
- -- Destroy internal condition variable
-
- Result := CloseHandle (S.CV);
- pragma Assert (Result = Win32.TRUE);
- 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
- begin
- SSL.Abort_Defer.all;
-
- EnterCriticalSection (S.L'Access);
-
- S.State := False;
-
- LeaveCriticalSection (S.L'Access);
-
- SSL.Abort_Undefer.all;
- end Set_False;
-
- --------------
- -- Set_True --
- --------------
-
- procedure Set_True (S : in out Suspension_Object) is
- Result : BOOL;
-
- begin
- SSL.Abort_Defer.all;
-
- EnterCriticalSection (S.L'Access);
-
- -- 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 ARM D.10 par. 9. Otherwise, it just leaves
- -- the state to True.
-
- if S.Waiting then
- S.Waiting := False;
- S.State := False;
-
- Result := SetEvent (S.CV);
- pragma Assert (Result = Win32.TRUE);
-
- else
- S.State := True;
- end if;
-
- LeaveCriticalSection (S.L'Access);
-
- SSL.Abort_Undefer.all;
- end Set_True;
-
- ------------------------
- -- Suspend_Until_True --
- ------------------------
-
- procedure Suspend_Until_True (S : in out Suspension_Object) is
- Result : DWORD;
- Result_Bool : BOOL;
-
- begin
- SSL.Abort_Defer.all;
-
- EnterCriticalSection (S.L'Access);
-
- if S.Waiting then
-
- -- Program_Error must be raised upon calling Suspend_Until_True
- -- if another task is already waiting on that suspension object
- -- (ARM D.10 par. 10).
-
- LeaveCriticalSection (S.L'Access);
-
- 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;
-
- LeaveCriticalSection (S.L'Access);
-
- SSL.Abort_Undefer.all;
-
- else
- S.Waiting := True;
-
- -- Must reset CV BEFORE L is unlocked
-
- Result_Bool := ResetEvent (S.CV);
- pragma Assert (Result_Bool = Win32.TRUE);
-
- LeaveCriticalSection (S.L'Access);
-
- SSL.Abort_Undefer.all;
-
- Result := WaitForSingleObject (S.CV, Wait_Infinite);
- pragma Assert (Result = 0);
- end if;
- end if;
- end Suspend_Until_True;
-
- ----------------
- -- Check_Exit --
- ----------------
-
- -- Dummy versions, currently this only works for solaris (native)
-
- 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;
-
- ------------------
- -- 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 SuspendThread (T.Common.LL.Thread) = NO_ERROR;
- 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 ResumeThread (T.Common.LL.Thread) = NO_ERROR;
- 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;
-
- -----------------------
- -- Set_Task_Affinity --
- -----------------------
-
- procedure Set_Task_Affinity (T : ST.Task_Id) is
- Result : DWORD;
-
- use type System.Multiprocessors.CPU_Range;
-
- begin
- -- Do nothing if the underlying thread has not yet been created. If the
- -- thread has not yet been created then the proper affinity will be set
- -- during its creation.
-
- if T.Common.LL.Thread = Null_Thread_Id then
- null;
-
- -- pragma CPU
-
- elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
-
- -- The CPU numbering in pragma CPU starts at 1 while the subprogram
- -- to set the affinity starts at 0, therefore we must substract 1.
-
- Result :=
- SetThreadIdealProcessor
- (T.Common.LL.Thread, ProcessorId (T.Common.Base_CPU) - 1);
- pragma Assert (Result = 1);
-
- -- Task_Info
-
- elsif T.Common.Task_Info /= null then
- if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then
- Result :=
- SetThreadIdealProcessor
- (T.Common.LL.Thread, T.Common.Task_Info.CPU);
- pragma Assert (Result = 1);
- end if;
-
- -- Dispatching domains
-
- elsif T.Common.Domain /= null
- and then (T.Common.Domain /= ST.System_Domain
- or else
- T.Common.Domain.all /=
- (Multiprocessors.CPU'First ..
- Multiprocessors.Number_Of_CPUs => True))
- then
- declare
- CPU_Set : DWORD := 0;
-
- begin
- for Proc in T.Common.Domain'Range loop
- if T.Common.Domain (Proc) then
-
- -- The thread affinity mask is a bit vector in which each
- -- bit represents a logical processor.
-
- CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1);
- end if;
- end loop;
-
- Result := SetThreadAffinityMask (T.Common.LL.Thread, CPU_Set);
- pragma Assert (Result = 1);
- end;
- end if;
- end Set_Task_Affinity;
-
-end System.Task_Primitives.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . 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 --
--- <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 a POSIX-like 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
-
- Locking_Policy : 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.
-
- Unblocked_Signal_Mask : aliased sigset_t;
- -- The set of signals that should unblocked in all tasks
-
- -- 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 : Integer;
- pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
-
- Dispatching_Policy : 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
-
- ----------------------------------
- -- 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) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread
-
- function Register_Foreign_Thread
- (Thread : Thread_Id) 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
- 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;
-
- -- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . 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 --
--- <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 a Solaris (native) version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-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 Interfaces.C;
-
-with System.Multiprocessors;
-with System.Tasking.Debug;
-with System.Interrupt_Management;
-with System.OS_Constants;
-with System.OS_Primitives;
-with System.Task_Info;
-
-pragma Warnings (Off);
-with System.OS_Lib;
-pragma Warnings (On);
-
-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 following are logically constants, but need to be initialized
- -- at run time.
-
- Environment_Task_Id : Task_Id;
- -- A variable to hold Task_Id for the environment task.
- -- If we use this variable to get the Task_Id, we need the following
- -- ATCB_Key only for non-Ada threads.
-
- Unblocked_Signal_Mask : aliased sigset_t;
- -- The set of signals that should unblocked in all tasks
-
- ATCB_Key : aliased thread_key_t;
- -- Key used to find the Ada Task_Id associated with a thread,
- -- at least for C threads unknown to the Ada run-time system.
-
- 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
-
- Next_Serial_Number : Task_Serial_Number := 100;
- -- We start at 100, to reserve some special values for
- -- using in error checking.
- -- The following are internal configuration constants needed.
-
- Abort_Handler_Installed : Boolean := False;
- -- True if a handler for the abort signal is installed
-
- Null_Thread_Id : constant Thread_Id := Thread_Id'Last;
- -- Constant to indicate that the thread identifier has not yet been
- -- initialized.
-
- ----------------------
- -- Priority Support --
- ----------------------
-
- Priority_Ceiling_Emulation : constant Boolean := True;
- -- controls whether we emulate priority ceiling locking
-
- -- To get a scheduling close to annex D requirements, we use the real-time
- -- class provided for LWPs and map each task/thread to a specific and
- -- unique LWP (there is 1 thread per LWP, and 1 LWP per thread).
-
- -- The real time class can only be set when the process has root
- -- privileges, so in the other cases, we use the normal thread scheduling
- -- and priority handling.
-
- Using_Real_Time_Class : Boolean := False;
- -- indicates whether the real time class is being used (i.e. the process
- -- has root privileges).
-
- Prio_Param : aliased struct_pcparms;
- -- Hold priority info (Real_Time) initialized during the package
- -- elaboration.
-
- -----------------------------------
- -- External Configuration Values --
- -----------------------------------
-
- Time_Slice_Val : Integer;
- pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
-
- Locking_Policy : Character;
- pragma Import (C, Locking_Policy, "__gl_locking_policy");
-
- Dispatching_Policy : 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)
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function sysconf (name : System.OS_Interface.int) return processorid_t;
- pragma Import (C, sysconf, "sysconf");
-
- SC_NPROCESSORS_CONF : constant System.OS_Interface.int := 14;
-
- function Num_Procs
- (name : System.OS_Interface.int := SC_NPROCESSORS_CONF)
- return processorid_t renames sysconf;
-
- procedure Abort_Handler
- (Sig : Signal;
- Code : not null access siginfo_t;
- Context : not null access ucontext_t);
- -- Target-dependent binding of inter-thread Abort signal to
- -- the raising of the Abort_Signal exception.
- -- See also comments in 7staprop.adb
-
- ------------
- -- Checks --
- ------------
-
- function Check_Initialize_Lock
- (L : Lock_Ptr;
- Level : Lock_Level) return Boolean;
- pragma Inline (Check_Initialize_Lock);
-
- function Check_Lock (L : Lock_Ptr) return Boolean;
- pragma Inline (Check_Lock);
-
- function Record_Lock (L : Lock_Ptr) return Boolean;
- pragma Inline (Record_Lock);
-
- function Check_Sleep (Reason : Task_States) return Boolean;
- pragma Inline (Check_Sleep);
-
- function Record_Wakeup
- (L : Lock_Ptr;
- Reason : Task_States) return Boolean;
- pragma Inline (Record_Wakeup);
-
- function Check_Wakeup
- (T : Task_Id;
- Reason : Task_States) return Boolean;
- pragma Inline (Check_Wakeup);
-
- function Check_Unlock (L : Lock_Ptr) return Boolean;
- pragma Inline (Check_Unlock);
-
- function Check_Finalize_Lock (L : Lock_Ptr) return Boolean;
- pragma Inline (Check_Finalize_Lock);
-
- --------------------
- -- 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) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread
-
- function Register_Foreign_Thread
- (Thread : Thread_Id) return Task_Id is separate;
-
- ------------
- -- Checks --
- ------------
-
- Check_Count : Integer := 0;
- Lock_Count : Integer := 0;
- Unlock_Count : Integer := 0;
-
- -------------------
- -- Abort_Handler --
- -------------------
-
- procedure Abort_Handler
- (Sig : Signal;
- Code : not null access siginfo_t;
- Context : not null access ucontext_t)
- is
- pragma Unreferenced (Sig);
- pragma Unreferenced (Code);
- pragma Unreferenced (Context);
-
- Self_ID : 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 Self_ID.Deferral_Level = 0
- and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- and then not Self_ID.Aborting
- then
- Self_ID.Aborting := True;
-
- -- Make sure signals used for RTS internal purpose are unmasked
-
- Result :=
- thr_sigsetmask
- (SIG_UNBLOCK,
- Unblocked_Signal_Mask'Unchecked_Access,
- Old_Set'Unchecked_Access);
- pragma Assert (Result = 0);
-
- raise Standard'Abort_Signal;
- end if;
- end Abort_Handler;
-
- -----------------
- -- Stack_Guard --
- -----------------
-
- -- The underlying thread system sets a guard page at the
- -- bottom of a thread stack, so nothing is needed.
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- pragma Unreferenced (T);
- pragma Unreferenced (On);
- begin
- null;
- 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;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : ST.Task_Id) is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Tmp_Set : aliased sigset_t;
- Result : Interfaces.C.int;
-
- procedure Configure_Processors;
- -- Processors configuration
- -- The user can specify a processor which the program should run
- -- on to emulate a single-processor system. This can be easily
- -- done by setting environment variable GNAT_PROCESSOR to one of
- -- the following :
- --
- -- -2 : use the default configuration (run the program on all
- -- available processors) - this is the same as having
- -- GNAT_PROCESSOR unset
- -- -1 : let the RTS choose one processor and run the program on
- -- that processor
- -- 0 .. Last_Proc : run the program on the specified processor
- --
- -- Last_Proc is equal to the value of the system variable
- -- _SC_NPROCESSORS_CONF, minus one.
-
- procedure Configure_Processors is
- Proc_Acc : constant System.OS_Lib.String_Access :=
- System.OS_Lib.Getenv ("GNAT_PROCESSOR");
- Proc : aliased processorid_t; -- User processor #
- Last_Proc : processorid_t; -- Last processor #
-
- begin
- if Proc_Acc.all'Length /= 0 then
-
- -- Environment variable is defined
-
- Last_Proc := Num_Procs - 1;
-
- if Last_Proc /= -1 then
- Proc := processorid_t'Value (Proc_Acc.all);
-
- if Proc <= -2 or else Proc > Last_Proc then
-
- -- Use the default configuration
-
- null;
-
- elsif Proc = -1 then
-
- -- Choose a processor
-
- Result := 0;
- while Proc < Last_Proc loop
- Proc := Proc + 1;
- Result := p_online (Proc, PR_STATUS);
- exit when Result = PR_ONLINE;
- end loop;
-
- pragma Assert (Result = PR_ONLINE);
- Result := processor_bind (P_PID, P_MYID, Proc, null);
- pragma Assert (Result = 0);
-
- else
- -- Use user processor
-
- Result := processor_bind (P_PID, P_MYID, Proc, null);
- pragma Assert (Result = 0);
- end if;
- end if;
- end if;
-
- exception
- when Constraint_Error =>
-
- -- Illegal environment variable GNAT_PROCESSOR - ignored
-
- null;
- end Configure_Processors;
-
- 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)
-
- -- Start of processing for Initialize
-
- 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;
-
- if Dispatching_Policy = 'F' then
- declare
- Result : Interfaces.C.long;
- Class_Info : aliased struct_pcinfo;
- Secs, Nsecs : Interfaces.C.long;
-
- begin
- -- If a pragma Time_Slice is specified, takes the value in account
-
- if Time_Slice_Val > 0 then
-
- -- Convert Time_Slice_Val (microseconds) to seconds/nanosecs
-
- Secs := Interfaces.C.long (Time_Slice_Val / 1_000_000);
- Nsecs :=
- Interfaces.C.long ((Time_Slice_Val rem 1_000_000) * 1_000);
-
- -- Otherwise, default to no time slicing (i.e run until blocked)
-
- else
- Secs := RT_TQINF;
- Nsecs := RT_TQINF;
- end if;
-
- -- Get the real time class id
-
- Class_Info.pc_clname (1) := 'R';
- Class_Info.pc_clname (2) := 'T';
- Class_Info.pc_clname (3) := ASCII.NUL;
-
- Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID,
- Class_Info'Address);
-
- -- Request the real time class
-
- Prio_Param.pc_cid := Class_Info.pc_cid;
- Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri);
- Prio_Param.rt_tqsecs := Secs;
- Prio_Param.rt_tqnsecs := Nsecs;
-
- Result :=
- priocntl
- (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS, Prio_Param'Address);
-
- Using_Real_Time_Class := Result /= -1;
- end;
- end if;
-
- Specific.Initialize (Environment_Task);
-
- -- The following is done in Enter_Task, but this is too late for the
- -- Environment Task, since we need to call Self in Check_Locks when
- -- the run time is compiled with assertions on.
-
- Specific.Set (Environment_Task);
-
- -- Initialize the lock used to synchronize chain of all ATCBs
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- -- 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);
-
- Configure_Processors;
-
- if State
- (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
- then
- -- Set sa_flags to SA_NODEFER so that during the handler execution
- -- we do not change the Signal_Mask to be masked for the Abort_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.
- -- In that case, this field should be changed back to 0. ???
-
- act.sa_flags := 16;
-
- 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;
-
- ---------------------
- -- 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
- Result : Interfaces.C.int;
-
- begin
- pragma Assert (Check_Initialize_Lock (Lock_Ptr (L), PO_Level));
-
- if Priority_Ceiling_Emulation then
- L.Ceiling := Prio;
- end if;
-
- Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error with "Failed to allocate a lock";
- end if;
- end Initialize_Lock;
-
- procedure Initialize_Lock
- (L : not null access RTS_Lock;
- Level : Lock_Level)
- is
- Result : Interfaces.C.int;
-
- begin
- pragma Assert
- (Check_Initialize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level));
- Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error with "Failed to allocate a lock";
- end if;
- end Initialize_Lock;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : not null access Lock) is
- Result : Interfaces.C.int;
- begin
- pragma Assert (Check_Finalize_Lock (Lock_Ptr (L)));
- Result := mutex_destroy (L.L'Access);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : not null access RTS_Lock) is
- Result : Interfaces.C.int;
- begin
- pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
- Result := mutex_destroy (L.L'Access);
- 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
- pragma Assert (Check_Lock (Lock_Ptr (L)));
-
- if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
- declare
- Self_Id : constant Task_Id := Self;
- Saved_Priority : System.Any_Priority;
-
- begin
- if Self_Id.Common.LL.Active_Priority > L.Ceiling then
- Ceiling_Violation := True;
- return;
- end if;
-
- Saved_Priority := Self_Id.Common.LL.Active_Priority;
-
- if Self_Id.Common.LL.Active_Priority < L.Ceiling then
- Set_Priority (Self_Id, L.Ceiling);
- end if;
-
- Result := mutex_lock (L.L'Access);
- pragma Assert (Result = 0);
- Ceiling_Violation := False;
-
- L.Saved_Priority := Saved_Priority;
- end;
-
- else
- Result := mutex_lock (L.L'Access);
- pragma Assert (Result = 0);
- Ceiling_Violation := False;
- end if;
-
- pragma Assert (Record_Lock (Lock_Ptr (L)));
- 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
- pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
- Result := mutex_lock (L.L'Access);
- pragma Assert (Result = 0);
- pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
- end if;
- end Write_Lock;
-
- procedure Write_Lock (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock then
- pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
- Result := mutex_lock (T.Common.LL.L.L'Access);
- pragma Assert (Result = 0);
- pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
- 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
- pragma Assert (Check_Unlock (Lock_Ptr (L)));
-
- if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
- declare
- Self_Id : constant Task_Id := Self;
-
- begin
- Result := mutex_unlock (L.L'Access);
- pragma Assert (Result = 0);
-
- if Self_Id.Common.LL.Active_Priority > L.Saved_Priority then
- Set_Priority (Self_Id, L.Saved_Priority);
- end if;
- end;
- else
- Result := mutex_unlock (L.L'Access);
- pragma Assert (Result = 0);
- end if;
- 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
- pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
- Result := mutex_unlock (L.L'Access);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- procedure Unlock (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock then
- pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access)));
- Result := mutex_unlock (T.Common.LL.L.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;
-
- -- For the time delay implementation, we need to make sure we
- -- achieve following criteria:
-
- -- 1) We have to delay at least for the amount requested.
- -- 2) We have to give up CPU even though the actual delay does not
- -- result in blocking.
- -- 3) Except for restricted run-time systems that do not support
- -- ATC or task abort, the delay must be interrupted by the
- -- abort_task operation.
- -- 4) The implementation has to be efficient so that the delay overhead
- -- is relatively cheap.
- -- (1)-(3) are Ada requirements. Even though (2) is an Annex-D
- -- requirement we still want to provide the effect in all cases.
- -- The reason is that users may want to use short delays to implement
- -- their own scheduling effect in the absence of language provided
- -- scheduling policies.
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- function Monotonic_Clock return Duration is
- TS : aliased timespec;
- Result : Interfaces.C.int;
- begin
- Result := clock_gettime (OSC.CLOCK_RT_Ada, 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;
-
- -----------
- -- Yield --
- -----------
-
- procedure Yield (Do_Yield : Boolean := True) is
- begin
- if Do_Yield then
- System.OS_Interface.thr_yield;
- end if;
- end Yield;
-
- -----------
- -- Self ---
- -----------
-
- function Self return Task_Id renames Specific.Self;
-
- ------------------
- -- 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;
- pragma Unreferenced (Result);
-
- Param : aliased struct_pcparms;
-
- use Task_Info;
-
- begin
- T.Common.Current_Priority := Prio;
-
- if Priority_Ceiling_Emulation then
- T.Common.LL.Active_Priority := Prio;
- end if;
-
- if Using_Real_Time_Class then
- Param.pc_cid := Prio_Param.pc_cid;
- Param.rt_pri := pri_t (Prio);
- Param.rt_tqsecs := Prio_Param.rt_tqsecs;
- Param.rt_tqnsecs := Prio_Param.rt_tqnsecs;
-
- Result := Interfaces.C.int (
- priocntl (PC_VERSION, P_LWPID, T.Common.LL.LWP, PC_SETPARMS,
- Param'Address));
-
- else
- if T.Common.Task_Info /= null
- and then not T.Common.Task_Info.Bound_To_LWP
- then
- -- The task is not bound to a LWP, so use thr_setprio
-
- Result :=
- thr_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
-
- else
- -- The task is bound to a LWP, use priocntl
- -- ??? TBD
-
- null;
- end if;
- end if;
- 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 := thr_self;
- Self_ID.Common.LL.LWP := lwp_self;
-
- Set_Task_Affinity (Self_ID);
- Specific.Set (Self_ID);
-
- -- We need the above code even if we do direct fetch of Task_Id in Self
- -- for the main task on Sun, x86 Solaris and for gcc 2.7.2.
- 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 (thr_self);
- end if;
- end Register_Foreign_Thread;
-
- --------------------
- -- Initialize_TCB --
- --------------------
-
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- Result : Interfaces.C.int := 0;
-
- 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);
-
- Self_ID.Common.LL.Thread := Null_Thread_Id;
-
- if not Single_Lock then
- Result :=
- mutex_init
- (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address);
- Self_ID.Common.LL.L.Level :=
- Private_Task_Serial_Number (Self_ID.Serial_Number);
- pragma Assert (Result = 0 or else Result = ENOMEM);
- end if;
-
- if Result = 0 then
- Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0);
- pragma Assert (Result = 0 or else Result = ENOMEM);
- end if;
-
- if Result = 0 then
- Succeeded := True;
- else
- if not Single_Lock then
- Result := mutex_destroy (Self_ID.Common.LL.L.L'Access);
- pragma Assert (Result = 0);
- end if;
-
- Succeeded := False;
- end if;
- 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
- pragma Unreferenced (Priority);
-
- Result : Interfaces.C.int;
- Adjusted_Stack_Size : Interfaces.C.size_t;
- Opts : Interfaces.C.int := THR_DETACHED;
-
- Page_Size : constant System.Parameters.Size_Type := 4096;
- -- This constant is for reserving extra space at the
- -- end of the stack, which can be used by the stack
- -- checking as guard page. The idea is that we need
- -- to have at least Stack_Size bytes available for
- -- actual use.
-
- use System.Task_Info;
- use type System.Multiprocessors.CPU_Range;
-
- begin
- -- Check whether both Dispatching_Domain and CPU are specified for the
- -- task, and the CPU value is not contained within the range of
- -- processors for the domain.
-
- if T.Common.Domain /= null
- and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
- and then
- (T.Common.Base_CPU not in T.Common.Domain'Range
- or else not T.Common.Domain (T.Common.Base_CPU))
- then
- Succeeded := False;
- return;
- end if;
-
- Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Page_Size);
-
- -- 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.
-
- if T.Common.Task_Info /= null then
- if T.Common.Task_Info.New_LWP then
- Opts := Opts + THR_NEW_LWP;
- end if;
-
- if T.Common.Task_Info.Bound_To_LWP then
- Opts := Opts + THR_BOUND;
- end if;
-
- else
- Opts := THR_DETACHED + THR_BOUND;
- end if;
-
- -- 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 :=
- thr_create
- (System.Null_Address,
- Adjusted_Stack_Size,
- Thread_Body_Access (Wrapper),
- To_Address (T),
- Opts,
- T.Common.LL.Thread'Unrestricted_Access);
-
- Succeeded := Result = 0;
- pragma Assert
- (Result = 0
- or else Result = ENOMEM
- or else Result = EAGAIN);
- end Create_Task;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- Result : Interfaces.C.int;
-
- begin
- T.Common.LL.Thread := Null_Thread_Id;
-
- if not Single_Lock then
- Result := mutex_destroy (T.Common.LL.L.L'Access);
- pragma Assert (Result = 0);
- end if;
-
- Result := 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 --
- ---------------
-
- -- This procedure must be called with abort deferred. It can no longer
- -- call Self or access the current task's ATCB, since the ATCB has been
- -- deallocated.
-
- procedure Exit_Task is
- begin
- 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
- pragma Assert (T /= Self);
- Result :=
- thr_kill
- (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
- pragma Assert (Result = 0);
- end if;
- end Abort_Task;
-
- -----------
- -- Sleep --
- -----------
-
- procedure Sleep
- (Self_ID : Task_Id;
- Reason : Task_States)
- is
- Result : Interfaces.C.int;
-
- begin
- pragma Assert (Check_Sleep (Reason));
-
- if Single_Lock then
- Result :=
- cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access);
- else
- Result :=
- cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
- end if;
-
- pragma Assert
- (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
- pragma Assert (Result = 0 or else Result = EINTR);
- end Sleep;
-
- -- Note that we are relying heavily here on GNAT representing
- -- Calendar.Time, System.Real_Time.Time, Duration,
- -- System.Real_Time.Time_Span in the same way, i.e., as a 64-bit count of
- -- nanoseconds.
-
- -- This allows us to always pass the timeout value as a Duration
-
- -- ???
- -- We are taking liberties here with the semantics of the delays. That is,
- -- we make no distinction between delays on the Calendar clock and delays
- -- on the Real_Time clock. That is technically incorrect, if the Calendar
- -- clock happens to be reset or adjusted. To solve this defect will require
- -- modification to the compiler interface, so that it can pass through more
- -- information, to tell us here which clock to use.
-
- -- cond_timedwait will return if any of the following happens:
- -- 1) some other task did cond_signal on this condition variable
- -- In this case, the return value is 0
- -- 2) the call just returned, for no good reason
- -- This is called a "spurious wakeup".
- -- In this case, the return value may also be 0.
- -- 3) the time delay expires
- -- In this case, the return value is ETIME
- -- 4) this task received a signal, which was handled by some
- -- handler procedure, and now the thread is resuming execution
- -- UNIX calls this an "interrupted" system call.
- -- In this case, the return value is EINTR
-
- -- If the cond_timedwait returns 0 or EINTR, it is still possible that the
- -- time has actually expired, and by chance a signal or cond_signal
- -- occurred at around the same time.
-
- -- We have also observed that on some OS's the value ETIME will be
- -- returned, but the clock will show that the full delay has not yet
- -- expired.
-
- -- For these reasons, we need to check the clock after return from
- -- cond_timedwait. If the time has expired, we will set Timedout = True.
-
- -- This check might be omitted for systems on which the cond_timedwait()
- -- never returns early or wakes up spuriously.
-
- -- Annex D requires that completion of a delay cause the task to go to the
- -- end of its priority queue, regardless of whether the task actually was
- -- suspended by the delay. Since cond_timedwait does not do this on
- -- Solaris, we add a call to thr_yield at the end. We might do this at the
- -- beginning, instead, but then the round-robin effect would not be the
- -- same; the delayed task would be ahead of other tasks of the same
- -- priority that awoke while it was sleeping.
-
- -- For Timed_Sleep, we are expecting possible cond_signals to indicate
- -- other events (e.g., completion of a RV or completion of the abortable
- -- part of an async. select), we want to always return if interrupted. The
- -- caller will be responsible for checking the task state to see whether
- -- the wakeup was spurious, and to go back to sleep again in that case. We
- -- don't need to check for pending abort or priority change on the way in
- -- our out; that is the caller's responsibility.
-
- -- For Timed_Delay, we are not expecting any cond_signals or other
- -- interruptions, except for priority changes and aborts. Therefore, we
- -- don't want to return unless the delay has actually expired, or the call
- -- has been aborted. In this case, since we want to implement the entire
- -- delay statement semantics, we do need to check for pending abort and
- -- priority changes. We can quietly handle priority changes inside the
- -- procedure, since there is no entry-queue reordering involved.
-
- -----------------
- -- Timed_Sleep --
- -----------------
-
- procedure Timed_Sleep
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes;
- Reason : System.Tasking.Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- Base_Time : constant Duration := Monotonic_Clock;
- Check_Time : Duration := Base_Time;
- Abs_Time : Duration;
- Request : aliased timespec;
- Result : Interfaces.C.int;
-
- begin
- pragma Assert (Check_Sleep (Reason));
- Timedout := True;
- Yielded := False;
-
- Abs_Time :=
- (if Mode = Relative
- then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (Abs_Time);
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- if Single_Lock then
- Result :=
- cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock.L'Access, Request'Access);
- else
- Result :=
- cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L.L'Access, Request'Access);
- end if;
-
- Yielded := True;
-
- 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 = ETIME);
- end loop;
- end if;
-
- pragma Assert
- (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
- end Timed_Sleep;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Base_Time : constant Duration := Monotonic_Clock;
- Check_Time : Duration := Base_Time;
- Abs_Time : Duration;
- Request : aliased timespec;
- Result : Interfaces.C.int;
- Yielded : Boolean := False;
-
- begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
- Write_Lock (Self_ID);
-
- Abs_Time :=
- (if Mode = Relative
- then Time + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (Abs_Time);
- Self_ID.Common.State := Delay_Sleep;
-
- pragma Assert (Check_Sleep (Delay_Sleep));
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- if Single_Lock then
- Result :=
- cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock.L'Access,
- Request'Access);
- else
- Result :=
- cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L.L'Access,
- Request'Access);
- end if;
-
- Yielded := True;
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- pragma Assert
- (Result = 0 or else
- Result = ETIME or else
- Result = EINTR);
- end loop;
-
- pragma Assert
- (Record_Wakeup
- (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep));
-
- Self_ID.Common.State := Runnable;
- end if;
-
- Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
- if not Yielded then
- thr_yield;
- end if;
- end Timed_Delay;
-
- ------------
- -- Wakeup --
- ------------
-
- procedure Wakeup
- (T : Task_Id;
- Reason : Task_States)
- is
- Result : Interfaces.C.int;
- begin
- pragma Assert (Check_Wakeup (T, Reason));
- Result := cond_signal (T.Common.LL.CV'Access);
- pragma Assert (Result = 0);
- end Wakeup;
-
- ---------------------------
- -- Check_Initialize_Lock --
- ---------------------------
-
- -- The following code is intended to check some of the invariant assertions
- -- related to lock usage, on which we depend.
-
- function Check_Initialize_Lock
- (L : Lock_Ptr;
- Level : Lock_Level) return Boolean
- is
- Self_ID : constant Task_Id := Self;
-
- begin
- -- Check that caller is abort-deferred
-
- if Self_ID.Deferral_Level = 0 then
- return False;
- end if;
-
- -- Check that the lock is not yet initialized
-
- if L.Level /= 0 then
- return False;
- end if;
-
- L.Level := Lock_Level'Pos (Level) + 1;
- return True;
- end Check_Initialize_Lock;
-
- ----------------
- -- Check_Lock --
- ----------------
-
- function Check_Lock (L : Lock_Ptr) return Boolean is
- Self_ID : constant Task_Id := Self;
- P : Lock_Ptr;
-
- begin
- -- Check that the argument is not null
-
- if L = null then
- return False;
- end if;
-
- -- Check that L is not frozen
-
- if L.Frozen then
- return False;
- end if;
-
- -- Check that caller is abort-deferred
-
- if Self_ID.Deferral_Level = 0 then
- return False;
- end if;
-
- -- Check that caller is not holding this lock already
-
- if L.Owner = To_Owner_ID (To_Address (Self_ID)) then
- return False;
- end if;
-
- if Single_Lock then
- return True;
- end if;
-
- -- Check that TCB lock order rules are satisfied
-
- P := Self_ID.Common.LL.Locks;
- if P /= null then
- if P.Level >= L.Level
- and then (P.Level > 2 or else L.Level > 2)
- then
- return False;
- end if;
- end if;
-
- return True;
- end Check_Lock;
-
- -----------------
- -- Record_Lock --
- -----------------
-
- function Record_Lock (L : Lock_Ptr) return Boolean is
- Self_ID : constant Task_Id := Self;
- P : Lock_Ptr;
-
- begin
- Lock_Count := Lock_Count + 1;
-
- -- There should be no owner for this lock at this point
-
- if L.Owner /= null then
- return False;
- end if;
-
- -- Record new owner
-
- L.Owner := To_Owner_ID (To_Address (Self_ID));
-
- if Single_Lock then
- return True;
- end if;
-
- -- Check that TCB lock order rules are satisfied
-
- P := Self_ID.Common.LL.Locks;
-
- if P /= null then
- L.Next := P;
- end if;
-
- Self_ID.Common.LL.Locking := null;
- Self_ID.Common.LL.Locks := L;
- return True;
- end Record_Lock;
-
- -----------------
- -- Check_Sleep --
- -----------------
-
- function Check_Sleep (Reason : Task_States) return Boolean is
- pragma Unreferenced (Reason);
-
- Self_ID : constant Task_Id := Self;
- P : Lock_Ptr;
-
- begin
- -- Check that caller is abort-deferred
-
- if Self_ID.Deferral_Level = 0 then
- return False;
- end if;
-
- if Single_Lock then
- return True;
- end if;
-
- -- Check that caller is holding own lock, on top of list
-
- if Self_ID.Common.LL.Locks /=
- To_Lock_Ptr (Self_ID.Common.LL.L'Access)
- then
- return False;
- end if;
-
- -- Check that TCB lock order rules are satisfied
-
- if Self_ID.Common.LL.Locks.Next /= null then
- return False;
- end if;
-
- Self_ID.Common.LL.L.Owner := null;
- P := Self_ID.Common.LL.Locks;
- Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
- P.Next := null;
- return True;
- end Check_Sleep;
-
- -------------------
- -- Record_Wakeup --
- -------------------
-
- function Record_Wakeup
- (L : Lock_Ptr;
- Reason : Task_States) return Boolean
- is
- pragma Unreferenced (Reason);
-
- Self_ID : constant Task_Id := Self;
- P : Lock_Ptr;
-
- begin
- -- Record new owner
-
- L.Owner := To_Owner_ID (To_Address (Self_ID));
-
- if Single_Lock then
- return True;
- end if;
-
- -- Check that TCB lock order rules are satisfied
-
- P := Self_ID.Common.LL.Locks;
-
- if P /= null then
- L.Next := P;
- end if;
-
- Self_ID.Common.LL.Locking := null;
- Self_ID.Common.LL.Locks := L;
- return True;
- end Record_Wakeup;
-
- ------------------
- -- Check_Wakeup --
- ------------------
-
- function Check_Wakeup
- (T : Task_Id;
- Reason : Task_States) return Boolean
- is
- Self_ID : constant Task_Id := Self;
-
- begin
- -- Is caller holding T's lock?
-
- if T.Common.LL.L.Owner /= To_Owner_ID (To_Address (Self_ID)) then
- return False;
- end if;
-
- -- Are reasons for wakeup and sleep consistent?
-
- if T.Common.State /= Reason then
- return False;
- end if;
-
- return True;
- end Check_Wakeup;
-
- ------------------
- -- Check_Unlock --
- ------------------
-
- function Check_Unlock (L : Lock_Ptr) return Boolean is
- Self_ID : constant Task_Id := Self;
- P : Lock_Ptr;
-
- begin
- Unlock_Count := Unlock_Count + 1;
-
- if L = null then
- return False;
- end if;
-
- if L.Buddy /= null then
- return False;
- end if;
-
- -- Magic constant 4???
-
- if L.Level = 4 then
- Check_Count := Unlock_Count;
- end if;
-
- -- Magic constant 1000???
-
- if Unlock_Count - Check_Count > 1000 then
- Check_Count := Unlock_Count;
- end if;
-
- -- Check that caller is abort-deferred
-
- if Self_ID.Deferral_Level = 0 then
- return False;
- end if;
-
- -- Check that caller is holding this lock, on top of list
-
- if Self_ID.Common.LL.Locks /= L then
- return False;
- end if;
-
- -- Record there is no owner now
-
- L.Owner := null;
- P := Self_ID.Common.LL.Locks;
- Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
- P.Next := null;
- return True;
- end Check_Unlock;
-
- --------------------
- -- Check_Finalize --
- --------------------
-
- function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is
- Self_ID : constant Task_Id := Self;
-
- begin
- -- Check that caller is abort-deferred
-
- if Self_ID.Deferral_Level = 0 then
- return False;
- end if;
-
- -- Check that no one is holding this lock
-
- if L.Owner /= null then
- return False;
- end if;
-
- L.Frozen := True;
- return True;
- end Check_Finalize_Lock;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- -- Initialize internal state (always to zero (RM D.10(6)))
-
- S.State := False;
- S.Waiting := False;
-
- -- Initialize internal mutex
-
- Result := mutex_init (S.L'Access, USYNC_THREAD, System.Null_Address);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error with "Failed to allocate a lock";
- end if;
-
- -- Initialize internal condition variable
-
- Result := cond_init (S.CV'Access, USYNC_THREAD, 0);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result /= 0 then
- Result := mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
- end if;
- end Initialize;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- -- Destroy internal mutex
-
- Result := mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- -- Destroy internal condition variable
-
- Result := 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 := mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- S.State := False;
-
- Result := 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 := 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 ARM D.10 par. 9. Otherwise, it just leaves
- -- the state to True.
-
- if S.Waiting then
- S.Waiting := False;
- S.State := False;
-
- Result := cond_signal (S.CV'Access);
- pragma Assert (Result = 0);
-
- else
- S.State := True;
- end if;
-
- Result := 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 := 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 := 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 := 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 := mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end if;
- end Suspend_Until_True;
-
- ----------------
- -- Check_Exit --
- ----------------
-
- function Check_Exit (Self_ID : Task_Id) return Boolean is
- begin
- -- Check that caller is just holding Global_Task_Lock and no other locks
-
- if Self_ID.Common.LL.Locks = null then
- return False;
- end if;
-
- -- 2 = Global_Task_Level
-
- if Self_ID.Common.LL.Locks.Level /= 2 then
- return False;
- end if;
-
- if Self_ID.Common.LL.Locks.Next /= null then
- return False;
- end if;
-
- -- Check that caller is abort-deferred
-
- if Self_ID.Deferral_Level = 0 then
- return False;
- end if;
-
- return True;
- end Check_Exit;
-
- --------------------
- -- Check_No_Locks --
- --------------------
-
- function Check_No_Locks (Self_ID : Task_Id) return Boolean is
- begin
- return Self_ID.Common.LL.Locks = null;
- 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 thr_suspend (T.Common.LL.Thread) = 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 thr_continue (T.Common.LL.Thread) = 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;
-
- -----------------------
- -- Set_Task_Affinity --
- -----------------------
-
- procedure Set_Task_Affinity (T : ST.Task_Id) is
- Result : Interfaces.C.int;
- Proc : processorid_t; -- User processor #
- Last_Proc : processorid_t; -- Last processor #
-
- use System.Task_Info;
- use type System.Multiprocessors.CPU_Range;
-
- begin
- -- Do nothing if the underlying thread has not yet been created. If the
- -- thread has not yet been created then the proper affinity will be set
- -- during its creation.
-
- if T.Common.LL.Thread = Null_Thread_Id then
- null;
-
- -- pragma CPU
-
- elsif T.Common.Base_CPU /=
- System.Multiprocessors.Not_A_Specific_CPU
- then
- -- The CPU numbering in pragma CPU starts at 1 while the subprogram
- -- to set the affinity starts at 0, therefore we must substract 1.
-
- Result :=
- processor_bind
- (P_LWPID, id_t (T.Common.LL.LWP),
- processorid_t (T.Common.Base_CPU) - 1, null);
- pragma Assert (Result = 0);
-
- -- Task_Info
-
- elsif T.Common.Task_Info /= null then
- if T.Common.Task_Info.New_LWP
- and then T.Common.Task_Info.CPU /= CPU_UNCHANGED
- then
- Last_Proc := Num_Procs - 1;
-
- if T.Common.Task_Info.CPU = ANY_CPU then
- Result := 0;
-
- Proc := 0;
- while Proc < Last_Proc loop
- Result := p_online (Proc, PR_STATUS);
- exit when Result = PR_ONLINE;
- Proc := Proc + 1;
- end loop;
-
- Result :=
- processor_bind
- (P_LWPID, id_t (T.Common.LL.LWP), Proc, null);
- pragma Assert (Result = 0);
-
- else
- -- Use specified processor
-
- if T.Common.Task_Info.CPU < 0
- or else T.Common.Task_Info.CPU > Last_Proc
- then
- raise Invalid_CPU_Number;
- end if;
-
- Result :=
- processor_bind
- (P_LWPID, id_t (T.Common.LL.LWP),
- T.Common.Task_Info.CPU, null);
- pragma Assert (Result = 0);
- end if;
- end if;
-
- -- Handle dispatching domains
-
- elsif T.Common.Domain /= null
- and then (T.Common.Domain /= ST.System_Domain
- or else T.Common.Domain.all /=
- (Multiprocessors.CPU'First ..
- Multiprocessors.Number_Of_CPUs => True))
- then
- declare
- CPU_Set : aliased psetid_t;
- Result : int;
-
- begin
- Result := pset_create (CPU_Set'Access);
- pragma Assert (Result = 0);
-
- -- Set the affinity to all the processors belonging to the
- -- dispatching domain.
-
- for Proc in T.Common.Domain'Range loop
-
- -- The Ada CPU numbering starts at 1 while the subprogram to
- -- set the affinity starts at 0, therefore we must substract 1.
-
- if T.Common.Domain (Proc) then
- Result :=
- pset_assign (CPU_Set, processorid_t (Proc) - 1, null);
- pragma Assert (Result = 0);
- end if;
- end loop;
-
- Result :=
- pset_bind (CPU_Set, P_LWPID, id_t (T.Common.LL.LWP), null);
- pragma Assert (Result = 0);
- end;
- end if;
- end Set_Task_Affinity;
-
-end System.Task_Primitives.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . 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 --
--- <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 VxWorks version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-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.Multiprocessors;
-with System.Tasking.Debug;
-with System.Interrupt_Management;
-with System.Float_Control;
-with System.OS_Constants;
-
-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.
-
-with System.Task_Info;
-with System.VxWorks.Ext;
-
-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 System.OS_Interface;
- use System.Parameters;
- use type System.VxWorks.Ext.t_id;
- use type Interfaces.C.int;
- use type System.OS_Interface.unsigned;
-
- subtype int is System.OS_Interface.int;
- subtype unsigned is System.OS_Interface.unsigned;
-
- Relative : constant := 0;
-
- ----------------
- -- Local Data --
- ----------------
-
- -- The followings are logically constants, but need to be initialized at
- -- run time.
-
- Environment_Task_Id : Task_Id;
- -- A variable to hold Task_Id for the environment task
-
- -- The followings are internal configuration constants needed
-
- Dispatching_Policy : 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)
-
- Locking_Policy : Character;
- pragma Import (C, Locking_Policy, "__gl_locking_policy");
-
- Mutex_Protocol : Priority_Type;
-
- 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
-
- Time_Slice_Val : Integer;
- pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
-
- Null_Thread_Id : constant Thread_Id := 0;
- -- Constant to indicate that the thread identifier has not yet been
- -- initialized.
-
- --------------------
- -- Local Packages --
- --------------------
-
- package Specific is
-
- procedure Initialize;
- pragma Inline (Initialize);
- -- Initialize task specific data
-
- 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, unless Self_Id is null, in
- -- which case the task specific data is deleted.
-
- 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) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread
-
- function Register_Foreign_Thread
- (Thread : Thread_Id) return Task_Id is separate;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Abort_Handler (signo : Signal);
- -- Handler for the abort (SIGABRT) signal to handle asynchronous abort
-
- procedure Install_Signal_Handlers;
- -- Install the default signal handlers for the current task
-
- function Is_Task_Context return Boolean;
- -- This function returns True if the current execution is in the context of
- -- a task, and False if it is an interrupt context.
-
- type Set_Stack_Limit_Proc_Acc is access procedure;
- pragma Convention (C, Set_Stack_Limit_Proc_Acc);
-
- Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
- pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
- -- Procedure to be called when a task is created to set stack limit. Used
- -- only for VxWorks 5 and VxWorks MILS guest OS.
-
- function To_Address is
- new Ada.Unchecked_Conversion (Task_Id, System.Address);
-
- -------------------
- -- Abort_Handler --
- -------------------
-
- procedure Abort_Handler (signo : Signal) is
- pragma Unreferenced (signo);
-
- Self_ID : constant Task_Id := Self;
- Old_Set : aliased sigset_t;
- Unblocked_Mask : aliased sigset_t;
- Result : int;
- pragma Warnings (Off, Result);
-
- use System.Interrupt_Management;
-
- begin
- -- It is not safe to raise an exception when using ZCX and the GCC
- -- exception handling mechanism.
-
- if ZCX_By_Default then
- return;
- end if;
-
- if Self_ID.Deferral_Level = 0
- and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- and then not Self_ID.Aborting
- then
- Self_ID.Aborting := True;
-
- -- Make sure signals used for RTS internal purposes are unmasked
-
- Result := sigemptyset (Unblocked_Mask'Access);
- pragma Assert (Result = 0);
- Result :=
- sigaddset
- (Unblocked_Mask'Access,
- Signal (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
- pragma Unreferenced (T);
- pragma Unreferenced (On);
-
- begin
- -- Nothing needed (why not???)
-
- null;
- 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;
-
- -----------------------------
- -- Install_Signal_Handlers --
- -----------------------------
-
- procedure Install_Signal_Handlers is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Tmp_Set : aliased sigset_t;
- Result : int;
-
- begin
- 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 (Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
-
- Interrupt_Management.Initialize_Interrupts;
- end Install_Signal_Handlers;
-
- ---------------------
- -- Initialize_Lock --
- ---------------------
-
- procedure Initialize_Lock
- (Prio : System.Any_Priority;
- L : not null access Lock)
- is
- begin
- L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
- L.Prio_Ceiling := int (Prio);
- L.Protocol := Mutex_Protocol;
- pragma Assert (L.Mutex /= 0);
- end Initialize_Lock;
-
- procedure Initialize_Lock
- (L : not null access RTS_Lock;
- Level : Lock_Level)
- is
- pragma Unreferenced (Level);
- begin
- L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
- L.Prio_Ceiling := int (System.Any_Priority'Last);
- L.Protocol := Mutex_Protocol;
- pragma Assert (L.Mutex /= 0);
- end Initialize_Lock;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : not null access Lock) is
- Result : int;
- begin
- Result := semDelete (L.Mutex);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : not null access RTS_Lock) is
- Result : int;
- begin
- Result := semDelete (L.Mutex);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- ----------------
- -- Write_Lock --
- ----------------
-
- procedure Write_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- Result : int;
-
- begin
- if L.Protocol = Prio_Protect
- and then int (Self.Common.Current_Priority) > L.Prio_Ceiling
- then
- Ceiling_Violation := True;
- return;
- else
- Ceiling_Violation := False;
- end if;
-
- Result := semTake (L.Mutex, WAIT_FOREVER);
- pragma Assert (Result = 0);
- end Write_Lock;
-
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : int;
- begin
- if not Single_Lock or else Global_Lock then
- Result := semTake (L.Mutex, WAIT_FOREVER);
- pragma Assert (Result = 0);
- end if;
- end Write_Lock;
-
- procedure Write_Lock (T : Task_Id) is
- Result : int;
- begin
- if not Single_Lock then
- Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
- 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 : int;
- begin
- Result := semGive (L.Mutex);
- pragma Assert (Result = 0);
- end Unlock;
-
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : int;
- begin
- if not Single_Lock or else Global_Lock then
- Result := semGive (L.Mutex);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- procedure Unlock (T : Task_Id) is
- Result : int;
- begin
- if not Single_Lock then
- Result := semGive (T.Common.LL.L.Mutex);
- 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 : int;
-
- begin
- pragma Assert (Self_ID = Self);
-
- -- Release the mutex before sleeping
-
- Result :=
- semGive (if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex);
- pragma Assert (Result = 0);
-
- -- Perform a blocking operation to take the CV semaphore. Note that a
- -- blocking operation in VxWorks will reenable task scheduling. When we
- -- are no longer blocked and control is returned, task scheduling will
- -- again be disabled.
-
- Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER);
- pragma Assert (Result = 0);
-
- -- Take the mutex back
-
- Result :=
- semTake ((if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
- pragma Assert (Result = 0);
- 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 : System.Tasking.Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- pragma Unreferenced (Reason);
-
- Orig : constant Duration := Monotonic_Clock;
- Absolute : Duration;
- Ticks : int;
- Result : int;
- Wakeup : Boolean := False;
-
- begin
- Timedout := False;
- Yielded := True;
-
- if Mode = Relative then
- Absolute := Orig + Time;
-
- -- Systematically add one since the first tick will delay *at most*
- -- 1 / Rate_Duration seconds, so we need to add one to be on the
- -- safe side.
-
- Ticks := To_Clock_Ticks (Time);
-
- if Ticks > 0 and then Ticks < int'Last then
- Ticks := Ticks + 1;
- end if;
-
- else
- Absolute := Time;
- Ticks := To_Clock_Ticks (Time - Monotonic_Clock);
- end if;
-
- if Ticks > 0 then
- loop
- -- Release the mutex before sleeping
-
- Result :=
- semGive (if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex);
- pragma Assert (Result = 0);
-
- -- Perform a blocking operation to take the CV semaphore. Note
- -- that a blocking operation in VxWorks will reenable task
- -- scheduling. When we are no longer blocked and control is
- -- returned, task scheduling will again be disabled.
-
- Result := semTake (Self_ID.Common.LL.CV, Ticks);
-
- if Result = 0 then
-
- -- Somebody may have called Wakeup for us
-
- Wakeup := True;
-
- else
- if errno /= S_objLib_OBJ_TIMEOUT then
- Wakeup := True;
-
- else
- -- If Ticks = int'last, it was most probably truncated so
- -- let's make another round after recomputing Ticks from
- -- the absolute time.
-
- if Ticks /= int'Last then
- Timedout := True;
-
- else
- Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
-
- if Ticks < 0 then
- Timedout := True;
- end if;
- end if;
- end if;
- end if;
-
- -- Take the mutex back
-
- Result :=
- semTake ((if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
- pragma Assert (Result = 0);
-
- exit when Timedout or Wakeup;
- end loop;
-
- else
- Timedout := True;
-
- -- Should never hold a lock while yielding
-
- if Single_Lock then
- Result := semGive (Single_RTS_Lock.Mutex);
- Result := taskDelay (0);
- Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
-
- else
- Result := semGive (Self_ID.Common.LL.L.Mutex);
- Result := taskDelay (0);
- Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
- end if;
- end if;
- end Timed_Sleep;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- -- This is for use in implementing delay statements, so we assume the
- -- caller is holding no locks.
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Orig : constant Duration := Monotonic_Clock;
- Absolute : Duration;
- Ticks : int;
- Timedout : Boolean;
- Aborted : Boolean := False;
-
- Result : int;
- pragma Warnings (Off, Result);
-
- begin
- if Mode = Relative then
- Absolute := Orig + Time;
- Ticks := To_Clock_Ticks (Time);
-
- if Ticks > 0 and then Ticks < int'Last then
-
- -- First tick will delay anytime between 0 and 1 / sysClkRateGet
- -- seconds, so we need to add one to be on the safe side.
-
- Ticks := Ticks + 1;
- end if;
-
- else
- Absolute := Time;
- Ticks := To_Clock_Ticks (Time - Orig);
- end if;
-
- if Ticks > 0 then
-
- -- Modifying State, locking the TCB
-
- Result :=
- semTake ((if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
-
- pragma Assert (Result = 0);
-
- Self_ID.Common.State := Delay_Sleep;
- Timedout := False;
-
- loop
- Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- -- Release the TCB before sleeping
-
- Result :=
- semGive (if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex);
- pragma Assert (Result = 0);
-
- exit when Aborted;
-
- Result := semTake (Self_ID.Common.LL.CV, Ticks);
-
- if Result /= 0 then
-
- -- If Ticks = int'last, it was most probably truncated, so make
- -- another round after recomputing Ticks from absolute time.
-
- if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then
- Timedout := True;
- else
- Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
-
- if Ticks < 0 then
- Timedout := True;
- end if;
- end if;
- end if;
-
- -- Take back the lock after having slept, to protect further
- -- access to Self_ID.
-
- Result :=
- semTake
- ((if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
-
- pragma Assert (Result = 0);
-
- exit when Timedout;
- end loop;
-
- Self_ID.Common.State := Runnable;
-
- Result :=
- semGive
- (if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex);
-
- else
- Result := taskDelay (0);
- end if;
- end Timed_Delay;
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- function Monotonic_Clock return Duration is
- TS : aliased timespec;
- Result : int;
- begin
- Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
- pragma Assert (Result = 0);
- return To_Duration (TS);
- end Monotonic_Clock;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- begin
- return 1.0 / Duration (sysClkRateGet);
- end RT_Resolution;
-
- ------------
- -- Wakeup --
- ------------
-
- procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
- pragma Unreferenced (Reason);
- Result : int;
- begin
- Result := semGive (T.Common.LL.CV);
- pragma Assert (Result = 0);
- end Wakeup;
-
- -----------
- -- Yield --
- -----------
-
- procedure Yield (Do_Yield : Boolean := True) is
- pragma Unreferenced (Do_Yield);
- Result : int;
- pragma Unreferenced (Result);
- begin
- Result := taskDelay (0);
- 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 : int;
-
- begin
- Result :=
- taskPrioritySet
- (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio)));
- pragma Assert (Result = 0);
-
- -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of
- -- the priority queue instead of the head. This is not the behavior
- -- required by Annex D (RM D.2.3(5/2)), but we consider it an acceptable
- -- variation (RM 1.1.3(6)), given this is the built-in behavior of the
- -- operating system. VxWorks versions starting from 6.7 implement the
- -- required Annex D semantics.
-
- -- In older versions we attempted to better approximate the Annex D
- -- required behavior, but this simulation was not entirely accurate,
- -- and it seems better to live with the standard VxWorks semantics.
-
- T.Common.Current_Priority := Prio;
- 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
- -- Store the user-level task id in the Thread field (to be used
- -- internally by the run-time system) and the kernel-level task id in
- -- the LWP field (to be used by the debugger).
-
- Self_ID.Common.LL.Thread := taskIdSelf;
- Self_ID.Common.LL.LWP := getpid;
-
- Specific.Set (Self_ID);
-
- -- Properly initializes the FPU for PPC/MIPS systems
-
- System.Float_Control.Reset;
-
- -- Install the signal handlers
-
- -- This is called for each task since there is no signal inheritance
- -- between VxWorks tasks.
-
- Install_Signal_Handlers;
-
- -- If stack checking is enabled, set the stack limit for this task
-
- if Set_Stack_Limit_Hook /= null then
- Set_Stack_Limit_Hook.all;
- 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 (taskIdSelf);
- end if;
- end Register_Foreign_Thread;
-
- --------------------
- -- Initialize_TCB --
- --------------------
-
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- begin
- Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
- Self_ID.Common.LL.Thread := Null_Thread_Id;
-
- if Self_ID.Common.LL.CV = 0 then
- Succeeded := False;
-
- else
- Succeeded := True;
-
- if not Single_Lock then
- Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
- end if;
- end if;
- 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
- Adjusted_Stack_Size : size_t;
-
- use type System.Multiprocessors.CPU_Range;
-
- begin
- -- Check whether both Dispatching_Domain and CPU are specified for
- -- the task, and the CPU value is not contained within the range of
- -- processors for the domain.
-
- if T.Common.Domain /= null
- and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
- and then
- (T.Common.Base_CPU not in T.Common.Domain'Range
- or else not T.Common.Domain (T.Common.Base_CPU))
- then
- Succeeded := False;
- return;
- end if;
-
- -- Ask for four extra bytes of stack space so that the ATCB pointer can
- -- be stored below the stack limit, plus extra space for the frame of
- -- Task_Wrapper. This is so the user gets the amount of stack requested
- -- exclusive of the needs.
-
- -- We also have to allocate n more bytes for the task name storage and
- -- enough space for the Wind Task Control Block which is around 0x778
- -- bytes. VxWorks also seems to carve out additional space, so use 2048
- -- as a nice round number. We might want to increment to the nearest
- -- page size in case we ever support VxVMI.
-
- -- ??? - we should come back and visit this so we can set the task name
- -- to something appropriate.
-
- Adjusted_Stack_Size := size_t (Stack_Size) + 2048;
-
- -- 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.
-
- -- We now compute the VxWorks task name and options, then spawn ...
-
- declare
- Name : aliased String (1 .. T.Common.Task_Image_Len + 1);
- Name_Address : System.Address;
- -- Task name we are going to hand down to VxWorks
-
- function Get_Task_Options return int;
- pragma Import (C, Get_Task_Options, "__gnat_get_task_options");
- -- Function that returns the options to be set for the task that we
- -- are creating. We fetch the options assigned to the current task,
- -- so offering some user level control over the options for a task
- -- hierarchy, and force VX_FP_TASK because it is almost always
- -- required.
-
- begin
- -- If there is no Ada task name handy, let VxWorks choose one.
- -- Otherwise, tell VxWorks what the Ada task name is.
-
- if T.Common.Task_Image_Len = 0 then
- Name_Address := System.Null_Address;
- else
- Name (1 .. Name'Last - 1) :=
- T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
- Name (Name'Last) := ASCII.NUL;
- Name_Address := Name'Address;
- end if;
-
- -- Now spawn the VxWorks task for real
-
- T.Common.LL.Thread :=
- taskSpawn
- (Name_Address,
- To_VxWorks_Priority (int (Priority)),
- Get_Task_Options,
- Adjusted_Stack_Size,
- Wrapper,
- To_Address (T));
- end;
-
- -- Set processor affinity
-
- Set_Task_Affinity (T);
-
- -- Only case of failure is if taskSpawn returned 0 (aka Null_Thread_Id)
-
- if T.Common.LL.Thread = Null_Thread_Id then
- Succeeded := False;
- else
- Succeeded := True;
- Task_Creation_Hook (T.Common.LL.Thread);
- Set_Priority (T, Priority);
- end if;
- end Create_Task;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- Result : int;
-
- begin
- if not Single_Lock then
- Result := semDelete (T.Common.LL.L.Mutex);
- pragma Assert (Result = 0);
- end if;
-
- T.Common.LL.Thread := Null_Thread_Id;
-
- Result := semDelete (T.Common.LL.CV);
- 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
- Specific.Set (null);
- end Exit_Task;
-
- ----------------
- -- Abort_Task --
- ----------------
-
- procedure Abort_Task (T : Task_Id) is
- Result : int;
- begin
- Result :=
- kill
- (T.Common.LL.Thread,
- Signal (Interrupt_Management.Abort_Task_Interrupt));
- pragma Assert (Result = 0);
- end Abort_Task;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (S : in out Suspension_Object) is
- begin
- -- Initialize internal state (always to False (RM D.10(6)))
-
- S.State := False;
- S.Waiting := False;
-
- -- Initialize internal mutex
-
- -- Use simpler binary semaphore instead of VxWorks mutual exclusion
- -- semaphore, because we don't need the fancier semantics and their
- -- overhead.
-
- S.L := semBCreate (SEM_Q_FIFO, SEM_FULL);
-
- -- Initialize internal condition variable
-
- S.CV := semBCreate (SEM_Q_FIFO, SEM_EMPTY);
- end Initialize;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (S : in out Suspension_Object) is
- pragma Unmodified (S);
- -- S may be modified on other targets, but not on VxWorks
-
- Result : STATUS;
-
- begin
- -- Destroy internal mutex
-
- Result := semDelete (S.L);
- pragma Assert (Result = OK);
-
- -- Destroy internal condition variable
-
- Result := semDelete (S.CV);
- pragma Assert (Result = OK);
- 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 : STATUS;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := semTake (S.L, WAIT_FOREVER);
- pragma Assert (Result = OK);
-
- S.State := False;
-
- Result := semGive (S.L);
- pragma Assert (Result = OK);
-
- SSL.Abort_Undefer.all;
- end Set_False;
-
- --------------
- -- Set_True --
- --------------
-
- procedure Set_True (S : in out Suspension_Object) is
- Result : STATUS;
-
- begin
- -- Set_True can be called from an interrupt context, in which case
- -- Abort_Defer is undefined.
-
- if Is_Task_Context then
- SSL.Abort_Defer.all;
- end if;
-
- Result := semTake (S.L, WAIT_FOREVER);
- pragma Assert (Result = OK);
-
- -- 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 := semGive (S.CV);
- pragma Assert (Result = OK);
- else
- S.State := True;
- end if;
-
- Result := semGive (S.L);
- pragma Assert (Result = OK);
-
- -- Set_True can be called from an interrupt context, in which case
- -- Abort_Undefer is undefined.
-
- if Is_Task_Context then
- SSL.Abort_Undefer.all;
- end if;
-
- end Set_True;
-
- ------------------------
- -- Suspend_Until_True --
- ------------------------
-
- procedure Suspend_Until_True (S : in out Suspension_Object) is
- Result : STATUS;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := semTake (S.L, WAIT_FOREVER);
-
- 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 := semGive (S.L);
- pragma Assert (Result = OK);
-
- 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 (RM D.10 (9)).
-
- if S.State then
- S.State := False;
-
- Result := semGive (S.L);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
-
- else
- S.Waiting := True;
-
- -- Release the mutex before sleeping
-
- Result := semGive (S.L);
- pragma Assert (Result = OK);
-
- SSL.Abort_Undefer.all;
-
- Result := semTake (S.CV, WAIT_FOREVER);
- pragma Assert (Result = 0);
- end if;
- 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 /= Null_Thread_Id
- and then T.Common.LL.Thread /= Thread_Self
- then
- return taskSuspend (T.Common.LL.Thread) = 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 /= Null_Thread_Id
- and then T.Common.LL.Thread /= Thread_Self
- then
- return taskResume (T.Common.LL.Thread) = 0;
- else
- return True;
- end if;
- end Resume_Task;
-
- --------------------
- -- Stop_All_Tasks --
- --------------------
-
- procedure Stop_All_Tasks
- is
- Thread_Self : constant Thread_Id := taskIdSelf;
- C : Task_Id;
-
- Dummy : int;
- Old : int;
-
- begin
- Old := Int_Lock;
-
- C := All_Tasks_List;
- while C /= null loop
- if C.Common.LL.Thread /= Null_Thread_Id
- and then C.Common.LL.Thread /= Thread_Self
- then
- Dummy := Task_Stop (C.Common.LL.Thread);
- end if;
-
- C := C.Common.All_Tasks_Link;
- end loop;
-
- Dummy := Int_Unlock (Old);
- end Stop_All_Tasks;
-
- ---------------
- -- Stop_Task --
- ---------------
-
- function Stop_Task (T : ST.Task_Id) return Boolean is
- begin
- if T.Common.LL.Thread /= Null_Thread_Id then
- return Task_Stop (T.Common.LL.Thread) = 0;
- else
- return True;
- end if;
- end Stop_Task;
-
- -------------------
- -- Continue_Task --
- -------------------
-
- function Continue_Task (T : ST.Task_Id) return Boolean
- is
- begin
- if T.Common.LL.Thread /= Null_Thread_Id then
- return Task_Cont (T.Common.LL.Thread) = 0;
- else
- return True;
- end if;
- end Continue_Task;
-
- ---------------------
- -- Is_Task_Context --
- ---------------------
-
- function Is_Task_Context return Boolean is
- begin
- return System.OS_Interface.Interrupt_Context /= 1;
- end Is_Task_Context;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- Result : int;
- pragma Unreferenced (Result);
-
- begin
- Environment_Task_Id := Environment_Task;
-
- Interrupt_Management.Initialize;
- Specific.Initialize;
-
- if Locking_Policy = 'C' then
- Mutex_Protocol := Prio_Protect;
- elsif Locking_Policy = 'I' then
- Mutex_Protocol := Prio_Inherit;
- else
- Mutex_Protocol := Prio_None;
- end if;
-
- if Time_Slice_Val > 0 then
- Result :=
- Set_Time_Slice
- (To_Clock_Ticks
- (Duration (Time_Slice_Val) / Duration (1_000_000.0)));
-
- elsif Dispatching_Policy = 'R' then
- Result := Set_Time_Slice (To_Clock_Ticks (0.01));
-
- end if;
-
- -- Initialize the lock used to synchronize chain of all ATCBs
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- -- 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);
-
- -- Set processor affinity
-
- Set_Task_Affinity (Environment_Task);
- end Initialize;
-
- -----------------------
- -- Set_Task_Affinity --
- -----------------------
-
- procedure Set_Task_Affinity (T : ST.Task_Id) is
- Result : int := 0;
- pragma Unreferenced (Result);
-
- use System.Task_Info;
- use type System.Multiprocessors.CPU_Range;
-
- begin
- -- Do nothing if the underlying thread has not yet been created. If the
- -- thread has not yet been created then the proper affinity will be set
- -- during its creation.
-
- if T.Common.LL.Thread = Null_Thread_Id then
- null;
-
- -- pragma CPU
-
- elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
-
- -- Ada 2012 pragma CPU uses CPU numbers starting from 1, while on
- -- VxWorks the first CPU is identified by a 0, so we need to adjust.
-
- Result :=
- taskCpuAffinitySet
- (T.Common.LL.Thread, int (T.Common.Base_CPU) - 1);
-
- -- Task_Info
-
- elsif T.Common.Task_Info /= Unspecified_Task_Info then
- Result := taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info);
-
- -- Handle dispatching domains
-
- elsif T.Common.Domain /= null
- and then (T.Common.Domain /= ST.System_Domain
- or else T.Common.Domain.all /=
- (Multiprocessors.CPU'First ..
- Multiprocessors.Number_Of_CPUs => True))
- then
- declare
- CPU_Set : unsigned := 0;
-
- begin
- -- Set the affinity to all the processors belonging to the
- -- dispatching domain.
-
- for Proc in T.Common.Domain'Range loop
- if T.Common.Domain (Proc) then
-
- -- The thread affinity mask is a bit vector in which each
- -- bit represents a logical processor.
-
- CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1);
- end if;
- end loop;
-
- Result := taskMaskAffinitySet (T.Common.LL.Thread, CPU_Set);
- end;
- end if;
- end Set_Task_Affinity;
-
-end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . 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 --
+-- <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 a no tasking version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+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.
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking;
+ use System.Parameters;
+
+ pragma Warnings (Off);
+ -- Turn off warnings since so many unreferenced parameters
+
+ --------------
+ -- Specific --
+ --------------
+
+ -- Package Specific contains target specific routines, and the body of
+ -- this package is target specific.
+
+ package Specific is
+ procedure Set (Self_Id : Task_Id);
+ pragma Inline (Set);
+ -- Set the self id for the current task
+ end Specific;
+
+ package body Specific is
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ begin
+ null;
+ end Set;
+ end Specific;
+
+ ----------------------------------
+ -- ATCB allocation/deallocation --
+ ----------------------------------
+
+ package body ATCB_Allocation is separate;
+ -- The body of this package is shared across several targets
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
+ begin
+ null;
+ end Abort_Task;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
+ begin
+ return True;
+ end Check_No_Locks;
+
+ -------------------
+ -- Continue_Task --
+ -------------------
+
+ function Continue_Task (T : ST.Task_Id) return Boolean is
+ begin
+ return False;
+ end Continue_Task;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ begin
+ return False;
+ end Current_State;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_Id is
+ begin
+ return null;
+ end Environment_Task;
+
+ -----------------
+ -- 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
+ begin
+ Succeeded := False;
+ end Create_Task;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_Id) is
+ begin
+ null;
+ end Enter_Task;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ null;
+ end Exit_Task;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ begin
+ null;
+ end Finalize;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : not null access Lock) is
+ begin
+ null;
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : not null access RTS_Lock) is
+ begin
+ null;
+ end Finalize_Lock;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_Id) is
+ begin
+ null;
+ end Finalize_TCB;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_Id) return System.Any_Priority is
+ begin
+ return 0;
+ end Get_Priority;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
+ begin
+ return OSI.Thread_Id (T.Common.LL.Thread);
+ end Get_Thread_Id;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ No_Tasking : Boolean;
+ begin
+ raise Program_Error with "tasking not implemented on this configuration";
+ end Initialize;
+
+ procedure Initialize (S : in out Suspension_Object) is
+ begin
+ null;
+ end Initialize;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : not null access Lock)
+ is
+ begin
+ null;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock; Level : Lock_Level) is
+ begin
+ null;
+ end Initialize_Lock;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
+ begin
+ Succeeded := False;
+ end Initialize_TCB;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return False;
+ end Is_Valid_Task;
+
+ --------------
+ -- Lock_RTS --
+ --------------
+
+ procedure Lock_RTS is
+ begin
+ null;
+ end Lock_RTS;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ begin
+ return 0.0;
+ end Monotonic_Clock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
+ begin
+ Ceiling_Violation := False;
+ end Read_Lock;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_Id is
+ begin
+ return null;
+ end Register_Foreign_Thread;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_Id;
+ Thread_Self : OSI.Thread_Id) return Boolean
+ is
+ begin
+ return False;
+ end Resume_Task;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 10#1.0#E-6;
+ end RT_Resolution;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id is
+ begin
+ return Null_Task;
+ end Self;
+
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ begin
+ null;
+ end Set_Ceiling;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ begin
+ null;
+ end Set_False;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_Id;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ begin
+ null;
+ end Set_Priority;
+
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ begin
+ null;
+ end Set_Task_Affinity;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ begin
+ null;
+ end Set_True;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
+ begin
+ null;
+ end Sleep;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ begin
+ null;
+ end Stack_Guard;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_Id;
+ Thread_Self : OSI.Thread_Id) return Boolean
+ is
+ begin
+ return False;
+ end Suspend_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;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ begin
+ null;
+ end Suspend_Until_True;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ begin
+ null;
+ end Timed_Delay;
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ procedure Timed_Sleep
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ begin
+ Timedout := False;
+ Yielded := False;
+ end Timed_Sleep;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : not null access Lock) is
+ begin
+ null;
+ end Unlock;
+
+ procedure Unlock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ begin
+ null;
+ end Unlock;
+
+ procedure Unlock (T : Task_Id) is
+ begin
+ null;
+ end Unlock;
+
+ ----------------
+ -- Unlock_RTS --
+ ----------------
+
+ procedure Unlock_RTS is
+ begin
+ null;
+ end Unlock_RTS;
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
+ begin
+ null;
+ end Wakeup;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
+ begin
+ Ceiling_Violation := False;
+ end Write_Lock;
+
+ procedure Write_Lock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ begin
+ null;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_Id) is
+ begin
+ null;
+ end Write_Lock;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ begin
+ null;
+ end Yield;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2011, 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 a HP-UX DCE threads (HPUX 10) version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+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_Primitives.Interrupt_Operations;
+
+pragma Warnings (Off);
+with System.Interrupt_Management.Operations;
+pragma Elaborate_All (System.Interrupt_Management.Operations);
+pragma Warnings (On);
+
+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;
+
+ package PIO renames System.Task_Primitives.Interrupt_Operations;
+
+ ----------------
+ -- 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 unblocked in all tasks
+
+ 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");
+
+ -- Note: the reason that Locking_Policy is not needed is that this
+ -- is not implemented for DCE threads. The HPUX 10 port is at this
+ -- stage considered dead, and no further work is planned on it.
+
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads)
+
+ --------------------
+ -- 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 the 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) return Task_Id;
+ -- Allocate and Initialize a new ATCB for the current Thread
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_Id is separate;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler (Sig : Signal);
+
+ function To_Address is
+ new Ada.Unchecked_Conversion (Task_Id, System.Address);
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ procedure Abort_Handler (Sig : Signal) is
+ pragma Unreferenced (Sig);
+
+ Self_Id : constant Task_Id := Self;
+ Result : Interfaces.C.int;
+ Old_Set : aliased sigset_t;
+
+ begin
+ if Self_Id.Deferral_Level = 0
+ and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
+ and then not Self_Id.Aborting
+ then
+ Self_Id.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;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ -- The underlying thread system sets a guard page at the bottom of a thread
+ -- stack, so nothing is needed.
+ -- ??? Check the comment above
+
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ pragma Unreferenced (T, On);
+ begin
+ null;
+ 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;
+
+ L.Priority := Prio;
+
+ Result := pthread_mutex_init (L.L'Access, Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ 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;
+
+ Result := pthread_mutex_init (L, Attributes'Access);
+
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ 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.L'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
+ L.Owner_Priority := Get_Priority (Self);
+
+ if L.Priority < L.Owner_Priority then
+ Ceiling_Violation := True;
+ return;
+ end if;
+
+ Result := pthread_mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ Ceiling_Violation := False;
+ 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.L'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 --
+ -----------------
+
+ procedure Timed_Sleep
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ pragma Unreferenced (Reason);
+
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ Timedout := True;
+ Yielded := False;
+
+ Abs_Time :=
+ (if Mode = Relative
+ then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (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);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ 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 --
+ -----------------
+
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_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);
+
+ Abs_Time :=
+ (if Mode = Relative
+ then Time + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (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);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ 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 (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 10#1.0#E-6;
+ 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 --
+ ------------------
+
+ type Prio_Array_Type is array (System.Any_Priority) of Integer;
+ pragma Atomic_Components (Prio_Array_Type);
+
+ Prio_Array : Prio_Array_Type;
+ -- Global array containing the id of the currently running task for
+ -- each priority.
+ --
+ -- Note: assume we are on single processor with run-til-blocked scheduling
+
+ procedure Set_Priority
+ (T : Task_Id;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ Array_Item : Integer;
+ 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
+ Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
+
+ if 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);
+
+ if Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' then
+
+ -- Annex D requirement [RM D.2.2 par. 9]:
+ -- If the task drops its priority due to the loss of inherited
+ -- priority, it is added at the head of the ready queue for its
+ -- new active priority.
+
+ if Loss_Of_Inheritance
+ and then Prio < T.Common.Current_Priority
+ then
+ Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
+ Prio_Array (T.Common.Base_Priority) := Array_Item;
+
+ loop
+ -- Let some processes a chance to arrive
+
+ Yield;
+
+ -- Then wait for our turn to proceed
+
+ exit when Array_Item = Prio_Array (T.Common.Base_Priority)
+ or else Prio_Array (T.Common.Base_Priority) = 1;
+ end loop;
+
+ Prio_Array (T.Common.Base_Priority) :=
+ Prio_Array (T.Common.Base_Priority) - 1;
+ end if;
+ end if;
+
+ T.Common.Current_Priority := Prio;
+ 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;
+ Specific.Set (Self_ID);
+ 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
+ if not Single_Lock then
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ 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 :=
+ 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;
+ Result : Interfaces.C.int;
+
+ function Thread_Body_Access is new
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ begin
+ 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_setstacksize
+ (Attributes'Access, Interfaces.C.size_t (Stack_Size));
+ pragma Assert (Result = 0);
+
+ -- 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.
+
+ Result := pthread_create
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
+ pragma Assert (Result = 0 or else Result = EAGAIN);
+
+ Succeeded := Result = 0;
+
+ pthread_detach (T.Common.LL.Thread'Access);
+ -- Detach the thread using pthread_detach, since DCE threads do not have
+ -- pthread_attr_set_detachstate.
+
+ Result := pthread_attr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+
+ Set_Priority (T, Priority);
+ 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
+ Specific.Set (null);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
+ begin
+ -- Interrupt Server_Tasks may be waiting on an "event" flag (signal)
+
+ if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
+ System.Interrupt_Management.Operations.Interrupt_Self_Process
+ (PIO.Get_Interrupt_ID (T));
+ 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 (ARM D.10(6)))
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ -- Initialize internal condition variable
+
+ 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);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+ end if;
+ 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 ARM D.10 par. 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
+ -- (ARM D.10 par. 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
+ pragma Unreferenced (T);
+ pragma Unreferenced (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);
+ pragma Unreferenced (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);
+
+ -- 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);
+
+ -- Install the abort-signal handler
+
+ 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);
+ end if;
+ end Initialize;
+
+ -- NOTE: Unlike other pthread implementations, we do *not* mask all
+ -- signals here since we handle signals using the process-wide primitive
+ -- signal, rather than using sigthreadmask and sigwait. The reason of
+ -- this difference is that sigwait doesn't work when some critical
+ -- signals (SIGABRT, SIGPIPE) are masked.
+
+ -----------------------
+ -- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA 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 --
+-- <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 a GNU/Linux (GNU/LinuxThreads) version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+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 Interfaces.C; use Interfaces; use type Interfaces.C.int;
+
+with System.Task_Info;
+with System.Tasking.Debug;
+with System.Interrupt_Management;
+with System.OS_Constants;
+with System.OS_Primitives;
+with System.Multiprocessors;
+
+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 System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+ use System.Task_Info;
+
+ ----------------
+ -- 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
+
+ Null_Thread_Id : constant pthread_t := pthread_t'Last;
+ -- Constant to indicate that the thread identifier has not yet been
+ -- initialized.
+
+ --------------------
+ -- 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) return Task_Id;
+ -- Allocate and Initialize a new ATCB for the current Thread
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_Id is separate;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler (signo : Signal);
+
+ function GNAT_pthread_condattr_setup
+ (attr : access pthread_condattr_t) return C.int;
+ pragma Import
+ (C, GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
+
+ function GNAT_has_cap_sys_nice return C.int;
+ pragma Import
+ (C, GNAT_has_cap_sys_nice, "__gnat_has_cap_sys_nice");
+ -- We do not have pragma Linker_Options ("-lcap"); here, because this
+ -- library is not present on many Linux systems. 'libcap' is the Linux
+ -- "capabilities" library, called by __gnat_has_cap_sys_nice.
+
+ function Prio_To_Linux_Prio (Prio : Any_Priority) return C.int is
+ (C.int (Prio) + 1);
+ -- Convert Ada priority to Linux priority. Priorities are 1 .. 99 on
+ -- GNU/Linux, so we map 0 .. 98 to 1 .. 99.
+
+ function Get_Ceiling_Support return Boolean;
+ -- Get the value of the Ceiling_Support constant (see below).
+ -- Note well: If this function or related code is modified, it should be
+ -- tested by hand, because automated testing doesn't exercise it.
+
+ function Get_Ceiling_Support return Boolean is
+ Ceiling_Support : Boolean := False;
+ begin
+ if Locking_Policy /= 'C' then
+ return False;
+ end if;
+
+ declare
+ function geteuid return Integer;
+ pragma Import (C, geteuid, "geteuid");
+ Superuser : constant Boolean := geteuid = 0;
+ Has_Cap : constant C.int := GNAT_has_cap_sys_nice;
+ pragma Assert (Has_Cap in 0 | 1);
+ begin
+ Ceiling_Support := Superuser or else Has_Cap = 1;
+ end;
+
+ return Ceiling_Support;
+ end Get_Ceiling_Support;
+
+ pragma Warnings (Off, "non-static call not allowed in preelaborated unit");
+ Ceiling_Support : constant Boolean := Get_Ceiling_Support;
+ pragma Warnings (On, "non-static call not allowed in preelaborated unit");
+ -- True if the locking policy is Ceiling_Locking, and the current process
+ -- has permission to use this policy. The process has permission if it is
+ -- running as 'root', or if the capability was set by the setcap command,
+ -- as in "sudo /sbin/setcap cap_sys_nice=ep exe_file". If it doesn't have
+ -- permission, then a request for Ceiling_Locking is ignored.
+
+ type RTS_Lock_Ptr is not null access all RTS_Lock;
+
+ function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int;
+ -- Initialize the mutex L. If Ceiling_Support is True, then set the ceiling
+ -- to Prio. Returns 0 for success, or ENOMEM for out-of-memory.
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ procedure Abort_Handler (signo : Signal) is
+ pragma Unreferenced (signo);
+
+ Self_Id : constant Task_Id := Self;
+ Result : C.int;
+ Old_Set : aliased sigset_t;
+
+ 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 Self_Id.Deferral_Level = 0
+ and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
+ and then not Self_Id.Aborting
+ then
+ Self_Id.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;
+
+ --------------
+ -- 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;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ -- The underlying thread system extends the memory (up to 2MB) when needed
+
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ pragma Unreferenced (T);
+ pragma Unreferenced (On);
+ begin
+ null;
+ 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;
+
+ ----------------
+ -- Init_Mutex --
+ ----------------
+
+ function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Result, Result_2 : C.int;
+
+ begin
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result in 0 | ENOMEM);
+
+ if Result = ENOMEM then
+ return Result;
+ end if;
+
+ if Ceiling_Support then
+ Result := pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Mutex_Attr'Access, Prio_To_Linux_Prio (Prio));
+ 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 (L, Mutex_Attr'Access);
+ pragma Assert (Result in 0 | ENOMEM);
+
+ Result_2 := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result_2 = 0);
+ return Result; -- of pthread_mutex_init, not pthread_mutexattr_destroy
+ end Init_Mutex;
+
+ ---------------------
+ -- 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 : Any_Priority;
+ L : not null access Lock)
+ is
+ begin
+ if Locking_Policy = 'R' then
+ declare
+ RWlock_Attr : aliased pthread_rwlockattr_t;
+ Result : C.int;
+
+ begin
+ -- Set the rwlock to prefer writer to avoid writers starvation
+
+ Result := pthread_rwlockattr_init (RWlock_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_rwlockattr_setkind_np
+ (RWlock_Attr'Access,
+ PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP);
+ pragma Assert (Result = 0);
+
+ Result := pthread_rwlock_init (L.RW'Access, RWlock_Attr'Access);
+
+ pragma Assert (Result in 0 | ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+ end;
+
+ else
+ if Init_Mutex (L.WO'Access, Prio) = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+ end if;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock; Level : Lock_Level)
+ is
+ pragma Unreferenced (Level);
+ begin
+ if Init_Mutex (L.all'Access, Any_Priority'Last) = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : not null access Lock) is
+ Result : C.int;
+ begin
+ if Locking_Policy = 'R' then
+ Result := pthread_rwlock_destroy (L.RW'Access);
+ else
+ Result := pthread_mutex_destroy (L.WO'Access);
+ end if;
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : not null access RTS_Lock) is
+ Result : 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 : C.int;
+ begin
+ if Locking_Policy = 'R' then
+ Result := pthread_rwlock_wrlock (L.RW'Access);
+ else
+ Result := pthread_mutex_lock (L.WO'Access);
+ end if;
+
+ -- The cause of EINVAL is a priority ceiling violation
+
+ pragma Assert (Result in 0 | EINVAL);
+ Ceiling_Violation := Result = EINVAL;
+ end Write_Lock;
+
+ procedure Write_Lock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ Result : 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 : 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
+ Result : C.int;
+ begin
+ if Locking_Policy = 'R' then
+ Result := pthread_rwlock_rdlock (L.RW'Access);
+ else
+ Result := pthread_mutex_lock (L.WO'Access);
+ end if;
+
+ -- The cause of EINVAL is a priority ceiling violation
+
+ pragma Assert (Result in 0 | EINVAL);
+ Ceiling_Violation := Result = EINVAL;
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : not null access Lock) is
+ Result : C.int;
+ begin
+ if Locking_Policy = 'R' then
+ Result := pthread_rwlock_unlock (L.RW'Access);
+ else
+ Result := pthread_mutex_unlock (L.WO'Access);
+ end if;
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ Result : 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 : 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 : 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 : C.int;
+
+ begin
+ pragma Assert (Self_ID = Self);
+
+ 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 in 0 | 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 : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ pragma Unreferenced (Reason);
+
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : C.int;
+
+ begin
+ Timedout := True;
+ Yielded := False;
+
+ Abs_Time :=
+ (if Mode = Relative
+ then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (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 in 0 | 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 : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+
+ Result : C.int;
+ pragma Warnings (Off, Result);
+
+ begin
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ Write_Lock (Self_ID);
+
+ Abs_Time :=
+ (if Mode = Relative
+ then Time + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (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 in 0 | ETIMEDOUT | 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 : 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 : 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 : 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 : 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 : Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ pragma Unreferenced (Loss_Of_Inheritance);
+
+ Result : C.int;
+ Param : aliased struct_sched_param;
+
+ function Get_Policy (Prio : 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 := Prio_To_Linux_Prio (Prio);
+
+ if 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
+ Param.sched_priority := 0;
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread,
+ SCHED_OTHER, Param'Access);
+ end if;
+
+ pragma Assert (Result in 0 | EPERM | EINVAL);
+ end Set_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_Id) return Any_Priority is
+ begin
+ return T.Common.Current_Priority;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_Id) is
+ begin
+ if Self_ID.Common.Task_Info /= null
+ and then Self_ID.Common.Task_Info.CPU_Affinity = No_CPU
+ then
+ raise Invalid_CPU_Number;
+ end if;
+
+ Self_ID.Common.LL.Thread := pthread_self;
+ Self_ID.Common.LL.LWP := lwp_self;
+
+ -- Set thread name to ease debugging. If the name of the task is
+ -- "foreign thread" (as set by Register_Foreign_Thread) retrieve
+ -- the name of the thread and update the name of the task instead.
+
+ if Self_ID.Common.Task_Image_Len = 14
+ and then Self_ID.Common.Task_Image (1 .. 14) = "foreign thread"
+ then
+ declare
+ Thread_Name : String (1 .. 16);
+ -- PR_GET_NAME returns a string of up to 16 bytes
+
+ Len : Natural := 0;
+ -- Length of the task name contained in Task_Name
+
+ Result : C.int;
+ -- Result from the prctl call
+ begin
+ Result := prctl (PR_GET_NAME, unsigned_long (Thread_Name'Address));
+ pragma Assert (Result = 0);
+
+ -- Find the length of the given name
+
+ for J in Thread_Name'Range loop
+ if Thread_Name (J) /= ASCII.NUL then
+ Len := Len + 1;
+ else
+ exit;
+ end if;
+ end loop;
+
+ -- Cover the odd situation where someone decides to change
+ -- Parameters.Max_Task_Image_Length to less than 16 characters.
+
+ if Len > Parameters.Max_Task_Image_Length then
+ Len := Parameters.Max_Task_Image_Length;
+ end if;
+
+ -- Copy the name of the thread to the task's ATCB
+
+ Self_ID.Common.Task_Image (1 .. Len) := Thread_Name (1 .. Len);
+ Self_ID.Common.Task_Image_Len := Len;
+ end;
+
+ elsif Self_ID.Common.Task_Image_Len > 0 then
+ declare
+ Task_Name : String (1 .. Parameters.Max_Task_Image_Length + 1);
+ Result : C.int;
+
+ begin
+ Task_Name (1 .. Self_ID.Common.Task_Image_Len) :=
+ Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len);
+ Task_Name (Self_ID.Common.Task_Image_Len + 1) := ASCII.NUL;
+
+ Result := prctl (PR_SET_NAME, unsigned_long (Task_Name'Address));
+ pragma Assert (Result = 0);
+ end;
+ end if;
+
+ Specific.Set (Self_ID);
+
+ if Use_Alternate_Stack
+ and then Self_ID.Common.Task_Alternate_Stack /= Null_Address
+ then
+ declare
+ Stack : aliased stack_t;
+ Result : 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
+ Result : 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);
+
+ Self_ID.Common.LL.Thread := Null_Thread_Id;
+
+ if not Single_Lock then
+ if Init_Mutex
+ (Self_ID.Common.LL.L'Access, Any_Priority'Last) /= 0
+ then
+ Succeeded := False;
+ return;
+ end if;
+ end if;
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result in 0 | 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 in 0 | 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 : Any_Priority;
+ Succeeded : out Boolean)
+ is
+ Thread_Attr : aliased pthread_attr_t;
+ Adjusted_Stack_Size : C.size_t;
+ Result : C.int;
+
+ use type Multiprocessors.CPU_Range, Interfaces.C.size_t;
+
+ begin
+ -- Check whether both Dispatching_Domain and CPU are specified for
+ -- the task, and the CPU value is not contained within the range of
+ -- processors for the domain.
+
+ if T.Common.Domain /= null
+ and then T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU
+ and then
+ (T.Common.Base_CPU not in T.Common.Domain'Range
+ or else not T.Common.Domain (T.Common.Base_CPU))
+ then
+ Succeeded := False;
+ return;
+ end if;
+
+ Adjusted_Stack_Size := C.size_t (Stack_Size + Alternate_Stack_Size);
+
+ Result := pthread_attr_init (Thread_Attr'Access);
+ pragma Assert (Result in 0 | ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result :=
+ pthread_attr_setstacksize (Thread_Attr'Access, Adjusted_Stack_Size);
+ pragma Assert (Result = 0);
+
+ Result :=
+ pthread_attr_setdetachstate
+ (Thread_Attr'Access, PTHREAD_CREATE_DETACHED);
+ pragma Assert (Result = 0);
+
+ -- Set the required attributes for the creation of the thread
+
+ -- Note: Previously, we called pthread_setaffinity_np (after thread
+ -- creation but before thread activation) to set the affinity but it was
+ -- not behaving as expected. Setting the required attributes for the
+ -- creation of the thread works correctly and it is more appropriate.
+
+ -- Do nothing if required support not provided by the operating system
+
+ if pthread_attr_setaffinity_np'Address = Null_Address then
+ null;
+
+ -- Support is available
+
+ elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
+ declare
+ CPUs : constant size_t :=
+ C.size_t (Multiprocessors.Number_Of_CPUs);
+ CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
+ Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
+
+ begin
+ CPU_ZERO (Size, CPU_Set);
+ System.OS_Interface.CPU_SET
+ (int (T.Common.Base_CPU), Size, CPU_Set);
+ Result :=
+ pthread_attr_setaffinity_np (Thread_Attr'Access, Size, CPU_Set);
+ pragma Assert (Result = 0);
+
+ CPU_FREE (CPU_Set);
+ end;
+
+ -- Handle Task_Info
+
+ elsif T.Common.Task_Info /= null then
+ Result :=
+ pthread_attr_setaffinity_np
+ (Thread_Attr'Access,
+ CPU_SETSIZE / 8,
+ T.Common.Task_Info.CPU_Affinity'Access);
+ pragma Assert (Result = 0);
+
+ -- Handle dispatching domains
+
+ -- To avoid changing CPU affinities when not needed, we set the
+ -- affinity only when assigning to a domain other than the default
+ -- one, or when the default one has been modified.
+
+ elsif T.Common.Domain /= null and then
+ (T.Common.Domain /= ST.System_Domain
+ or else T.Common.Domain.all /=
+ (Multiprocessors.CPU'First ..
+ Multiprocessors.Number_Of_CPUs => True))
+ then
+ declare
+ CPUs : constant size_t :=
+ C.size_t (Multiprocessors.Number_Of_CPUs);
+ CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
+ Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
+
+ begin
+ CPU_ZERO (Size, CPU_Set);
+
+ -- Set the affinity to all the processors belonging to the
+ -- dispatching domain.
+
+ for Proc in T.Common.Domain'Range loop
+ if T.Common.Domain (Proc) then
+ System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
+ end if;
+ end loop;
+
+ Result :=
+ pthread_attr_setaffinity_np (Thread_Attr'Access, Size, CPU_Set);
+ pragma Assert (Result = 0);
+
+ CPU_FREE (CPU_Set);
+ end;
+ 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,
+ Thread_Attr'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
+
+ pragma Assert (Result in 0 | EAGAIN | ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ Result := pthread_attr_destroy (Thread_Attr'Access);
+ pragma Assert (Result = 0);
+ return;
+ end if;
+
+ Succeeded := True;
+
+ Result := pthread_attr_destroy (Thread_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Set_Priority (T, Priority);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_Id) is
+ Result : 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
+ Specific.Set (null);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
+ Result : C.int;
+
+ ESRCH : constant := 3; -- No such process
+ -- It can happen that T has already vanished, in which case pthread_kill
+ -- returns ESRCH, so we don't consider that to be an error.
+
+ begin
+ if Abort_Handler_Installed then
+ Result :=
+ pthread_kill
+ (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ pragma Assert (Result in 0 | ESRCH);
+ end if;
+ end Abort_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ Result : C.int;
+
+ begin
+ -- Initialize internal state (always to False (RM D.10(6)))
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ Result := pthread_mutex_init (S.L'Access, null);
+
+ pragma Assert (Result in 0 | ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ -- Initialize internal condition variable
+
+ Result := pthread_cond_init (S.CV'Access, null);
+
+ pragma Assert (Result in 0 | ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+ end if;
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ Result : 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 : 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 : 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 ARM D.10 par. 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 : 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). This should not
+ -- happen with the current Linux implementation of pthread, but
+ -- POSIX does not guarantee it so this may change in future.
+
+ Result := pthread_cond_wait (S.CV'Access, S.L'Access);
+ pragma Assert (Result in 0 | 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;
+
+ ------------------
+ -- 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 : C.int;
+ -- Whether to use an alternate signal stack for stack overflows
+
+ 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 be 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_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ -- Initialize the global RTS lock
+
+ 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 (Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ Abort_Handler_Installed := True;
+ end if;
+
+ -- pragma CPU and dispatching domains for the environment task
+
+ Set_Task_Affinity (Environment_Task);
+ end Initialize;
+
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ use type Multiprocessors.CPU_Range;
+
+ begin
+ -- Do nothing if there is no support for setting affinities or the
+ -- underlying thread has not yet been created. If the thread has not
+ -- yet been created then the proper affinity will be set during its
+ -- creation.
+
+ if pthread_setaffinity_np'Address /= Null_Address
+ and then T.Common.LL.Thread /= Null_Thread_Id
+ then
+ declare
+ CPUs : constant size_t :=
+ C.size_t (Multiprocessors.Number_Of_CPUs);
+ CPU_Set : cpu_set_t_ptr := null;
+ Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
+
+ Result : C.int;
+
+ begin
+ -- We look at the specific CPU (Base_CPU) first, then at the
+ -- Task_Info field, and finally at the assigned dispatching
+ -- domain, if any.
+
+ if T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
+
+ -- Set the affinity to an unique CPU
+
+ CPU_Set := CPU_ALLOC (CPUs);
+ System.OS_Interface.CPU_ZERO (Size, CPU_Set);
+ System.OS_Interface.CPU_SET
+ (int (T.Common.Base_CPU), Size, CPU_Set);
+
+ -- Handle Task_Info
+
+ elsif T.Common.Task_Info /= null then
+ CPU_Set := T.Common.Task_Info.CPU_Affinity'Access;
+
+ -- Handle dispatching domains
+
+ elsif T.Common.Domain /= null and then
+ (T.Common.Domain /= ST.System_Domain
+ or else T.Common.Domain.all /=
+ (Multiprocessors.CPU'First ..
+ Multiprocessors.Number_Of_CPUs => True))
+ then
+ -- Set the affinity to all the processors belonging to the
+ -- dispatching domain. To avoid changing CPU affinities when
+ -- not needed, we set the affinity only when assigning to a
+ -- domain other than the default one, or when the default one
+ -- has been modified.
+
+ CPU_Set := CPU_ALLOC (CPUs);
+ System.OS_Interface.CPU_ZERO (Size, CPU_Set);
+
+ for Proc in T.Common.Domain'Range loop
+ if T.Common.Domain (Proc) then
+ System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
+ end if;
+ end loop;
+ end if;
+
+ -- We set the new affinity if needed. Otherwise, the new task
+ -- will inherit its creator's CPU affinity mask (according to
+ -- the documentation of pthread_setaffinity_np), which is
+ -- consistent with Ada's required semantics.
+
+ if CPU_Set /= null then
+ Result :=
+ pthread_setaffinity_np (T.Common.LL.Thread, Size, CPU_Set);
+ pragma Assert (Result = 0);
+
+ CPU_FREE (CPU_Set);
+ end if;
+ end;
+ end if;
+ end Set_Task_Affinity;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . 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 --
+-- <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 a NT (native) version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+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 Interfaces.C;
+with Interfaces.C.Strings;
+
+with System.Float_Control;
+with System.Interrupt_Management;
+with System.Multiprocessors;
+with System.OS_Primitives;
+with System.Task_Info;
+with System.Tasking.Debug;
+with System.Win32.Ext;
+
+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 SSL renames System.Soft_Links;
+
+ use Interfaces.C;
+ use Interfaces.C.Strings;
+ use System.OS_Interface;
+ use System.OS_Primitives;
+ use System.Parameters;
+ use System.Task_Info;
+ use System.Tasking;
+ use System.Tasking.Debug;
+ use System.Win32;
+ use System.Win32.Ext;
+
+ pragma Link_With ("-Xlinker --stack=0x200000,0x1000");
+ -- Change the default stack size (2 MB) for tasking programs on Windows.
+ -- This allows about 1000 tasks running at the same time. Note that
+ -- we set the stack size for non tasking programs on System unit.
+ -- Also note that under Windows XP, we use a Windows XP extension to
+ -- specify the stack size on a per task basis, as done under other OSes.
+
+ ---------------------
+ -- Local Functions --
+ ---------------------
+
+ procedure InitializeCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure InitializeCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import
+ (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
+
+ procedure EnterCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure EnterCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
+
+ procedure LeaveCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure LeaveCriticalSection (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
+
+ procedure DeleteCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure DeleteCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
+
+ ----------------
+ -- Local Data --
+ ----------------
+
+ Environment_Task_Id : Task_Id;
+ -- A variable to hold Task_Id for the environment task
+
+ 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
+
+ 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");
+
+ function Get_Policy (Prio : System.Any_Priority) return Character;
+ pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
+ -- Get priority specific dispatching policy
+
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads)
+
+ Null_Thread_Id : constant Thread_Id := 0;
+ -- Constant to indicate that the thread identifier has not yet been
+ -- initialized.
+
+ ------------------------------------
+ -- The thread local storage index --
+ ------------------------------------
+
+ TlsIndex : DWORD;
+ pragma Export (Ada, TlsIndex);
+ -- To ensure that this variable won't be local to this package, since
+ -- in some cases, inlining forces this variable to be global anyway.
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ 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
+
+ end Specific;
+
+ package body Specific is
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return TlsGetValue (TlsIndex) /= System.Null_Address;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ Succeeded : BOOL;
+ begin
+ Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
+ pragma Assert (Succeeded = Win32.TRUE);
+ end Set;
+
+ end 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) return Task_Id;
+ -- Allocate and Initialize a new ATCB for the current Thread
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_Id is separate;
+
+ ----------------------------------
+ -- Condition Variable Functions --
+ ----------------------------------
+
+ procedure Initialize_Cond (Cond : not null access Condition_Variable);
+ -- Initialize given condition variable Cond
+
+ procedure Finalize_Cond (Cond : not null access Condition_Variable);
+ -- Finalize given condition variable Cond
+
+ procedure Cond_Signal (Cond : not null access Condition_Variable);
+ -- Signal condition variable Cond
+
+ procedure Cond_Wait
+ (Cond : not null access Condition_Variable;
+ L : not null access RTS_Lock);
+ -- Wait on conditional variable Cond, using lock L
+
+ procedure Cond_Timed_Wait
+ (Cond : not null access Condition_Variable;
+ L : not null access RTS_Lock;
+ Rel_Time : Duration;
+ Timed_Out : out Boolean;
+ Status : out Integer);
+ -- Do timed wait on condition variable Cond using lock L. The duration
+ -- of the timed wait is given by Rel_Time. When the condition is
+ -- signalled, Timed_Out shows whether or not a time out occurred.
+ -- Status is only valid if Timed_Out is False, in which case it
+ -- shows whether Cond_Timed_Wait completed successfully.
+
+ ---------------------
+ -- Initialize_Cond --
+ ---------------------
+
+ procedure Initialize_Cond (Cond : not null access Condition_Variable) is
+ hEvent : HANDLE;
+ begin
+ hEvent := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
+ pragma Assert (hEvent /= 0);
+ Cond.all := Condition_Variable (hEvent);
+ end Initialize_Cond;
+
+ -------------------
+ -- Finalize_Cond --
+ -------------------
+
+ -- No such problem here, DosCloseEventSem has been derived.
+ -- What does such refer to in above comment???
+
+ procedure Finalize_Cond (Cond : not null access Condition_Variable) is
+ Result : BOOL;
+ begin
+ Result := CloseHandle (HANDLE (Cond.all));
+ pragma Assert (Result = Win32.TRUE);
+ end Finalize_Cond;
+
+ -----------------
+ -- Cond_Signal --
+ -----------------
+
+ procedure Cond_Signal (Cond : not null access Condition_Variable) is
+ Result : BOOL;
+ begin
+ Result := SetEvent (HANDLE (Cond.all));
+ pragma Assert (Result = Win32.TRUE);
+ end Cond_Signal;
+
+ ---------------
+ -- Cond_Wait --
+ ---------------
+
+ -- Pre-condition: Cond is posted
+ -- L is locked.
+
+ -- Post-condition: Cond is posted
+ -- L is locked.
+
+ procedure Cond_Wait
+ (Cond : not null access Condition_Variable;
+ L : not null access RTS_Lock)
+ is
+ Result : DWORD;
+ Result_Bool : BOOL;
+
+ begin
+ -- Must reset Cond BEFORE L is unlocked
+
+ Result_Bool := ResetEvent (HANDLE (Cond.all));
+ pragma Assert (Result_Bool = Win32.TRUE);
+ Unlock (L, Global_Lock => True);
+
+ -- No problem if we are interrupted here: if the condition is signaled,
+ -- WaitForSingleObject will simply not block
+
+ Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
+ pragma Assert (Result = 0);
+
+ Write_Lock (L, Global_Lock => True);
+ end Cond_Wait;
+
+ ---------------------
+ -- Cond_Timed_Wait --
+ ---------------------
+
+ -- Pre-condition: Cond is posted
+ -- L is locked.
+
+ -- Post-condition: Cond is posted
+ -- L is locked.
+
+ procedure Cond_Timed_Wait
+ (Cond : not null access Condition_Variable;
+ L : not null access RTS_Lock;
+ Rel_Time : Duration;
+ Timed_Out : out Boolean;
+ Status : out Integer)
+ is
+ Time_Out_Max : constant DWORD := 16#FFFF0000#;
+ -- NT 4 can't handle excessive timeout values (e.g. DWORD'Last - 1)
+
+ Time_Out : DWORD;
+ Result : BOOL;
+ Wait_Result : DWORD;
+
+ begin
+ -- Must reset Cond BEFORE L is unlocked
+
+ Result := ResetEvent (HANDLE (Cond.all));
+ pragma Assert (Result = Win32.TRUE);
+ Unlock (L, Global_Lock => True);
+
+ -- No problem if we are interrupted here: if the condition is signaled,
+ -- WaitForSingleObject will simply not block.
+
+ if Rel_Time <= 0.0 then
+ Timed_Out := True;
+ Wait_Result := 0;
+
+ else
+ Time_Out :=
+ (if Rel_Time >= Duration (Time_Out_Max) / 1000
+ then Time_Out_Max
+ else DWORD (Rel_Time * 1000));
+
+ Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
+
+ if Wait_Result = WAIT_TIMEOUT then
+ Timed_Out := True;
+ Wait_Result := 0;
+ else
+ Timed_Out := False;
+ end if;
+ end if;
+
+ Write_Lock (L, Global_Lock => True);
+
+ -- Ensure post-condition
+
+ if Timed_Out then
+ Result := SetEvent (HANDLE (Cond.all));
+ pragma Assert (Result = Win32.TRUE);
+ end if;
+
+ Status := Integer (Wait_Result);
+ end Cond_Timed_Wait;
+
+ ------------------
+ -- Stack_Guard --
+ ------------------
+
+ -- The underlying thread system sets a guard page at the bottom of a thread
+ -- stack, so nothing is needed.
+ -- ??? Check the comment above
+
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ pragma Unreferenced (T, On);
+ begin
+ null;
+ 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 is
+ Self_Id : constant Task_Id := To_Task_Id (TlsGetValue (TlsIndex));
+ begin
+ if Self_Id = null then
+ return Register_Foreign_Thread (GetCurrentThread);
+ else
+ return Self_Id;
+ end if;
+ end 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 the 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
+ begin
+ InitializeCriticalSection (L.Mutex'Access);
+ L.Owner_Priority := 0;
+ L.Priority := Prio;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock; Level : Lock_Level)
+ is
+ pragma Unreferenced (Level);
+ begin
+ InitializeCriticalSection (L);
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : not null access Lock) is
+ begin
+ DeleteCriticalSection (L.Mutex'Access);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : not null access RTS_Lock) is
+ begin
+ DeleteCriticalSection (L);
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock
+ (L : not null access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ L.Owner_Priority := Get_Priority (Self);
+
+ if L.Priority < L.Owner_Priority then
+ Ceiling_Violation := True;
+ return;
+ end if;
+
+ EnterCriticalSection (L.Mutex'Access);
+
+ Ceiling_Violation := False;
+ end Write_Lock;
+
+ procedure Write_Lock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ begin
+ if not Single_Lock or else Global_Lock then
+ EnterCriticalSection (L);
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_Id) is
+ begin
+ if not Single_Lock then
+ EnterCriticalSection (T.Common.LL.L'Access);
+ 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
+ begin
+ LeaveCriticalSection (L.Mutex'Access);
+ end Unlock;
+
+ procedure Unlock
+ (L : not null access RTS_Lock; Global_Lock : Boolean := False) is
+ begin
+ if not Single_Lock or else Global_Lock then
+ LeaveCriticalSection (L);
+ end if;
+ end Unlock;
+
+ procedure Unlock (T : Task_Id) is
+ begin
+ if not Single_Lock then
+ LeaveCriticalSection (T.Common.LL.L'Access);
+ 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);
+
+ begin
+ pragma Assert (Self_ID = Self);
+
+ if Single_Lock then
+ Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ else
+ Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ end if;
+
+ if Self_ID.Deferral_Level = 0
+ and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ then
+ Unlock (Self_ID);
+ raise Standard'Abort_Signal;
+ end if;
+ 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 : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ pragma Unreferenced (Reason);
+ Check_Time : Duration := Monotonic_Clock;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
+
+ Local_Timedout : Boolean;
+
+ begin
+ Timedout := True;
+ Yielded := False;
+
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ if Single_Lock then
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Rel_Time, Local_Timedout, Result);
+ else
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Rel_Time, Local_Timedout, Result);
+ end if;
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time;
+
+ if not Local_Timedout then
+
+ -- Somebody may have called Wakeup for us
+
+ Timedout := False;
+ exit;
+ end if;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Check_Time : Duration := Monotonic_Clock;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+
+ Timedout : Boolean;
+ Result : Integer;
+ pragma Unreferenced (Timedout, Result);
+
+ begin
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ Write_Lock (Self_ID);
+
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ if Single_Lock then
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Rel_Time, Timedout, Result);
+ else
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Rel_Time, Timedout, Result);
+ end if;
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ Yield;
+ end Timed_Delay;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+ begin
+ Cond_Signal (T.Common.LL.CV'Access);
+ end Wakeup;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ begin
+ -- Note: in a previous implementation if Do_Yield was False, then we
+ -- introduced a delay of 1 millisecond in an attempt to get closer to
+ -- annex D semantics, and in particular to make ACATS CXD8002 pass. But
+ -- this change introduced a huge performance regression evaluating the
+ -- Count attribute. So we decided to remove this processing.
+
+ -- Moreover, CXD8002 appears to pass on Windows (although we do not
+ -- guarantee full Annex D compliance on Windows in any case).
+
+ if Do_Yield then
+ SwitchToThread;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_Id;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Res : BOOL;
+ pragma Unreferenced (Loss_Of_Inheritance);
+
+ begin
+ Res :=
+ SetThreadPriority
+ (T.Common.LL.Thread,
+ Interfaces.C.int (Underlying_Priorities (Prio)));
+ pragma Assert (Res = Win32.TRUE);
+
+ -- Note: Annex D (RM D.2.3(5/2)) requires the task to be placed at the
+ -- head of its priority queue when decreasing its priority as a result
+ -- of a loss of inherited priority. This is not the case, but we
+ -- consider it an acceptable variation (RM 1.1.3(6)), given this is
+ -- the built-in behavior offered by the Windows operating system.
+
+ -- In older versions we attempted to better approximate the Annex D
+ -- required behavior, but this simulation was not entirely accurate,
+ -- and it seems better to live with the standard Windows semantics.
+
+ T.Common.Current_Priority := Prio;
+ 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 --
+ ----------------
+
+ -- There were two paths were we needed to call Enter_Task :
+ -- 1) from System.Task_Primitives.Operations.Initialize
+ -- 2) from System.Tasking.Stages.Task_Wrapper
+
+ -- The pseudo handle (LL.Thread) need not be closed when it is no
+ -- longer needed. Calling the CloseHandle function with this handle
+ -- has no effect.
+
+ procedure Enter_Task (Self_ID : Task_Id) is
+ procedure Get_Stack_Bounds (Base : Address; Limit : Address);
+ pragma Import (C, Get_Stack_Bounds, "__gnat_get_stack_bounds");
+ -- Get stack boundaries
+ begin
+ Specific.Set (Self_ID);
+
+ -- Properly initializes the FPU for x86 systems
+
+ System.Float_Control.Reset;
+
+ if Self_ID.Common.Task_Info /= null
+ and then
+ Self_ID.Common.Task_Info.CPU >= CPU_Number (Number_Of_Processors)
+ then
+ raise Invalid_CPU_Number;
+ end if;
+
+ Self_ID.Common.LL.Thread := GetCurrentThread;
+ Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
+
+ Get_Stack_Bounds
+ (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base'Address,
+ Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address);
+ 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 (GetCurrentThread);
+ end if;
+ end Register_Foreign_Thread;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
+ begin
+ -- Initialize thread ID to 0, this is needed to detect threads that
+ -- are not yet activated.
+
+ Self_ID.Common.LL.Thread := Null_Thread_Id;
+
+ Initialize_Cond (Self_ID.Common.LL.CV'Access);
+
+ if not Single_Lock then
+ Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
+ end if;
+
+ Succeeded := True;
+ 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
+ Initial_Stack_Size : constant := 1024;
+ -- We set the initial stack size to 1024. On Windows version prior to XP
+ -- there is no way to fix a task stack size. Only the initial stack size
+ -- can be set, the operating system will raise the task stack size if
+ -- needed.
+
+ function Is_Windows_XP return Integer;
+ pragma Import (C, Is_Windows_XP, "__gnat_is_windows_xp");
+ -- Returns 1 if running on Windows XP
+
+ hTask : HANDLE;
+ TaskId : aliased DWORD;
+ pTaskParameter : Win32.PVOID;
+ Result : DWORD;
+ Entry_Point : PTHREAD_START_ROUTINE;
+
+ use type System.Multiprocessors.CPU_Range;
+
+ begin
+ -- Check whether both Dispatching_Domain and CPU are specified for the
+ -- task, and the CPU value is not contained within the range of
+ -- processors for the domain.
+
+ if T.Common.Domain /= null
+ and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
+ and then
+ (T.Common.Base_CPU not in T.Common.Domain'Range
+ or else not T.Common.Domain (T.Common.Base_CPU))
+ then
+ Succeeded := False;
+ return;
+ end if;
+
+ pTaskParameter := To_Address (T);
+
+ Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
+
+ if Is_Windows_XP = 1 then
+ hTask := CreateThread
+ (null,
+ DWORD (Stack_Size),
+ Entry_Point,
+ pTaskParameter,
+ DWORD (Create_Suspended)
+ or DWORD (Stack_Size_Param_Is_A_Reservation),
+ TaskId'Unchecked_Access);
+ else
+ hTask := CreateThread
+ (null,
+ Initial_Stack_Size,
+ Entry_Point,
+ pTaskParameter,
+ DWORD (Create_Suspended),
+ TaskId'Unchecked_Access);
+ end if;
+
+ -- Step 1: Create the thread in blocked mode
+
+ if hTask = 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ -- Step 2: set its TCB
+
+ T.Common.LL.Thread := hTask;
+
+ -- Note: it would be useful to initialize Thread_Id right away to avoid
+ -- a race condition in gdb where Thread_ID may not have the right value
+ -- yet, but GetThreadId is a Vista specific API, not available under XP:
+ -- T.Common.LL.Thread_Id := GetThreadId (hTask); so instead we set the
+ -- field to 0 to avoid having a random value. Thread_Id is initialized
+ -- in Enter_Task anyway.
+
+ T.Common.LL.Thread_Id := 0;
+
+ -- Step 3: set its priority (child has inherited priority from parent)
+
+ Set_Priority (T, Priority);
+
+ if Time_Slice_Val = 0
+ or else Dispatching_Policy = 'F'
+ or else Get_Policy (Priority) = 'F'
+ then
+ -- Here we need Annex D semantics so we disable the NT priority
+ -- boost. A priority boost is temporarily given by the system to
+ -- a thread when it is taken out of a wait state.
+
+ SetThreadPriorityBoost (hTask, DisablePriorityBoost => Win32.TRUE);
+ end if;
+
+ -- Step 4: Handle pragma CPU and Task_Info
+
+ Set_Task_Affinity (T);
+
+ -- Step 5: Now, start it for good
+
+ Result := ResumeThread (hTask);
+ pragma Assert (Result = 1);
+
+ Succeeded := Result = 1;
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_Id) is
+ Succeeded : BOOL;
+ pragma Unreferenced (Succeeded);
+
+ begin
+ if not Single_Lock then
+ Finalize_Lock (T.Common.LL.L'Access);
+ end if;
+
+ Finalize_Cond (T.Common.LL.CV'Access);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ if T.Common.LL.Thread /= 0 then
+
+ -- This task has been activated. Close the thread handle. This
+ -- is needed to release system resources.
+
+ Succeeded := CloseHandle (T.Common.LL.Thread);
+ -- Note that we do not check for the returned value, this is
+ -- because the above call will fail for a foreign thread. But
+ -- we still need to call it to properly close Ada tasks created
+ -- with CreateThread() in Create_Task above.
+ end if;
+
+ ATCB_Allocation.Free_ATCB (T);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ Specific.Set (null);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
+ pragma Unreferenced (T);
+ begin
+ null;
+ end Abort_Task;
+
+ ----------------------
+ -- 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;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ Discard : BOOL;
+
+ begin
+ Environment_Task_Id := Environment_Task;
+ OS_Primitives.Initialize;
+ Interrupt_Management.Initialize;
+
+ if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
+ -- Here we need Annex D semantics, switch the current process to the
+ -- Realtime_Priority_Class.
+
+ Discard := OS_Interface.SetPriorityClass
+ (GetCurrentProcess, Realtime_Priority_Class);
+ end if;
+
+ TlsIndex := TlsAlloc;
+
+ -- Initialize the lock used to synchronize chain of all ATCBs
+
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ Environment_Task.Common.LL.Thread := GetCurrentThread;
+
+ -- 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);
+
+ -- pragma CPU and dispatching domains for the environment task
+
+ Set_Task_Affinity (Environment_Task);
+ end Initialize;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ function Internal_Clock return Duration;
+ pragma Import (Ada, Internal_Clock, "__gnat_monotonic_clock");
+ begin
+ return Internal_Clock;
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ Ticks_Per_Second : aliased LARGE_INTEGER;
+ begin
+ QueryPerformanceFrequency (Ticks_Per_Second'Access);
+ return Duration (1.0 / Ticks_Per_Second);
+ end RT_Resolution;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ begin
+ -- Initialize internal state. It is always initialized to False (ARM
+ -- D.10 par. 6).
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ InitializeCriticalSection (S.L'Access);
+
+ -- Initialize internal condition variable
+
+ S.CV := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
+ pragma Assert (S.CV /= 0);
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ Result : BOOL;
+
+ begin
+ -- Destroy internal mutex
+
+ DeleteCriticalSection (S.L'Access);
+
+ -- Destroy internal condition variable
+
+ Result := CloseHandle (S.CV);
+ pragma Assert (Result = Win32.TRUE);
+ 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
+ begin
+ SSL.Abort_Defer.all;
+
+ EnterCriticalSection (S.L'Access);
+
+ S.State := False;
+
+ LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ Result : BOOL;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ EnterCriticalSection (S.L'Access);
+
+ -- 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 ARM D.10 par. 9. Otherwise, it just leaves
+ -- the state to True.
+
+ if S.Waiting then
+ S.Waiting := False;
+ S.State := False;
+
+ Result := SetEvent (S.CV);
+ pragma Assert (Result = Win32.TRUE);
+
+ else
+ S.State := True;
+ end if;
+
+ LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ Result : DWORD;
+ Result_Bool : BOOL;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ EnterCriticalSection (S.L'Access);
+
+ if S.Waiting then
+
+ -- Program_Error must be raised upon calling Suspend_Until_True
+ -- if another task is already waiting on that suspension object
+ -- (ARM D.10 par. 10).
+
+ LeaveCriticalSection (S.L'Access);
+
+ 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;
+
+ LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
+
+ else
+ S.Waiting := True;
+
+ -- Must reset CV BEFORE L is unlocked
+
+ Result_Bool := ResetEvent (S.CV);
+ pragma Assert (Result_Bool = Win32.TRUE);
+
+ LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
+
+ Result := WaitForSingleObject (S.CV, Wait_Infinite);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end Suspend_Until_True;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions, currently this only works for solaris (native)
+
+ 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;
+
+ ------------------
+ -- 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 SuspendThread (T.Common.LL.Thread) = NO_ERROR;
+ 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 ResumeThread (T.Common.LL.Thread) = NO_ERROR;
+ 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;
+
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ Result : DWORD;
+
+ use type System.Multiprocessors.CPU_Range;
+
+ begin
+ -- Do nothing if the underlying thread has not yet been created. If the
+ -- thread has not yet been created then the proper affinity will be set
+ -- during its creation.
+
+ if T.Common.LL.Thread = Null_Thread_Id then
+ null;
+
+ -- pragma CPU
+
+ elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
+
+ -- The CPU numbering in pragma CPU starts at 1 while the subprogram
+ -- to set the affinity starts at 0, therefore we must substract 1.
+
+ Result :=
+ SetThreadIdealProcessor
+ (T.Common.LL.Thread, ProcessorId (T.Common.Base_CPU) - 1);
+ pragma Assert (Result = 1);
+
+ -- Task_Info
+
+ elsif T.Common.Task_Info /= null then
+ if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then
+ Result :=
+ SetThreadIdealProcessor
+ (T.Common.LL.Thread, T.Common.Task_Info.CPU);
+ pragma Assert (Result = 1);
+ end if;
+
+ -- Dispatching domains
+
+ elsif T.Common.Domain /= null
+ and then (T.Common.Domain /= ST.System_Domain
+ or else
+ T.Common.Domain.all /=
+ (Multiprocessors.CPU'First ..
+ Multiprocessors.Number_Of_CPUs => True))
+ then
+ declare
+ CPU_Set : DWORD := 0;
+
+ begin
+ for Proc in T.Common.Domain'Range loop
+ if T.Common.Domain (Proc) then
+
+ -- The thread affinity mask is a bit vector in which each
+ -- bit represents a logical processor.
+
+ CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1);
+ end if;
+ end loop;
+
+ Result := SetThreadAffinityMask (T.Common.LL.Thread, CPU_Set);
+ pragma Assert (Result = 1);
+ end;
+ end if;
+ end Set_Task_Affinity;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . 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 --
+-- <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 a POSIX-like 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
+
+ Locking_Policy : 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.
+
+ Unblocked_Signal_Mask : aliased sigset_t;
+ -- The set of signals that should unblocked in all tasks
+
+ -- 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 : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Dispatching_Policy : 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
+
+ ----------------------------------
+ -- 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) return Task_Id;
+ -- Allocate and Initialize a new ATCB for the current Thread
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) 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
+ 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;
+
+ -- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . 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 --
+-- <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 a Solaris (native) version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+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 Interfaces.C;
+
+with System.Multiprocessors;
+with System.Tasking.Debug;
+with System.Interrupt_Management;
+with System.OS_Constants;
+with System.OS_Primitives;
+with System.Task_Info;
+
+pragma Warnings (Off);
+with System.OS_Lib;
+pragma Warnings (On);
+
+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 following are logically constants, but need to be initialized
+ -- at run time.
+
+ Environment_Task_Id : Task_Id;
+ -- A variable to hold Task_Id for the environment task.
+ -- If we use this variable to get the Task_Id, we need the following
+ -- ATCB_Key only for non-Ada threads.
+
+ Unblocked_Signal_Mask : aliased sigset_t;
+ -- The set of signals that should unblocked in all tasks
+
+ ATCB_Key : aliased thread_key_t;
+ -- Key used to find the Ada Task_Id associated with a thread,
+ -- at least for C threads unknown to the Ada run-time system.
+
+ 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
+
+ Next_Serial_Number : Task_Serial_Number := 100;
+ -- We start at 100, to reserve some special values for
+ -- using in error checking.
+ -- The following are internal configuration constants needed.
+
+ Abort_Handler_Installed : Boolean := False;
+ -- True if a handler for the abort signal is installed
+
+ Null_Thread_Id : constant Thread_Id := Thread_Id'Last;
+ -- Constant to indicate that the thread identifier has not yet been
+ -- initialized.
+
+ ----------------------
+ -- Priority Support --
+ ----------------------
+
+ Priority_Ceiling_Emulation : constant Boolean := True;
+ -- controls whether we emulate priority ceiling locking
+
+ -- To get a scheduling close to annex D requirements, we use the real-time
+ -- class provided for LWPs and map each task/thread to a specific and
+ -- unique LWP (there is 1 thread per LWP, and 1 LWP per thread).
+
+ -- The real time class can only be set when the process has root
+ -- privileges, so in the other cases, we use the normal thread scheduling
+ -- and priority handling.
+
+ Using_Real_Time_Class : Boolean := False;
+ -- indicates whether the real time class is being used (i.e. the process
+ -- has root privileges).
+
+ Prio_Param : aliased struct_pcparms;
+ -- Hold priority info (Real_Time) initialized during the package
+ -- elaboration.
+
+ -----------------------------------
+ -- External Configuration Values --
+ -----------------------------------
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+
+ Dispatching_Policy : 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)
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function sysconf (name : System.OS_Interface.int) return processorid_t;
+ pragma Import (C, sysconf, "sysconf");
+
+ SC_NPROCESSORS_CONF : constant System.OS_Interface.int := 14;
+
+ function Num_Procs
+ (name : System.OS_Interface.int := SC_NPROCESSORS_CONF)
+ return processorid_t renames sysconf;
+
+ procedure Abort_Handler
+ (Sig : Signal;
+ Code : not null access siginfo_t;
+ Context : not null access ucontext_t);
+ -- Target-dependent binding of inter-thread Abort signal to
+ -- the raising of the Abort_Signal exception.
+ -- See also comments in 7staprop.adb
+
+ ------------
+ -- Checks --
+ ------------
+
+ function Check_Initialize_Lock
+ (L : Lock_Ptr;
+ Level : Lock_Level) return Boolean;
+ pragma Inline (Check_Initialize_Lock);
+
+ function Check_Lock (L : Lock_Ptr) return Boolean;
+ pragma Inline (Check_Lock);
+
+ function Record_Lock (L : Lock_Ptr) return Boolean;
+ pragma Inline (Record_Lock);
+
+ function Check_Sleep (Reason : Task_States) return Boolean;
+ pragma Inline (Check_Sleep);
+
+ function Record_Wakeup
+ (L : Lock_Ptr;
+ Reason : Task_States) return Boolean;
+ pragma Inline (Record_Wakeup);
+
+ function Check_Wakeup
+ (T : Task_Id;
+ Reason : Task_States) return Boolean;
+ pragma Inline (Check_Wakeup);
+
+ function Check_Unlock (L : Lock_Ptr) return Boolean;
+ pragma Inline (Check_Unlock);
+
+ function Check_Finalize_Lock (L : Lock_Ptr) return Boolean;
+ pragma Inline (Check_Finalize_Lock);
+
+ --------------------
+ -- 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) return Task_Id;
+ -- Allocate and Initialize a new ATCB for the current Thread
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_Id is separate;
+
+ ------------
+ -- Checks --
+ ------------
+
+ Check_Count : Integer := 0;
+ Lock_Count : Integer := 0;
+ Unlock_Count : Integer := 0;
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ procedure Abort_Handler
+ (Sig : Signal;
+ Code : not null access siginfo_t;
+ Context : not null access ucontext_t)
+ is
+ pragma Unreferenced (Sig);
+ pragma Unreferenced (Code);
+ pragma Unreferenced (Context);
+
+ Self_ID : 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 Self_ID.Deferral_Level = 0
+ and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ and then not Self_ID.Aborting
+ then
+ Self_ID.Aborting := True;
+
+ -- Make sure signals used for RTS internal purpose are unmasked
+
+ Result :=
+ thr_sigsetmask
+ (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access,
+ Old_Set'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+ end if;
+ end Abort_Handler;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ -- The underlying thread system sets a guard page at the
+ -- bottom of a thread stack, so nothing is needed.
+
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ pragma Unreferenced (T);
+ pragma Unreferenced (On);
+ begin
+ null;
+ 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;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : ST.Task_Id) is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ procedure Configure_Processors;
+ -- Processors configuration
+ -- The user can specify a processor which the program should run
+ -- on to emulate a single-processor system. This can be easily
+ -- done by setting environment variable GNAT_PROCESSOR to one of
+ -- the following :
+ --
+ -- -2 : use the default configuration (run the program on all
+ -- available processors) - this is the same as having
+ -- GNAT_PROCESSOR unset
+ -- -1 : let the RTS choose one processor and run the program on
+ -- that processor
+ -- 0 .. Last_Proc : run the program on the specified processor
+ --
+ -- Last_Proc is equal to the value of the system variable
+ -- _SC_NPROCESSORS_CONF, minus one.
+
+ procedure Configure_Processors is
+ Proc_Acc : constant System.OS_Lib.String_Access :=
+ System.OS_Lib.Getenv ("GNAT_PROCESSOR");
+ Proc : aliased processorid_t; -- User processor #
+ Last_Proc : processorid_t; -- Last processor #
+
+ begin
+ if Proc_Acc.all'Length /= 0 then
+
+ -- Environment variable is defined
+
+ Last_Proc := Num_Procs - 1;
+
+ if Last_Proc /= -1 then
+ Proc := processorid_t'Value (Proc_Acc.all);
+
+ if Proc <= -2 or else Proc > Last_Proc then
+
+ -- Use the default configuration
+
+ null;
+
+ elsif Proc = -1 then
+
+ -- Choose a processor
+
+ Result := 0;
+ while Proc < Last_Proc loop
+ Proc := Proc + 1;
+ Result := p_online (Proc, PR_STATUS);
+ exit when Result = PR_ONLINE;
+ end loop;
+
+ pragma Assert (Result = PR_ONLINE);
+ Result := processor_bind (P_PID, P_MYID, Proc, null);
+ pragma Assert (Result = 0);
+
+ else
+ -- Use user processor
+
+ Result := processor_bind (P_PID, P_MYID, Proc, null);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end if;
+
+ exception
+ when Constraint_Error =>
+
+ -- Illegal environment variable GNAT_PROCESSOR - ignored
+
+ null;
+ end Configure_Processors;
+
+ 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)
+
+ -- Start of processing for Initialize
+
+ 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;
+
+ if Dispatching_Policy = 'F' then
+ declare
+ Result : Interfaces.C.long;
+ Class_Info : aliased struct_pcinfo;
+ Secs, Nsecs : Interfaces.C.long;
+
+ begin
+ -- If a pragma Time_Slice is specified, takes the value in account
+
+ if Time_Slice_Val > 0 then
+
+ -- Convert Time_Slice_Val (microseconds) to seconds/nanosecs
+
+ Secs := Interfaces.C.long (Time_Slice_Val / 1_000_000);
+ Nsecs :=
+ Interfaces.C.long ((Time_Slice_Val rem 1_000_000) * 1_000);
+
+ -- Otherwise, default to no time slicing (i.e run until blocked)
+
+ else
+ Secs := RT_TQINF;
+ Nsecs := RT_TQINF;
+ end if;
+
+ -- Get the real time class id
+
+ Class_Info.pc_clname (1) := 'R';
+ Class_Info.pc_clname (2) := 'T';
+ Class_Info.pc_clname (3) := ASCII.NUL;
+
+ Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID,
+ Class_Info'Address);
+
+ -- Request the real time class
+
+ Prio_Param.pc_cid := Class_Info.pc_cid;
+ Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri);
+ Prio_Param.rt_tqsecs := Secs;
+ Prio_Param.rt_tqnsecs := Nsecs;
+
+ Result :=
+ priocntl
+ (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS, Prio_Param'Address);
+
+ Using_Real_Time_Class := Result /= -1;
+ end;
+ end if;
+
+ Specific.Initialize (Environment_Task);
+
+ -- The following is done in Enter_Task, but this is too late for the
+ -- Environment Task, since we need to call Self in Check_Locks when
+ -- the run time is compiled with assertions on.
+
+ Specific.Set (Environment_Task);
+
+ -- Initialize the lock used to synchronize chain of all ATCBs
+
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ -- 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);
+
+ Configure_Processors;
+
+ if State
+ (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
+ then
+ -- Set sa_flags to SA_NODEFER so that during the handler execution
+ -- we do not change the Signal_Mask to be masked for the Abort_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.
+ -- In that case, this field should be changed back to 0. ???
+
+ act.sa_flags := 16;
+
+ 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;
+
+ ---------------------
+ -- 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
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Initialize_Lock (Lock_Ptr (L), PO_Level));
+
+ if Priority_Ceiling_Emulation then
+ L.Ceiling := Prio;
+ end if;
+
+ Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock;
+ Level : Lock_Level)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert
+ (Check_Initialize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level));
+ Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : not null access Lock) is
+ Result : Interfaces.C.int;
+ begin
+ pragma Assert (Check_Finalize_Lock (Lock_Ptr (L)));
+ Result := mutex_destroy (L.L'Access);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : not null access RTS_Lock) is
+ Result : Interfaces.C.int;
+ begin
+ pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ Result := mutex_destroy (L.L'Access);
+ 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
+ pragma Assert (Check_Lock (Lock_Ptr (L)));
+
+ if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
+ declare
+ Self_Id : constant Task_Id := Self;
+ Saved_Priority : System.Any_Priority;
+
+ begin
+ if Self_Id.Common.LL.Active_Priority > L.Ceiling then
+ Ceiling_Violation := True;
+ return;
+ end if;
+
+ Saved_Priority := Self_Id.Common.LL.Active_Priority;
+
+ if Self_Id.Common.LL.Active_Priority < L.Ceiling then
+ Set_Priority (Self_Id, L.Ceiling);
+ end if;
+
+ Result := mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ Ceiling_Violation := False;
+
+ L.Saved_Priority := Saved_Priority;
+ end;
+
+ else
+ Result := mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ Ceiling_Violation := False;
+ end if;
+
+ pragma Assert (Record_Lock (Lock_Ptr (L)));
+ 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
+ pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ Result := mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock then
+ pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
+ Result := mutex_lock (T.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
+ pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
+ 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
+ pragma Assert (Check_Unlock (Lock_Ptr (L)));
+
+ if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
+ declare
+ Self_Id : constant Task_Id := Self;
+
+ begin
+ Result := mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+
+ if Self_Id.Common.LL.Active_Priority > L.Saved_Priority then
+ Set_Priority (Self_Id, L.Saved_Priority);
+ end if;
+ end;
+ else
+ Result := mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ 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
+ pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ Result := mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ procedure Unlock (T : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock then
+ pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access)));
+ Result := mutex_unlock (T.Common.LL.L.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;
+
+ -- For the time delay implementation, we need to make sure we
+ -- achieve following criteria:
+
+ -- 1) We have to delay at least for the amount requested.
+ -- 2) We have to give up CPU even though the actual delay does not
+ -- result in blocking.
+ -- 3) Except for restricted run-time systems that do not support
+ -- ATC or task abort, the delay must be interrupted by the
+ -- abort_task operation.
+ -- 4) The implementation has to be efficient so that the delay overhead
+ -- is relatively cheap.
+ -- (1)-(3) are Ada requirements. Even though (2) is an Annex-D
+ -- requirement we still want to provide the effect in all cases.
+ -- The reason is that users may want to use short delays to implement
+ -- their own scheduling effect in the absence of language provided
+ -- scheduling policies.
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+ begin
+ Result := clock_gettime (OSC.CLOCK_RT_Ada, 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;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ begin
+ if Do_Yield then
+ System.OS_Interface.thr_yield;
+ end if;
+ end Yield;
+
+ -----------
+ -- Self ---
+ -----------
+
+ function Self return Task_Id renames Specific.Self;
+
+ ------------------
+ -- 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;
+ pragma Unreferenced (Result);
+
+ Param : aliased struct_pcparms;
+
+ use Task_Info;
+
+ begin
+ T.Common.Current_Priority := Prio;
+
+ if Priority_Ceiling_Emulation then
+ T.Common.LL.Active_Priority := Prio;
+ end if;
+
+ if Using_Real_Time_Class then
+ Param.pc_cid := Prio_Param.pc_cid;
+ Param.rt_pri := pri_t (Prio);
+ Param.rt_tqsecs := Prio_Param.rt_tqsecs;
+ Param.rt_tqnsecs := Prio_Param.rt_tqnsecs;
+
+ Result := Interfaces.C.int (
+ priocntl (PC_VERSION, P_LWPID, T.Common.LL.LWP, PC_SETPARMS,
+ Param'Address));
+
+ else
+ if T.Common.Task_Info /= null
+ and then not T.Common.Task_Info.Bound_To_LWP
+ then
+ -- The task is not bound to a LWP, so use thr_setprio
+
+ Result :=
+ thr_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
+
+ else
+ -- The task is bound to a LWP, use priocntl
+ -- ??? TBD
+
+ null;
+ end if;
+ end if;
+ 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 := thr_self;
+ Self_ID.Common.LL.LWP := lwp_self;
+
+ Set_Task_Affinity (Self_ID);
+ Specific.Set (Self_ID);
+
+ -- We need the above code even if we do direct fetch of Task_Id in Self
+ -- for the main task on Sun, x86 Solaris and for gcc 2.7.2.
+ 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 (thr_self);
+ end if;
+ end Register_Foreign_Thread;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
+ Result : Interfaces.C.int := 0;
+
+ 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);
+
+ Self_ID.Common.LL.Thread := Null_Thread_Id;
+
+ if not Single_Lock then
+ Result :=
+ mutex_init
+ (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address);
+ Self_ID.Common.LL.L.Level :=
+ Private_Task_Serial_Number (Self_ID.Serial_Number);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+ end if;
+
+ if Result = 0 then
+ Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+ end if;
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ if not Single_Lock then
+ Result := mutex_destroy (Self_ID.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Succeeded := False;
+ end if;
+ 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
+ pragma Unreferenced (Priority);
+
+ Result : Interfaces.C.int;
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Opts : Interfaces.C.int := THR_DETACHED;
+
+ Page_Size : constant System.Parameters.Size_Type := 4096;
+ -- This constant is for reserving extra space at the
+ -- end of the stack, which can be used by the stack
+ -- checking as guard page. The idea is that we need
+ -- to have at least Stack_Size bytes available for
+ -- actual use.
+
+ use System.Task_Info;
+ use type System.Multiprocessors.CPU_Range;
+
+ begin
+ -- Check whether both Dispatching_Domain and CPU are specified for the
+ -- task, and the CPU value is not contained within the range of
+ -- processors for the domain.
+
+ if T.Common.Domain /= null
+ and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
+ and then
+ (T.Common.Base_CPU not in T.Common.Domain'Range
+ or else not T.Common.Domain (T.Common.Base_CPU))
+ then
+ Succeeded := False;
+ return;
+ end if;
+
+ Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Page_Size);
+
+ -- 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.
+
+ if T.Common.Task_Info /= null then
+ if T.Common.Task_Info.New_LWP then
+ Opts := Opts + THR_NEW_LWP;
+ end if;
+
+ if T.Common.Task_Info.Bound_To_LWP then
+ Opts := Opts + THR_BOUND;
+ end if;
+
+ else
+ Opts := THR_DETACHED + THR_BOUND;
+ end if;
+
+ -- 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 :=
+ thr_create
+ (System.Null_Address,
+ Adjusted_Stack_Size,
+ Thread_Body_Access (Wrapper),
+ To_Address (T),
+ Opts,
+ T.Common.LL.Thread'Unrestricted_Access);
+
+ Succeeded := Result = 0;
+ pragma Assert
+ (Result = 0
+ or else Result = ENOMEM
+ or else Result = EAGAIN);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_Id) is
+ Result : Interfaces.C.int;
+
+ begin
+ T.Common.LL.Thread := Null_Thread_Id;
+
+ if not Single_Lock then
+ Result := mutex_destroy (T.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := 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 --
+ ---------------
+
+ -- This procedure must be called with abort deferred. It can no longer
+ -- call Self or access the current task's ATCB, since the ATCB has been
+ -- deallocated.
+
+ procedure Exit_Task is
+ begin
+ 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
+ pragma Assert (T /= Self);
+ Result :=
+ thr_kill
+ (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ pragma Assert (Result = 0);
+ end if;
+ end Abort_Task;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep
+ (Self_ID : Task_Id;
+ Reason : Task_States)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Sleep (Reason));
+
+ if Single_Lock then
+ Result :=
+ cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access);
+ else
+ Result :=
+ cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
+ end if;
+
+ pragma Assert
+ (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
+ pragma Assert (Result = 0 or else Result = EINTR);
+ end Sleep;
+
+ -- Note that we are relying heavily here on GNAT representing
+ -- Calendar.Time, System.Real_Time.Time, Duration,
+ -- System.Real_Time.Time_Span in the same way, i.e., as a 64-bit count of
+ -- nanoseconds.
+
+ -- This allows us to always pass the timeout value as a Duration
+
+ -- ???
+ -- We are taking liberties here with the semantics of the delays. That is,
+ -- we make no distinction between delays on the Calendar clock and delays
+ -- on the Real_Time clock. That is technically incorrect, if the Calendar
+ -- clock happens to be reset or adjusted. To solve this defect will require
+ -- modification to the compiler interface, so that it can pass through more
+ -- information, to tell us here which clock to use.
+
+ -- cond_timedwait will return if any of the following happens:
+ -- 1) some other task did cond_signal on this condition variable
+ -- In this case, the return value is 0
+ -- 2) the call just returned, for no good reason
+ -- This is called a "spurious wakeup".
+ -- In this case, the return value may also be 0.
+ -- 3) the time delay expires
+ -- In this case, the return value is ETIME
+ -- 4) this task received a signal, which was handled by some
+ -- handler procedure, and now the thread is resuming execution
+ -- UNIX calls this an "interrupted" system call.
+ -- In this case, the return value is EINTR
+
+ -- If the cond_timedwait returns 0 or EINTR, it is still possible that the
+ -- time has actually expired, and by chance a signal or cond_signal
+ -- occurred at around the same time.
+
+ -- We have also observed that on some OS's the value ETIME will be
+ -- returned, but the clock will show that the full delay has not yet
+ -- expired.
+
+ -- For these reasons, we need to check the clock after return from
+ -- cond_timedwait. If the time has expired, we will set Timedout = True.
+
+ -- This check might be omitted for systems on which the cond_timedwait()
+ -- never returns early or wakes up spuriously.
+
+ -- Annex D requires that completion of a delay cause the task to go to the
+ -- end of its priority queue, regardless of whether the task actually was
+ -- suspended by the delay. Since cond_timedwait does not do this on
+ -- Solaris, we add a call to thr_yield at the end. We might do this at the
+ -- beginning, instead, but then the round-robin effect would not be the
+ -- same; the delayed task would be ahead of other tasks of the same
+ -- priority that awoke while it was sleeping.
+
+ -- For Timed_Sleep, we are expecting possible cond_signals to indicate
+ -- other events (e.g., completion of a RV or completion of the abortable
+ -- part of an async. select), we want to always return if interrupted. The
+ -- caller will be responsible for checking the task state to see whether
+ -- the wakeup was spurious, and to go back to sleep again in that case. We
+ -- don't need to check for pending abort or priority change on the way in
+ -- our out; that is the caller's responsibility.
+
+ -- For Timed_Delay, we are not expecting any cond_signals or other
+ -- interruptions, except for priority changes and aborts. Therefore, we
+ -- don't want to return unless the delay has actually expired, or the call
+ -- has been aborted. In this case, since we want to implement the entire
+ -- delay statement semantics, we do need to check for pending abort and
+ -- priority changes. We can quietly handle priority changes inside the
+ -- procedure, since there is no entry-queue reordering involved.
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ procedure Timed_Sleep
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Sleep (Reason));
+ Timedout := True;
+ Yielded := False;
+
+ Abs_Time :=
+ (if Mode = Relative
+ then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ if Single_Lock then
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock.L'Access, Request'Access);
+ else
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L.L'Access, Request'Access);
+ end if;
+
+ Yielded := True;
+
+ 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 = ETIME);
+ end loop;
+ end if;
+
+ pragma Assert
+ (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+ Yielded : Boolean := False;
+
+ begin
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ Write_Lock (Self_ID);
+
+ Abs_Time :=
+ (if Mode = Relative
+ then Time + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ pragma Assert (Check_Sleep (Delay_Sleep));
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ if Single_Lock then
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock.L'Access,
+ Request'Access);
+ else
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L.L'Access,
+ Request'Access);
+ end if;
+
+ Yielded := True;
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ pragma Assert
+ (Result = 0 or else
+ Result = ETIME or else
+ Result = EINTR);
+ end loop;
+
+ pragma Assert
+ (Record_Wakeup
+ (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep));
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ if not Yielded then
+ thr_yield;
+ end if;
+ end Timed_Delay;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup
+ (T : Task_Id;
+ Reason : Task_States)
+ is
+ Result : Interfaces.C.int;
+ begin
+ pragma Assert (Check_Wakeup (T, Reason));
+ Result := cond_signal (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ end Wakeup;
+
+ ---------------------------
+ -- Check_Initialize_Lock --
+ ---------------------------
+
+ -- The following code is intended to check some of the invariant assertions
+ -- related to lock usage, on which we depend.
+
+ function Check_Initialize_Lock
+ (L : Lock_Ptr;
+ Level : Lock_Level) return Boolean
+ is
+ Self_ID : constant Task_Id := Self;
+
+ begin
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level = 0 then
+ return False;
+ end if;
+
+ -- Check that the lock is not yet initialized
+
+ if L.Level /= 0 then
+ return False;
+ end if;
+
+ L.Level := Lock_Level'Pos (Level) + 1;
+ return True;
+ end Check_Initialize_Lock;
+
+ ----------------
+ -- Check_Lock --
+ ----------------
+
+ function Check_Lock (L : Lock_Ptr) return Boolean is
+ Self_ID : constant Task_Id := Self;
+ P : Lock_Ptr;
+
+ begin
+ -- Check that the argument is not null
+
+ if L = null then
+ return False;
+ end if;
+
+ -- Check that L is not frozen
+
+ if L.Frozen then
+ return False;
+ end if;
+
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level = 0 then
+ return False;
+ end if;
+
+ -- Check that caller is not holding this lock already
+
+ if L.Owner = To_Owner_ID (To_Address (Self_ID)) then
+ return False;
+ end if;
+
+ if Single_Lock then
+ return True;
+ end if;
+
+ -- Check that TCB lock order rules are satisfied
+
+ P := Self_ID.Common.LL.Locks;
+ if P /= null then
+ if P.Level >= L.Level
+ and then (P.Level > 2 or else L.Level > 2)
+ then
+ return False;
+ end if;
+ end if;
+
+ return True;
+ end Check_Lock;
+
+ -----------------
+ -- Record_Lock --
+ -----------------
+
+ function Record_Lock (L : Lock_Ptr) return Boolean is
+ Self_ID : constant Task_Id := Self;
+ P : Lock_Ptr;
+
+ begin
+ Lock_Count := Lock_Count + 1;
+
+ -- There should be no owner for this lock at this point
+
+ if L.Owner /= null then
+ return False;
+ end if;
+
+ -- Record new owner
+
+ L.Owner := To_Owner_ID (To_Address (Self_ID));
+
+ if Single_Lock then
+ return True;
+ end if;
+
+ -- Check that TCB lock order rules are satisfied
+
+ P := Self_ID.Common.LL.Locks;
+
+ if P /= null then
+ L.Next := P;
+ end if;
+
+ Self_ID.Common.LL.Locking := null;
+ Self_ID.Common.LL.Locks := L;
+ return True;
+ end Record_Lock;
+
+ -----------------
+ -- Check_Sleep --
+ -----------------
+
+ function Check_Sleep (Reason : Task_States) return Boolean is
+ pragma Unreferenced (Reason);
+
+ Self_ID : constant Task_Id := Self;
+ P : Lock_Ptr;
+
+ begin
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level = 0 then
+ return False;
+ end if;
+
+ if Single_Lock then
+ return True;
+ end if;
+
+ -- Check that caller is holding own lock, on top of list
+
+ if Self_ID.Common.LL.Locks /=
+ To_Lock_Ptr (Self_ID.Common.LL.L'Access)
+ then
+ return False;
+ end if;
+
+ -- Check that TCB lock order rules are satisfied
+
+ if Self_ID.Common.LL.Locks.Next /= null then
+ return False;
+ end if;
+
+ Self_ID.Common.LL.L.Owner := null;
+ P := Self_ID.Common.LL.Locks;
+ Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
+ P.Next := null;
+ return True;
+ end Check_Sleep;
+
+ -------------------
+ -- Record_Wakeup --
+ -------------------
+
+ function Record_Wakeup
+ (L : Lock_Ptr;
+ Reason : Task_States) return Boolean
+ is
+ pragma Unreferenced (Reason);
+
+ Self_ID : constant Task_Id := Self;
+ P : Lock_Ptr;
+
+ begin
+ -- Record new owner
+
+ L.Owner := To_Owner_ID (To_Address (Self_ID));
+
+ if Single_Lock then
+ return True;
+ end if;
+
+ -- Check that TCB lock order rules are satisfied
+
+ P := Self_ID.Common.LL.Locks;
+
+ if P /= null then
+ L.Next := P;
+ end if;
+
+ Self_ID.Common.LL.Locking := null;
+ Self_ID.Common.LL.Locks := L;
+ return True;
+ end Record_Wakeup;
+
+ ------------------
+ -- Check_Wakeup --
+ ------------------
+
+ function Check_Wakeup
+ (T : Task_Id;
+ Reason : Task_States) return Boolean
+ is
+ Self_ID : constant Task_Id := Self;
+
+ begin
+ -- Is caller holding T's lock?
+
+ if T.Common.LL.L.Owner /= To_Owner_ID (To_Address (Self_ID)) then
+ return False;
+ end if;
+
+ -- Are reasons for wakeup and sleep consistent?
+
+ if T.Common.State /= Reason then
+ return False;
+ end if;
+
+ return True;
+ end Check_Wakeup;
+
+ ------------------
+ -- Check_Unlock --
+ ------------------
+
+ function Check_Unlock (L : Lock_Ptr) return Boolean is
+ Self_ID : constant Task_Id := Self;
+ P : Lock_Ptr;
+
+ begin
+ Unlock_Count := Unlock_Count + 1;
+
+ if L = null then
+ return False;
+ end if;
+
+ if L.Buddy /= null then
+ return False;
+ end if;
+
+ -- Magic constant 4???
+
+ if L.Level = 4 then
+ Check_Count := Unlock_Count;
+ end if;
+
+ -- Magic constant 1000???
+
+ if Unlock_Count - Check_Count > 1000 then
+ Check_Count := Unlock_Count;
+ end if;
+
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level = 0 then
+ return False;
+ end if;
+
+ -- Check that caller is holding this lock, on top of list
+
+ if Self_ID.Common.LL.Locks /= L then
+ return False;
+ end if;
+
+ -- Record there is no owner now
+
+ L.Owner := null;
+ P := Self_ID.Common.LL.Locks;
+ Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
+ P.Next := null;
+ return True;
+ end Check_Unlock;
+
+ --------------------
+ -- Check_Finalize --
+ --------------------
+
+ function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is
+ Self_ID : constant Task_Id := Self;
+
+ begin
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level = 0 then
+ return False;
+ end if;
+
+ -- Check that no one is holding this lock
+
+ if L.Owner /= null then
+ return False;
+ end if;
+
+ L.Frozen := True;
+ return True;
+ end Check_Finalize_Lock;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ -- Initialize internal state (always to zero (RM D.10(6)))
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ Result := mutex_init (S.L'Access, USYNC_THREAD, System.Null_Address);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+
+ -- Initialize internal condition variable
+
+ Result := cond_init (S.CV'Access, USYNC_THREAD, 0);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+ end if;
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ -- Destroy internal mutex
+
+ Result := mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- Destroy internal condition variable
+
+ Result := 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 := mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ S.State := False;
+
+ Result := 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 := 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 ARM D.10 par. 9. Otherwise, it just leaves
+ -- the state to True.
+
+ if S.Waiting then
+ S.Waiting := False;
+ S.State := False;
+
+ Result := cond_signal (S.CV'Access);
+ pragma Assert (Result = 0);
+
+ else
+ S.State := True;
+ end if;
+
+ Result := 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 := 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 := 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 := 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 := mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end if;
+ end Suspend_Until_True;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ function Check_Exit (Self_ID : Task_Id) return Boolean is
+ begin
+ -- Check that caller is just holding Global_Task_Lock and no other locks
+
+ if Self_ID.Common.LL.Locks = null then
+ return False;
+ end if;
+
+ -- 2 = Global_Task_Level
+
+ if Self_ID.Common.LL.Locks.Level /= 2 then
+ return False;
+ end if;
+
+ if Self_ID.Common.LL.Locks.Next /= null then
+ return False;
+ end if;
+
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level = 0 then
+ return False;
+ end if;
+
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : Task_Id) return Boolean is
+ begin
+ return Self_ID.Common.LL.Locks = null;
+ 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 thr_suspend (T.Common.LL.Thread) = 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 thr_continue (T.Common.LL.Thread) = 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;
+
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ Result : Interfaces.C.int;
+ Proc : processorid_t; -- User processor #
+ Last_Proc : processorid_t; -- Last processor #
+
+ use System.Task_Info;
+ use type System.Multiprocessors.CPU_Range;
+
+ begin
+ -- Do nothing if the underlying thread has not yet been created. If the
+ -- thread has not yet been created then the proper affinity will be set
+ -- during its creation.
+
+ if T.Common.LL.Thread = Null_Thread_Id then
+ null;
+
+ -- pragma CPU
+
+ elsif T.Common.Base_CPU /=
+ System.Multiprocessors.Not_A_Specific_CPU
+ then
+ -- The CPU numbering in pragma CPU starts at 1 while the subprogram
+ -- to set the affinity starts at 0, therefore we must substract 1.
+
+ Result :=
+ processor_bind
+ (P_LWPID, id_t (T.Common.LL.LWP),
+ processorid_t (T.Common.Base_CPU) - 1, null);
+ pragma Assert (Result = 0);
+
+ -- Task_Info
+
+ elsif T.Common.Task_Info /= null then
+ if T.Common.Task_Info.New_LWP
+ and then T.Common.Task_Info.CPU /= CPU_UNCHANGED
+ then
+ Last_Proc := Num_Procs - 1;
+
+ if T.Common.Task_Info.CPU = ANY_CPU then
+ Result := 0;
+
+ Proc := 0;
+ while Proc < Last_Proc loop
+ Result := p_online (Proc, PR_STATUS);
+ exit when Result = PR_ONLINE;
+ Proc := Proc + 1;
+ end loop;
+
+ Result :=
+ processor_bind
+ (P_LWPID, id_t (T.Common.LL.LWP), Proc, null);
+ pragma Assert (Result = 0);
+
+ else
+ -- Use specified processor
+
+ if T.Common.Task_Info.CPU < 0
+ or else T.Common.Task_Info.CPU > Last_Proc
+ then
+ raise Invalid_CPU_Number;
+ end if;
+
+ Result :=
+ processor_bind
+ (P_LWPID, id_t (T.Common.LL.LWP),
+ T.Common.Task_Info.CPU, null);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+
+ -- Handle dispatching domains
+
+ elsif T.Common.Domain /= null
+ and then (T.Common.Domain /= ST.System_Domain
+ or else T.Common.Domain.all /=
+ (Multiprocessors.CPU'First ..
+ Multiprocessors.Number_Of_CPUs => True))
+ then
+ declare
+ CPU_Set : aliased psetid_t;
+ Result : int;
+
+ begin
+ Result := pset_create (CPU_Set'Access);
+ pragma Assert (Result = 0);
+
+ -- Set the affinity to all the processors belonging to the
+ -- dispatching domain.
+
+ for Proc in T.Common.Domain'Range loop
+
+ -- The Ada CPU numbering starts at 1 while the subprogram to
+ -- set the affinity starts at 0, therefore we must substract 1.
+
+ if T.Common.Domain (Proc) then
+ Result :=
+ pset_assign (CPU_Set, processorid_t (Proc) - 1, null);
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ Result :=
+ pset_bind (CPU_Set, P_LWPID, id_t (T.Common.LL.LWP), null);
+ pragma Assert (Result = 0);
+ end;
+ end if;
+ end Set_Task_Affinity;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . 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 --
+-- <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 VxWorks version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+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.Multiprocessors;
+with System.Tasking.Debug;
+with System.Interrupt_Management;
+with System.Float_Control;
+with System.OS_Constants;
+
+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.
+
+with System.Task_Info;
+with System.VxWorks.Ext;
+
+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 System.OS_Interface;
+ use System.Parameters;
+ use type System.VxWorks.Ext.t_id;
+ use type Interfaces.C.int;
+ use type System.OS_Interface.unsigned;
+
+ subtype int is System.OS_Interface.int;
+ subtype unsigned is System.OS_Interface.unsigned;
+
+ Relative : constant := 0;
+
+ ----------------
+ -- Local Data --
+ ----------------
+
+ -- The followings are logically constants, but need to be initialized at
+ -- run time.
+
+ Environment_Task_Id : Task_Id;
+ -- A variable to hold Task_Id for the environment task
+
+ -- The followings are internal configuration constants needed
+
+ Dispatching_Policy : 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)
+
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+
+ Mutex_Protocol : Priority_Type;
+
+ 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
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Null_Thread_Id : constant Thread_Id := 0;
+ -- Constant to indicate that the thread identifier has not yet been
+ -- initialized.
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ procedure Initialize;
+ pragma Inline (Initialize);
+ -- Initialize task specific data
+
+ 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, unless Self_Id is null, in
+ -- which case the task specific data is deleted.
+
+ 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) return Task_Id;
+ -- Allocate and Initialize a new ATCB for the current Thread
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_Id is separate;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler (signo : Signal);
+ -- Handler for the abort (SIGABRT) signal to handle asynchronous abort
+
+ procedure Install_Signal_Handlers;
+ -- Install the default signal handlers for the current task
+
+ function Is_Task_Context return Boolean;
+ -- This function returns True if the current execution is in the context of
+ -- a task, and False if it is an interrupt context.
+
+ type Set_Stack_Limit_Proc_Acc is access procedure;
+ pragma Convention (C, Set_Stack_Limit_Proc_Acc);
+
+ Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
+ pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
+ -- Procedure to be called when a task is created to set stack limit. Used
+ -- only for VxWorks 5 and VxWorks MILS guest OS.
+
+ function To_Address is
+ new Ada.Unchecked_Conversion (Task_Id, System.Address);
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ procedure Abort_Handler (signo : Signal) is
+ pragma Unreferenced (signo);
+
+ Self_ID : constant Task_Id := Self;
+ Old_Set : aliased sigset_t;
+ Unblocked_Mask : aliased sigset_t;
+ Result : int;
+ pragma Warnings (Off, Result);
+
+ use System.Interrupt_Management;
+
+ begin
+ -- It is not safe to raise an exception when using ZCX and the GCC
+ -- exception handling mechanism.
+
+ if ZCX_By_Default then
+ return;
+ end if;
+
+ if Self_ID.Deferral_Level = 0
+ and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ and then not Self_ID.Aborting
+ then
+ Self_ID.Aborting := True;
+
+ -- Make sure signals used for RTS internal purposes are unmasked
+
+ Result := sigemptyset (Unblocked_Mask'Access);
+ pragma Assert (Result = 0);
+ Result :=
+ sigaddset
+ (Unblocked_Mask'Access,
+ Signal (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
+ pragma Unreferenced (T);
+ pragma Unreferenced (On);
+
+ begin
+ -- Nothing needed (why not???)
+
+ null;
+ 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;
+
+ -----------------------------
+ -- Install_Signal_Handlers --
+ -----------------------------
+
+ procedure Install_Signal_Handlers is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : int;
+
+ begin
+ 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 (Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ Interrupt_Management.Initialize_Interrupts;
+ end Install_Signal_Handlers;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : not null access Lock)
+ is
+ begin
+ L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
+ L.Prio_Ceiling := int (Prio);
+ L.Protocol := Mutex_Protocol;
+ pragma Assert (L.Mutex /= 0);
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock;
+ Level : Lock_Level)
+ is
+ pragma Unreferenced (Level);
+ begin
+ L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
+ L.Prio_Ceiling := int (System.Any_Priority'Last);
+ L.Protocol := Mutex_Protocol;
+ pragma Assert (L.Mutex /= 0);
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : not null access Lock) is
+ Result : int;
+ begin
+ Result := semDelete (L.Mutex);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : not null access RTS_Lock) is
+ Result : int;
+ begin
+ Result := semDelete (L.Mutex);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
+ Result : int;
+
+ begin
+ if L.Protocol = Prio_Protect
+ and then int (Self.Common.Current_Priority) > L.Prio_Ceiling
+ then
+ Ceiling_Violation := True;
+ return;
+ else
+ Ceiling_Violation := False;
+ end if;
+
+ Result := semTake (L.Mutex, WAIT_FOREVER);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ procedure Write_Lock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ Result : int;
+ begin
+ if not Single_Lock or else Global_Lock then
+ Result := semTake (L.Mutex, WAIT_FOREVER);
+ pragma Assert (Result = 0);
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_Id) is
+ Result : int;
+ begin
+ if not Single_Lock then
+ Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
+ 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 : int;
+ begin
+ Result := semGive (L.Mutex);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ Result : int;
+ begin
+ if not Single_Lock or else Global_Lock then
+ Result := semGive (L.Mutex);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ procedure Unlock (T : Task_Id) is
+ Result : int;
+ begin
+ if not Single_Lock then
+ Result := semGive (T.Common.LL.L.Mutex);
+ 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 : int;
+
+ begin
+ pragma Assert (Self_ID = Self);
+
+ -- Release the mutex before sleeping
+
+ Result :=
+ semGive (if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex);
+ pragma Assert (Result = 0);
+
+ -- Perform a blocking operation to take the CV semaphore. Note that a
+ -- blocking operation in VxWorks will reenable task scheduling. When we
+ -- are no longer blocked and control is returned, task scheduling will
+ -- again be disabled.
+
+ Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER);
+ pragma Assert (Result = 0);
+
+ -- Take the mutex back
+
+ Result :=
+ semTake ((if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
+ pragma Assert (Result = 0);
+ 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 : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ pragma Unreferenced (Reason);
+
+ Orig : constant Duration := Monotonic_Clock;
+ Absolute : Duration;
+ Ticks : int;
+ Result : int;
+ Wakeup : Boolean := False;
+
+ begin
+ Timedout := False;
+ Yielded := True;
+
+ if Mode = Relative then
+ Absolute := Orig + Time;
+
+ -- Systematically add one since the first tick will delay *at most*
+ -- 1 / Rate_Duration seconds, so we need to add one to be on the
+ -- safe side.
+
+ Ticks := To_Clock_Ticks (Time);
+
+ if Ticks > 0 and then Ticks < int'Last then
+ Ticks := Ticks + 1;
+ end if;
+
+ else
+ Absolute := Time;
+ Ticks := To_Clock_Ticks (Time - Monotonic_Clock);
+ end if;
+
+ if Ticks > 0 then
+ loop
+ -- Release the mutex before sleeping
+
+ Result :=
+ semGive (if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex);
+ pragma Assert (Result = 0);
+
+ -- Perform a blocking operation to take the CV semaphore. Note
+ -- that a blocking operation in VxWorks will reenable task
+ -- scheduling. When we are no longer blocked and control is
+ -- returned, task scheduling will again be disabled.
+
+ Result := semTake (Self_ID.Common.LL.CV, Ticks);
+
+ if Result = 0 then
+
+ -- Somebody may have called Wakeup for us
+
+ Wakeup := True;
+
+ else
+ if errno /= S_objLib_OBJ_TIMEOUT then
+ Wakeup := True;
+
+ else
+ -- If Ticks = int'last, it was most probably truncated so
+ -- let's make another round after recomputing Ticks from
+ -- the absolute time.
+
+ if Ticks /= int'Last then
+ Timedout := True;
+
+ else
+ Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
+
+ if Ticks < 0 then
+ Timedout := True;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- Take the mutex back
+
+ Result :=
+ semTake ((if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
+ pragma Assert (Result = 0);
+
+ exit when Timedout or Wakeup;
+ end loop;
+
+ else
+ Timedout := True;
+
+ -- Should never hold a lock while yielding
+
+ if Single_Lock then
+ Result := semGive (Single_RTS_Lock.Mutex);
+ Result := taskDelay (0);
+ Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
+
+ else
+ Result := semGive (Self_ID.Common.LL.L.Mutex);
+ Result := taskDelay (0);
+ Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
+ end if;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ -- This is for use in implementing delay statements, so we assume the
+ -- caller is holding no locks.
+
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Orig : constant Duration := Monotonic_Clock;
+ Absolute : Duration;
+ Ticks : int;
+ Timedout : Boolean;
+ Aborted : Boolean := False;
+
+ Result : int;
+ pragma Warnings (Off, Result);
+
+ begin
+ if Mode = Relative then
+ Absolute := Orig + Time;
+ Ticks := To_Clock_Ticks (Time);
+
+ if Ticks > 0 and then Ticks < int'Last then
+
+ -- First tick will delay anytime between 0 and 1 / sysClkRateGet
+ -- seconds, so we need to add one to be on the safe side.
+
+ Ticks := Ticks + 1;
+ end if;
+
+ else
+ Absolute := Time;
+ Ticks := To_Clock_Ticks (Time - Orig);
+ end if;
+
+ if Ticks > 0 then
+
+ -- Modifying State, locking the TCB
+
+ Result :=
+ semTake ((if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
+
+ pragma Assert (Result = 0);
+
+ Self_ID.Common.State := Delay_Sleep;
+ Timedout := False;
+
+ loop
+ Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ -- Release the TCB before sleeping
+
+ Result :=
+ semGive (if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex);
+ pragma Assert (Result = 0);
+
+ exit when Aborted;
+
+ Result := semTake (Self_ID.Common.LL.CV, Ticks);
+
+ if Result /= 0 then
+
+ -- If Ticks = int'last, it was most probably truncated, so make
+ -- another round after recomputing Ticks from absolute time.
+
+ if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then
+ Timedout := True;
+ else
+ Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
+
+ if Ticks < 0 then
+ Timedout := True;
+ end if;
+ end if;
+ end if;
+
+ -- Take back the lock after having slept, to protect further
+ -- access to Self_ID.
+
+ Result :=
+ semTake
+ ((if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
+
+ pragma Assert (Result = 0);
+
+ exit when Timedout;
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+
+ Result :=
+ semGive
+ (if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex);
+
+ else
+ Result := taskDelay (0);
+ end if;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : int;
+ begin
+ Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 1.0 / Duration (sysClkRateGet);
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+ Result : int;
+ begin
+ Result := semGive (T.Common.LL.CV);
+ pragma Assert (Result = 0);
+ end Wakeup;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ pragma Unreferenced (Do_Yield);
+ Result : int;
+ pragma Unreferenced (Result);
+ begin
+ Result := taskDelay (0);
+ 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 : int;
+
+ begin
+ Result :=
+ taskPrioritySet
+ (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio)));
+ pragma Assert (Result = 0);
+
+ -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of
+ -- the priority queue instead of the head. This is not the behavior
+ -- required by Annex D (RM D.2.3(5/2)), but we consider it an acceptable
+ -- variation (RM 1.1.3(6)), given this is the built-in behavior of the
+ -- operating system. VxWorks versions starting from 6.7 implement the
+ -- required Annex D semantics.
+
+ -- In older versions we attempted to better approximate the Annex D
+ -- required behavior, but this simulation was not entirely accurate,
+ -- and it seems better to live with the standard VxWorks semantics.
+
+ T.Common.Current_Priority := Prio;
+ 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
+ -- Store the user-level task id in the Thread field (to be used
+ -- internally by the run-time system) and the kernel-level task id in
+ -- the LWP field (to be used by the debugger).
+
+ Self_ID.Common.LL.Thread := taskIdSelf;
+ Self_ID.Common.LL.LWP := getpid;
+
+ Specific.Set (Self_ID);
+
+ -- Properly initializes the FPU for PPC/MIPS systems
+
+ System.Float_Control.Reset;
+
+ -- Install the signal handlers
+
+ -- This is called for each task since there is no signal inheritance
+ -- between VxWorks tasks.
+
+ Install_Signal_Handlers;
+
+ -- If stack checking is enabled, set the stack limit for this task
+
+ if Set_Stack_Limit_Hook /= null then
+ Set_Stack_Limit_Hook.all;
+ 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 (taskIdSelf);
+ end if;
+ end Register_Foreign_Thread;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
+ begin
+ Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
+ Self_ID.Common.LL.Thread := Null_Thread_Id;
+
+ if Self_ID.Common.LL.CV = 0 then
+ Succeeded := False;
+
+ else
+ Succeeded := True;
+
+ if not Single_Lock then
+ Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
+ end if;
+ end if;
+ 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
+ Adjusted_Stack_Size : size_t;
+
+ use type System.Multiprocessors.CPU_Range;
+
+ begin
+ -- Check whether both Dispatching_Domain and CPU are specified for
+ -- the task, and the CPU value is not contained within the range of
+ -- processors for the domain.
+
+ if T.Common.Domain /= null
+ and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
+ and then
+ (T.Common.Base_CPU not in T.Common.Domain'Range
+ or else not T.Common.Domain (T.Common.Base_CPU))
+ then
+ Succeeded := False;
+ return;
+ end if;
+
+ -- Ask for four extra bytes of stack space so that the ATCB pointer can
+ -- be stored below the stack limit, plus extra space for the frame of
+ -- Task_Wrapper. This is so the user gets the amount of stack requested
+ -- exclusive of the needs.
+
+ -- We also have to allocate n more bytes for the task name storage and
+ -- enough space for the Wind Task Control Block which is around 0x778
+ -- bytes. VxWorks also seems to carve out additional space, so use 2048
+ -- as a nice round number. We might want to increment to the nearest
+ -- page size in case we ever support VxVMI.
+
+ -- ??? - we should come back and visit this so we can set the task name
+ -- to something appropriate.
+
+ Adjusted_Stack_Size := size_t (Stack_Size) + 2048;
+
+ -- 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.
+
+ -- We now compute the VxWorks task name and options, then spawn ...
+
+ declare
+ Name : aliased String (1 .. T.Common.Task_Image_Len + 1);
+ Name_Address : System.Address;
+ -- Task name we are going to hand down to VxWorks
+
+ function Get_Task_Options return int;
+ pragma Import (C, Get_Task_Options, "__gnat_get_task_options");
+ -- Function that returns the options to be set for the task that we
+ -- are creating. We fetch the options assigned to the current task,
+ -- so offering some user level control over the options for a task
+ -- hierarchy, and force VX_FP_TASK because it is almost always
+ -- required.
+
+ begin
+ -- If there is no Ada task name handy, let VxWorks choose one.
+ -- Otherwise, tell VxWorks what the Ada task name is.
+
+ if T.Common.Task_Image_Len = 0 then
+ Name_Address := System.Null_Address;
+ else
+ Name (1 .. Name'Last - 1) :=
+ T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
+ Name (Name'Last) := ASCII.NUL;
+ Name_Address := Name'Address;
+ end if;
+
+ -- Now spawn the VxWorks task for real
+
+ T.Common.LL.Thread :=
+ taskSpawn
+ (Name_Address,
+ To_VxWorks_Priority (int (Priority)),
+ Get_Task_Options,
+ Adjusted_Stack_Size,
+ Wrapper,
+ To_Address (T));
+ end;
+
+ -- Set processor affinity
+
+ Set_Task_Affinity (T);
+
+ -- Only case of failure is if taskSpawn returned 0 (aka Null_Thread_Id)
+
+ if T.Common.LL.Thread = Null_Thread_Id then
+ Succeeded := False;
+ else
+ Succeeded := True;
+ Task_Creation_Hook (T.Common.LL.Thread);
+ Set_Priority (T, Priority);
+ end if;
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_Id) is
+ Result : int;
+
+ begin
+ if not Single_Lock then
+ Result := semDelete (T.Common.LL.L.Mutex);
+ pragma Assert (Result = 0);
+ end if;
+
+ T.Common.LL.Thread := Null_Thread_Id;
+
+ Result := semDelete (T.Common.LL.CV);
+ 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
+ Specific.Set (null);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
+ Result : int;
+ begin
+ Result :=
+ kill
+ (T.Common.LL.Thread,
+ Signal (Interrupt_Management.Abort_Task_Interrupt));
+ pragma Assert (Result = 0);
+ end Abort_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ begin
+ -- Initialize internal state (always to False (RM D.10(6)))
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ -- Use simpler binary semaphore instead of VxWorks mutual exclusion
+ -- semaphore, because we don't need the fancier semantics and their
+ -- overhead.
+
+ S.L := semBCreate (SEM_Q_FIFO, SEM_FULL);
+
+ -- Initialize internal condition variable
+
+ S.CV := semBCreate (SEM_Q_FIFO, SEM_EMPTY);
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ pragma Unmodified (S);
+ -- S may be modified on other targets, but not on VxWorks
+
+ Result : STATUS;
+
+ begin
+ -- Destroy internal mutex
+
+ Result := semDelete (S.L);
+ pragma Assert (Result = OK);
+
+ -- Destroy internal condition variable
+
+ Result := semDelete (S.CV);
+ pragma Assert (Result = OK);
+ 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 : STATUS;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := semTake (S.L, WAIT_FOREVER);
+ pragma Assert (Result = OK);
+
+ S.State := False;
+
+ Result := semGive (S.L);
+ pragma Assert (Result = OK);
+
+ SSL.Abort_Undefer.all;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ Result : STATUS;
+
+ begin
+ -- Set_True can be called from an interrupt context, in which case
+ -- Abort_Defer is undefined.
+
+ if Is_Task_Context then
+ SSL.Abort_Defer.all;
+ end if;
+
+ Result := semTake (S.L, WAIT_FOREVER);
+ pragma Assert (Result = OK);
+
+ -- 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 := semGive (S.CV);
+ pragma Assert (Result = OK);
+ else
+ S.State := True;
+ end if;
+
+ Result := semGive (S.L);
+ pragma Assert (Result = OK);
+
+ -- Set_True can be called from an interrupt context, in which case
+ -- Abort_Undefer is undefined.
+
+ if Is_Task_Context then
+ SSL.Abort_Undefer.all;
+ end if;
+
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ Result : STATUS;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := semTake (S.L, WAIT_FOREVER);
+
+ 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 := semGive (S.L);
+ pragma Assert (Result = OK);
+
+ 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 (RM D.10 (9)).
+
+ if S.State then
+ S.State := False;
+
+ Result := semGive (S.L);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+
+ else
+ S.Waiting := True;
+
+ -- Release the mutex before sleeping
+
+ Result := semGive (S.L);
+ pragma Assert (Result = OK);
+
+ SSL.Abort_Undefer.all;
+
+ Result := semTake (S.CV, WAIT_FOREVER);
+ pragma Assert (Result = 0);
+ end if;
+ 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 /= Null_Thread_Id
+ and then T.Common.LL.Thread /= Thread_Self
+ then
+ return taskSuspend (T.Common.LL.Thread) = 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 /= Null_Thread_Id
+ and then T.Common.LL.Thread /= Thread_Self
+ then
+ return taskResume (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Resume_Task;
+
+ --------------------
+ -- Stop_All_Tasks --
+ --------------------
+
+ procedure Stop_All_Tasks
+ is
+ Thread_Self : constant Thread_Id := taskIdSelf;
+ C : Task_Id;
+
+ Dummy : int;
+ Old : int;
+
+ begin
+ Old := Int_Lock;
+
+ C := All_Tasks_List;
+ while C /= null loop
+ if C.Common.LL.Thread /= Null_Thread_Id
+ and then C.Common.LL.Thread /= Thread_Self
+ then
+ Dummy := Task_Stop (C.Common.LL.Thread);
+ end if;
+
+ C := C.Common.All_Tasks_Link;
+ end loop;
+
+ Dummy := Int_Unlock (Old);
+ end Stop_All_Tasks;
+
+ ---------------
+ -- Stop_Task --
+ ---------------
+
+ function Stop_Task (T : ST.Task_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Null_Thread_Id then
+ return Task_Stop (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Stop_Task;
+
+ -------------------
+ -- Continue_Task --
+ -------------------
+
+ function Continue_Task (T : ST.Task_Id) return Boolean
+ is
+ begin
+ if T.Common.LL.Thread /= Null_Thread_Id then
+ return Task_Cont (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Continue_Task;
+
+ ---------------------
+ -- Is_Task_Context --
+ ---------------------
+
+ function Is_Task_Context return Boolean is
+ begin
+ return System.OS_Interface.Interrupt_Context /= 1;
+ end Is_Task_Context;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ Result : int;
+ pragma Unreferenced (Result);
+
+ begin
+ Environment_Task_Id := Environment_Task;
+
+ Interrupt_Management.Initialize;
+ Specific.Initialize;
+
+ if Locking_Policy = 'C' then
+ Mutex_Protocol := Prio_Protect;
+ elsif Locking_Policy = 'I' then
+ Mutex_Protocol := Prio_Inherit;
+ else
+ Mutex_Protocol := Prio_None;
+ end if;
+
+ if Time_Slice_Val > 0 then
+ Result :=
+ Set_Time_Slice
+ (To_Clock_Ticks
+ (Duration (Time_Slice_Val) / Duration (1_000_000.0)));
+
+ elsif Dispatching_Policy = 'R' then
+ Result := Set_Time_Slice (To_Clock_Ticks (0.01));
+
+ end if;
+
+ -- Initialize the lock used to synchronize chain of all ATCBs
+
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ -- 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);
+
+ -- Set processor affinity
+
+ Set_Task_Affinity (Environment_Task);
+ end Initialize;
+
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ Result : int := 0;
+ pragma Unreferenced (Result);
+
+ use System.Task_Info;
+ use type System.Multiprocessors.CPU_Range;
+
+ begin
+ -- Do nothing if the underlying thread has not yet been created. If the
+ -- thread has not yet been created then the proper affinity will be set
+ -- during its creation.
+
+ if T.Common.LL.Thread = Null_Thread_Id then
+ null;
+
+ -- pragma CPU
+
+ elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
+
+ -- Ada 2012 pragma CPU uses CPU numbers starting from 1, while on
+ -- VxWorks the first CPU is identified by a 0, so we need to adjust.
+
+ Result :=
+ taskCpuAffinitySet
+ (T.Common.LL.Thread, int (T.Common.Base_CPU) - 1);
+
+ -- Task_Info
+
+ elsif T.Common.Task_Info /= Unspecified_Task_Info then
+ Result := taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info);
+
+ -- Handle dispatching domains
+
+ elsif T.Common.Domain /= null
+ and then (T.Common.Domain /= ST.System_Domain
+ or else T.Common.Domain.all /=
+ (Multiprocessors.CPU'First ..
+ Multiprocessors.Number_Of_CPUs => True))
+ then
+ declare
+ CPU_Set : unsigned := 0;
+
+ begin
+ -- Set the affinity to all the processors belonging to the
+ -- dispatching domain.
+
+ for Proc in T.Common.Domain'Range loop
+ if T.Common.Domain (Proc) then
+
+ -- The thread affinity mask is a bit vector in which each
+ -- bit represents a logical processor.
+
+ CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1);
+ end if;
+ end loop;
+
+ Result := taskMaskAffinitySet (T.Common.LL.Thread, CPU_Set);
+ end;
+ end if;
+ end Set_Task_Affinity;
+
+end System.Task_Primitives.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- B o d y --
--- --
--- Copyright (C) 2009-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the GNU/Linux version of this module
-
-package body System.Task_Info is
-
- N_CPU : Natural := 0;
- pragma Atomic (N_CPU);
- -- Cache CPU number. Use pragma Atomic to avoid a race condition when
- -- setting N_CPU in Number_Of_Processors below.
-
- --------------------------
- -- Number_Of_Processors --
- --------------------------
-
- function Number_Of_Processors return Positive is
- begin
- if N_CPU = 0 then
- N_CPU := Natural
- (OS_Interface.sysconf (OS_Interface.SC_NPROCESSORS_ONLN));
- end if;
-
- return N_CPU;
- end Number_Of_Processors;
-
-end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- S p e c --
--- --
--- Copyright (C) 2007-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the definitions and routines associated with the
--- implementation and use of the Task_Info pragma. It is specialized
--- appropriately for targets that make use of this pragma.
-
--- Note: the compiler generates direct calls to this interface, via Rtsfind.
--- Any changes to this interface may require corresponding compiler changes.
-
--- The functionality in this unit is now provided by the predefined package
--- System.Multiprocessors and the CPU aspect. This package is obsolescent.
-
--- This is the GNU/Linux version of this module
-
-with System.OS_Interface;
-
-package System.Task_Info is
- pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
- pragma Preelaborate;
- pragma Elaborate_Body;
- -- To ensure that a body is allowed
-
- -- The Linux kernel provides a way to define the ideal processor to use for
- -- a given thread. The ideal processor is not necessarily the one that will
- -- be used by the OS but the OS will always try to schedule this thread to
- -- the specified processor if it is available.
-
- -- The Task_Info pragma:
-
- -- pragma Task_Info (EXPRESSION);
-
- -- allows the specification on a task by task basis of a value of type
- -- System.Task_Info.Task_Info_Type to be passed to a task when it is
- -- created. The specification of this type, and the effect on the task
- -- that is created is target dependent.
-
- -- The Task_Info pragma appears within a task definition (compare the
- -- definition and implementation of pragma Priority). If no such pragma
- -- appears, then the value Unspecified_Task_Info is passed. If a pragma
- -- is present, then it supplies an alternative value. If the argument of
- -- the pragma is a discriminant reference, then the value can be set on
- -- a task by task basis by supplying the appropriate discriminant value.
-
- -- Note that this means that the type used for Task_Info_Type must be
- -- suitable for use as a discriminant (i.e. a scalar or access type).
-
- -----------------------
- -- Thread Attributes --
- -----------------------
-
- subtype CPU_Set is System.OS_Interface.cpu_set_t;
-
- Any_CPU : constant CPU_Set := (bits => (others => True));
- No_CPU : constant CPU_Set := (bits => (others => False));
-
- Invalid_CPU_Number : exception;
- -- Raised when an invalid CPU mask has been specified
- -- i.e. An empty CPU set
-
- type Thread_Attributes is record
- CPU_Affinity : aliased CPU_Set := Any_CPU;
- end record;
-
- Default_Thread_Attributes : constant Thread_Attributes := (others => <>);
-
- type Task_Info_Type is access all Thread_Attributes;
-
- Unspecified_Task_Info : constant Task_Info_Type := null;
-
- function Number_Of_Processors return Positive;
- -- Returns the number of processors on the running host
-
-end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- B o d y --
--- --
--- Copyright (C) 2007-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Windows (native) version of this module
-
-with System.OS_Interface;
-pragma Unreferenced (System.OS_Interface);
--- System.OS_Interface is not used today, but the protocol between the
--- run-time and the binder is that any tasking application uses
--- System.OS_Interface, so notify the binder with this "with" clause.
-
-package body System.Task_Info is
-
- N_CPU : Natural := 0;
- pragma Atomic (N_CPU);
- -- Cache CPU number. Use pragma Atomic to avoid a race condition when
- -- setting N_CPU in Number_Of_Processors below.
-
- --------------------------
- -- Number_Of_Processors --
- --------------------------
-
- function Number_Of_Processors return Positive is
- begin
- if N_CPU = 0 then
- declare
- SI : aliased Win32.SYSTEM_INFO;
- begin
- Win32.GetSystemInfo (SI'Access);
- N_CPU := Positive (SI.dwNumberOfProcessors);
- end;
- end if;
-
- return N_CPU;
- end Number_Of_Processors;
-
-end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- S p e c --
--- --
--- Copyright (C) 2007-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the definitions and routines associated with the
--- implementation and use of the Task_Info pragma. It is specialized
--- appropriately for targets that make use of this pragma.
-
--- Note: the compiler generates direct calls to this interface, via Rtsfind.
--- Any changes to this interface may require corresponding compiler changes.
-
--- The functionality in this unit is now provided by the predefined package
--- System.Multiprocessors and the CPU aspect. This package is obsolescent.
-
--- This is the Windows (native) version of this module
-
-with System.Win32;
-
-package System.Task_Info is
- pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
- pragma Preelaborate;
- pragma Elaborate_Body;
- -- To ensure that a body is allowed
-
- use type System.Win32.ProcessorId;
-
- -- Windows provides a way to define the ideal processor to use for a given
- -- thread. The ideal processor is not necessarily the one that will be used
- -- by the OS but the OS will always try to schedule this thread to the
- -- specified processor if it is available.
-
- -- The Task_Info pragma:
-
- -- pragma Task_Info (EXPRESSION);
-
- -- allows the specification on a task by task basis of a value of type
- -- System.Task_Info.Task_Info_Type to be passed to a task when it is
- -- created. The specification of this type, and the effect on the task
- -- that is created is target dependent.
-
- -- The Task_Info pragma appears within a task definition (compare the
- -- definition and implementation of pragma Priority). If no such pragma
- -- appears, then the value Unspecified_Task_Info is passed. If a pragma
- -- is present, then it supplies an alternative value. If the argument of
- -- the pragma is a discriminant reference, then the value can be set on
- -- a task by task basis by supplying the appropriate discriminant value.
-
- -- Note that this means that the type used for Task_Info_Type must be
- -- suitable for use as a discriminant (i.e. a scalar or access type).
-
- -----------------------
- -- Thread Attributes --
- -----------------------
-
- subtype CPU_Number is System.Win32.ProcessorId;
-
- Any_CPU : constant CPU_Number := -1;
-
- Invalid_CPU_Number : exception;
- -- Raised when an invalid CPU number has been specified
- -- i.e. CPU > Number_Of_Processors.
-
- type Thread_Attributes is record
- CPU : CPU_Number := Any_CPU;
- end record;
-
- Default_Thread_Attributes : constant Thread_Attributes := (others => <>);
-
- type Task_Info_Type is access all Thread_Attributes;
-
- Unspecified_Task_Info : constant Task_Info_Type := null;
-
- function Number_Of_Processors return Positive;
- -- Returns the number of processors on the running host
-
-end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package body contains the routines associated with the implementation
--- of the Task_Info pragma.
-
--- This is the Solaris (native) version of this module
-
-package body System.Task_Info is
-
- -----------------------------
- -- Bound_Thread_Attributes --
- -----------------------------
-
- function Bound_Thread_Attributes return Thread_Attributes is
- begin
- return (False, True);
- end Bound_Thread_Attributes;
-
- function Bound_Thread_Attributes (CPU : CPU_Number)
- return Thread_Attributes is
- begin
- return (True, True, CPU);
- end Bound_Thread_Attributes;
-
- ---------------------------------
- -- New_Bound_Thread_Attributes --
- ---------------------------------
-
- function New_Bound_Thread_Attributes return Task_Info_Type is
- begin
- return new Thread_Attributes'(False, True);
- end New_Bound_Thread_Attributes;
-
- function New_Bound_Thread_Attributes (CPU : CPU_Number)
- return Task_Info_Type is
- begin
- return new Thread_Attributes'(True, True, CPU);
- end New_Bound_Thread_Attributes;
-
- -----------------------------------
- -- New_Unbound_Thread_Attributes --
- -----------------------------------
-
- function New_Unbound_Thread_Attributes return Task_Info_Type is
- begin
- return new Thread_Attributes'(False, False);
- end New_Unbound_Thread_Attributes;
-
- -------------------------------
- -- Unbound_Thread_Attributes --
- -------------------------------
-
- function Unbound_Thread_Attributes return Thread_Attributes is
- begin
- return (False, False);
- end Unbound_Thread_Attributes;
-
-end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the definitions and routines associated with the
--- implementation and use of the Task_Info pragma. It is specialized
--- appropriately for targets that make use of this pragma.
-
--- Note: the compiler generates direct calls to this interface, via Rtsfind.
--- Any changes to this interface may require corresponding compiler changes.
-
--- The functionality in this unit is now provided by the predefined package
--- System.Multiprocessors and the CPU aspect. This package is obsolescent.
-
--- This is the Solaris (native) version of this module
-
-with System.OS_Interface;
-
-package System.Task_Info is
- pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
- pragma Preelaborate;
- pragma Elaborate_Body;
- -- To ensure that a body is allowed
-
- -----------------------------------------------------
- -- Binding of Tasks to LWPs and LWPs to processors --
- -----------------------------------------------------
-
- -- The Solaris implementation of the GNU Low-Level Interface (GNULLI)
- -- implements each Ada task as a Solaris thread. The Solaris thread
- -- library distributes threads across one or more LWPs (Light Weight
- -- Process) that are members of the same process. Solaris distributes
- -- processes and LWPs across the available CPUs on a given machine. The
- -- pragma Task_Info provides the mechanism to control the distribution
- -- of tasks to LWPs, and LWPs to processors.
-
- -- Each thread has a number of attributes that dictate it's scheduling.
- -- These attributes are:
- --
- -- New_LWP: whether a new LWP is created for this thread.
- --
- -- Bound_To_LWP: whether the thread is bound to a specific LWP
- -- for its entire lifetime.
- --
- -- CPU: the CPU number associated to the LWP
- --
-
- -- The Task_Info pragma:
-
- -- pragma Task_Info (EXPRESSION);
-
- -- allows the specification on a task by task basis of a value of type
- -- System.Task_Info.Task_Info_Type to be passed to a task when it is
- -- created. The specification of this type, and the effect on the task
- -- that is created is target dependent.
-
- -- The Task_Info pragma appears within a task definition (compare the
- -- definition and implementation of pragma Priority). If no such pragma
- -- appears, then the value Unspecified_Task_Info is passed. If a pragma
- -- is present, then it supplies an alternative value. If the argument of
- -- the pragma is a discriminant reference, then the value can be set on
- -- a task by task basis by supplying the appropriate discriminant value.
-
- -- Note that this means that the type used for Task_Info_Type must be
- -- suitable for use as a discriminant (i.e. a scalar or access type).
-
- -----------------------
- -- Thread Attributes --
- -----------------------
-
- subtype CPU_Number is System.OS_Interface.processorid_t;
-
- CPU_UNCHANGED : constant CPU_Number := System.OS_Interface.PBIND_QUERY;
- -- Do not bind the LWP to a specific processor
-
- ANY_CPU : constant CPU_Number := System.OS_Interface.PBIND_NONE;
- -- Bind the LWP to any processor
-
- Invalid_CPU_Number : exception;
-
- type Thread_Attributes (New_LWP : Boolean) is record
- Bound_To_LWP : Boolean := True;
- case New_LWP is
- when False =>
- null;
- when True =>
- CPU : CPU_Number := CPU_UNCHANGED;
- end case;
- end record;
-
- Default_Thread_Attributes : constant Thread_Attributes := (False, True);
-
- function Unbound_Thread_Attributes
- return Thread_Attributes;
-
- function Bound_Thread_Attributes
- return Thread_Attributes;
-
- function Bound_Thread_Attributes (CPU : CPU_Number)
- return Thread_Attributes;
-
- type Task_Info_Type is access all Thread_Attributes;
-
- function New_Unbound_Thread_Attributes
- return Task_Info_Type;
-
- function New_Bound_Thread_Attributes
- return Task_Info_Type;
-
- function New_Bound_Thread_Attributes (CPU : CPU_Number)
- return Task_Info_Type;
-
- Unspecified_Task_Info : constant Task_Info_Type := null;
-
-end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the definitions and routines associated with the
--- implementation and use of the Task_Info pragma. It is specialized
--- appropriately for targets that make use of this pragma.
-
--- Note: the compiler generates direct calls to this interface, via Rtsfind.
--- Any changes to this interface may require corresponding compiler changes.
-
--- The functionality in this unit is now provided by the predefined package
--- System.Multiprocessors and the CPU aspect. This package is obsolescent.
-
--- This is the VxWorks version of this package
-
-with Interfaces.C;
-
-package System.Task_Info is
- pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
- pragma Preelaborate;
- pragma Elaborate_Body;
- -- To ensure that a body is allowed
-
- -----------------------------------------
- -- Implementation of Task_Info Feature --
- -----------------------------------------
-
- -- The Task_Info pragma:
-
- -- pragma Task_Info (EXPRESSION);
-
- -- allows the specification on a task by task basis of a value of type
- -- System.Task_Info.Task_Info_Type to be passed to a task when it is
- -- created. The specification of this type, and the effect on the task
- -- that is created is target dependent.
-
- -- The Task_Info pragma appears within a task definition (compare the
- -- definition and implementation of pragma Priority). If no such pragma
- -- appears, then the value Unspecified_Task_Info is passed. If a pragma
- -- is present, then it supplies an alternative value. If the argument of
- -- the pragma is a discriminant reference, then the value can be set on
- -- a task by task basis by supplying the appropriate discriminant value.
-
- -- Note that this means that the type used for Task_Info_Type must be
- -- suitable for use as a discriminant (i.e. a scalar or access type).
-
- ------------------
- -- Declarations --
- ------------------
-
- subtype Task_Info_Type is Interfaces.C.int;
- -- This is a CPU number (natural - CPUs are 0-indexed on VxWorks)
-
- use type Interfaces.C.int;
-
- Unspecified_Task_Info : constant Task_Info_Type := -1;
- -- Value passed to task in the absence of a Task_Info pragma
- -- This value means do not try to set the CPU affinity
-
-end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2009-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the GNU/Linux version of this module
+
+package body System.Task_Info is
+
+ N_CPU : Natural := 0;
+ pragma Atomic (N_CPU);
+ -- Cache CPU number. Use pragma Atomic to avoid a race condition when
+ -- setting N_CPU in Number_Of_Processors below.
+
+ --------------------------
+ -- Number_Of_Processors --
+ --------------------------
+
+ function Number_Of_Processors return Positive is
+ begin
+ if N_CPU = 0 then
+ N_CPU := Natural
+ (OS_Interface.sysconf (OS_Interface.SC_NPROCESSORS_ONLN));
+ end if;
+
+ return N_CPU;
+ end Number_Of_Processors;
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines associated with the
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+-- The functionality in this unit is now provided by the predefined package
+-- System.Multiprocessors and the CPU aspect. This package is obsolescent.
+
+-- This is the GNU/Linux version of this module
+
+with System.OS_Interface;
+
+package System.Task_Info is
+ pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
+ pragma Preelaborate;
+ pragma Elaborate_Body;
+ -- To ensure that a body is allowed
+
+ -- The Linux kernel provides a way to define the ideal processor to use for
+ -- a given thread. The ideal processor is not necessarily the one that will
+ -- be used by the OS but the OS will always try to schedule this thread to
+ -- the specified processor if it is available.
+
+ -- The Task_Info pragma:
+
+ -- pragma Task_Info (EXPRESSION);
+
+ -- allows the specification on a task by task basis of a value of type
+ -- System.Task_Info.Task_Info_Type to be passed to a task when it is
+ -- created. The specification of this type, and the effect on the task
+ -- that is created is target dependent.
+
+ -- The Task_Info pragma appears within a task definition (compare the
+ -- definition and implementation of pragma Priority). If no such pragma
+ -- appears, then the value Unspecified_Task_Info is passed. If a pragma
+ -- is present, then it supplies an alternative value. If the argument of
+ -- the pragma is a discriminant reference, then the value can be set on
+ -- a task by task basis by supplying the appropriate discriminant value.
+
+ -- Note that this means that the type used for Task_Info_Type must be
+ -- suitable for use as a discriminant (i.e. a scalar or access type).
+
+ -----------------------
+ -- Thread Attributes --
+ -----------------------
+
+ subtype CPU_Set is System.OS_Interface.cpu_set_t;
+
+ Any_CPU : constant CPU_Set := (bits => (others => True));
+ No_CPU : constant CPU_Set := (bits => (others => False));
+
+ Invalid_CPU_Number : exception;
+ -- Raised when an invalid CPU mask has been specified
+ -- i.e. An empty CPU set
+
+ type Thread_Attributes is record
+ CPU_Affinity : aliased CPU_Set := Any_CPU;
+ end record;
+
+ Default_Thread_Attributes : constant Thread_Attributes := (others => <>);
+
+ type Task_Info_Type is access all Thread_Attributes;
+
+ Unspecified_Task_Info : constant Task_Info_Type := null;
+
+ function Number_Of_Processors return Positive;
+ -- Returns the number of processors on the running host
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Windows (native) version of this module
+
+with System.OS_Interface;
+pragma Unreferenced (System.OS_Interface);
+-- System.OS_Interface is not used today, but the protocol between the
+-- run-time and the binder is that any tasking application uses
+-- System.OS_Interface, so notify the binder with this "with" clause.
+
+package body System.Task_Info is
+
+ N_CPU : Natural := 0;
+ pragma Atomic (N_CPU);
+ -- Cache CPU number. Use pragma Atomic to avoid a race condition when
+ -- setting N_CPU in Number_Of_Processors below.
+
+ --------------------------
+ -- Number_Of_Processors --
+ --------------------------
+
+ function Number_Of_Processors return Positive is
+ begin
+ if N_CPU = 0 then
+ declare
+ SI : aliased Win32.SYSTEM_INFO;
+ begin
+ Win32.GetSystemInfo (SI'Access);
+ N_CPU := Positive (SI.dwNumberOfProcessors);
+ end;
+ end if;
+
+ return N_CPU;
+ end Number_Of_Processors;
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines associated with the
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+-- The functionality in this unit is now provided by the predefined package
+-- System.Multiprocessors and the CPU aspect. This package is obsolescent.
+
+-- This is the Windows (native) version of this module
+
+with System.Win32;
+
+package System.Task_Info is
+ pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
+ pragma Preelaborate;
+ pragma Elaborate_Body;
+ -- To ensure that a body is allowed
+
+ use type System.Win32.ProcessorId;
+
+ -- Windows provides a way to define the ideal processor to use for a given
+ -- thread. The ideal processor is not necessarily the one that will be used
+ -- by the OS but the OS will always try to schedule this thread to the
+ -- specified processor if it is available.
+
+ -- The Task_Info pragma:
+
+ -- pragma Task_Info (EXPRESSION);
+
+ -- allows the specification on a task by task basis of a value of type
+ -- System.Task_Info.Task_Info_Type to be passed to a task when it is
+ -- created. The specification of this type, and the effect on the task
+ -- that is created is target dependent.
+
+ -- The Task_Info pragma appears within a task definition (compare the
+ -- definition and implementation of pragma Priority). If no such pragma
+ -- appears, then the value Unspecified_Task_Info is passed. If a pragma
+ -- is present, then it supplies an alternative value. If the argument of
+ -- the pragma is a discriminant reference, then the value can be set on
+ -- a task by task basis by supplying the appropriate discriminant value.
+
+ -- Note that this means that the type used for Task_Info_Type must be
+ -- suitable for use as a discriminant (i.e. a scalar or access type).
+
+ -----------------------
+ -- Thread Attributes --
+ -----------------------
+
+ subtype CPU_Number is System.Win32.ProcessorId;
+
+ Any_CPU : constant CPU_Number := -1;
+
+ Invalid_CPU_Number : exception;
+ -- Raised when an invalid CPU number has been specified
+ -- i.e. CPU > Number_Of_Processors.
+
+ type Thread_Attributes is record
+ CPU : CPU_Number := Any_CPU;
+ end record;
+
+ Default_Thread_Attributes : constant Thread_Attributes := (others => <>);
+
+ type Task_Info_Type is access all Thread_Attributes;
+
+ Unspecified_Task_Info : constant Task_Info_Type := null;
+
+ function Number_Of_Processors return Positive;
+ -- Returns the number of processors on the running host
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package body contains the routines associated with the implementation
+-- of the Task_Info pragma.
+
+-- This is the Solaris (native) version of this module
+
+package body System.Task_Info is
+
+ -----------------------------
+ -- Bound_Thread_Attributes --
+ -----------------------------
+
+ function Bound_Thread_Attributes return Thread_Attributes is
+ begin
+ return (False, True);
+ end Bound_Thread_Attributes;
+
+ function Bound_Thread_Attributes (CPU : CPU_Number)
+ return Thread_Attributes is
+ begin
+ return (True, True, CPU);
+ end Bound_Thread_Attributes;
+
+ ---------------------------------
+ -- New_Bound_Thread_Attributes --
+ ---------------------------------
+
+ function New_Bound_Thread_Attributes return Task_Info_Type is
+ begin
+ return new Thread_Attributes'(False, True);
+ end New_Bound_Thread_Attributes;
+
+ function New_Bound_Thread_Attributes (CPU : CPU_Number)
+ return Task_Info_Type is
+ begin
+ return new Thread_Attributes'(True, True, CPU);
+ end New_Bound_Thread_Attributes;
+
+ -----------------------------------
+ -- New_Unbound_Thread_Attributes --
+ -----------------------------------
+
+ function New_Unbound_Thread_Attributes return Task_Info_Type is
+ begin
+ return new Thread_Attributes'(False, False);
+ end New_Unbound_Thread_Attributes;
+
+ -------------------------------
+ -- Unbound_Thread_Attributes --
+ -------------------------------
+
+ function Unbound_Thread_Attributes return Thread_Attributes is
+ begin
+ return (False, False);
+ end Unbound_Thread_Attributes;
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines associated with the
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+-- The functionality in this unit is now provided by the predefined package
+-- System.Multiprocessors and the CPU aspect. This package is obsolescent.
+
+-- This is the Solaris (native) version of this module
+
+with System.OS_Interface;
+
+package System.Task_Info is
+ pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
+ pragma Preelaborate;
+ pragma Elaborate_Body;
+ -- To ensure that a body is allowed
+
+ -----------------------------------------------------
+ -- Binding of Tasks to LWPs and LWPs to processors --
+ -----------------------------------------------------
+
+ -- The Solaris implementation of the GNU Low-Level Interface (GNULLI)
+ -- implements each Ada task as a Solaris thread. The Solaris thread
+ -- library distributes threads across one or more LWPs (Light Weight
+ -- Process) that are members of the same process. Solaris distributes
+ -- processes and LWPs across the available CPUs on a given machine. The
+ -- pragma Task_Info provides the mechanism to control the distribution
+ -- of tasks to LWPs, and LWPs to processors.
+
+ -- Each thread has a number of attributes that dictate it's scheduling.
+ -- These attributes are:
+ --
+ -- New_LWP: whether a new LWP is created for this thread.
+ --
+ -- Bound_To_LWP: whether the thread is bound to a specific LWP
+ -- for its entire lifetime.
+ --
+ -- CPU: the CPU number associated to the LWP
+ --
+
+ -- The Task_Info pragma:
+
+ -- pragma Task_Info (EXPRESSION);
+
+ -- allows the specification on a task by task basis of a value of type
+ -- System.Task_Info.Task_Info_Type to be passed to a task when it is
+ -- created. The specification of this type, and the effect on the task
+ -- that is created is target dependent.
+
+ -- The Task_Info pragma appears within a task definition (compare the
+ -- definition and implementation of pragma Priority). If no such pragma
+ -- appears, then the value Unspecified_Task_Info is passed. If a pragma
+ -- is present, then it supplies an alternative value. If the argument of
+ -- the pragma is a discriminant reference, then the value can be set on
+ -- a task by task basis by supplying the appropriate discriminant value.
+
+ -- Note that this means that the type used for Task_Info_Type must be
+ -- suitable for use as a discriminant (i.e. a scalar or access type).
+
+ -----------------------
+ -- Thread Attributes --
+ -----------------------
+
+ subtype CPU_Number is System.OS_Interface.processorid_t;
+
+ CPU_UNCHANGED : constant CPU_Number := System.OS_Interface.PBIND_QUERY;
+ -- Do not bind the LWP to a specific processor
+
+ ANY_CPU : constant CPU_Number := System.OS_Interface.PBIND_NONE;
+ -- Bind the LWP to any processor
+
+ Invalid_CPU_Number : exception;
+
+ type Thread_Attributes (New_LWP : Boolean) is record
+ Bound_To_LWP : Boolean := True;
+ case New_LWP is
+ when False =>
+ null;
+ when True =>
+ CPU : CPU_Number := CPU_UNCHANGED;
+ end case;
+ end record;
+
+ Default_Thread_Attributes : constant Thread_Attributes := (False, True);
+
+ function Unbound_Thread_Attributes
+ return Thread_Attributes;
+
+ function Bound_Thread_Attributes
+ return Thread_Attributes;
+
+ function Bound_Thread_Attributes (CPU : CPU_Number)
+ return Thread_Attributes;
+
+ type Task_Info_Type is access all Thread_Attributes;
+
+ function New_Unbound_Thread_Attributes
+ return Task_Info_Type;
+
+ function New_Bound_Thread_Attributes
+ return Task_Info_Type;
+
+ function New_Bound_Thread_Attributes (CPU : CPU_Number)
+ return Task_Info_Type;
+
+ Unspecified_Task_Info : constant Task_Info_Type := null;
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines associated with the
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+-- The functionality in this unit is now provided by the predefined package
+-- System.Multiprocessors and the CPU aspect. This package is obsolescent.
+
+-- This is the VxWorks version of this package
+
+with Interfaces.C;
+
+package System.Task_Info is
+ pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
+ pragma Preelaborate;
+ pragma Elaborate_Body;
+ -- To ensure that a body is allowed
+
+ -----------------------------------------
+ -- Implementation of Task_Info Feature --
+ -----------------------------------------
+
+ -- The Task_Info pragma:
+
+ -- pragma Task_Info (EXPRESSION);
+
+ -- allows the specification on a task by task basis of a value of type
+ -- System.Task_Info.Task_Info_Type to be passed to a task when it is
+ -- created. The specification of this type, and the effect on the task
+ -- that is created is target dependent.
+
+ -- The Task_Info pragma appears within a task definition (compare the
+ -- definition and implementation of pragma Priority). If no such pragma
+ -- appears, then the value Unspecified_Task_Info is passed. If a pragma
+ -- is present, then it supplies an alternative value. If the argument of
+ -- the pragma is a discriminant reference, then the value can be set on
+ -- a task by task basis by supplying the appropriate discriminant value.
+
+ -- Note that this means that the type used for Task_Info_Type must be
+ -- suitable for use as a discriminant (i.e. a scalar or access type).
+
+ ------------------
+ -- Declarations --
+ ------------------
+
+ subtype Task_Info_Type is Interfaces.C.int;
+ -- This is a CPU number (natural - CPUs are 0-indexed on VxWorks)
+
+ use type Interfaces.C.int;
+
+ Unspecified_Task_Info : constant Task_Info_Type := -1;
+ -- Value passed to task in the absence of a Task_Info pragma
+ -- This value means do not try to set the CPU affinity
+
+end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-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 --
--- <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 a no tasking version of this package
-
-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.
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is new Integer;
-
- type RTS_Lock is new Integer;
-
- type Suspension_Object is new Integer;
-
- type Task_Body_Access is access procedure;
-
- type Private_Data is limited record
- Thread : aliased Integer;
- CV : aliased Integer;
- L : aliased RTS_Lock;
- end record;
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2014, 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 a HP-UX version of this package
-
--- This package provides low-level support for most tasking features
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with System.OS_Interface;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- -- Should be used for implementation of protected objects
-
- type RTS_Lock is limited private;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the later one serves only as a semaphore so
- -- that do not check for ceiling violations.
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper
- -- declared local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
-private
- type Lock is record
- L : aliased System.OS_Interface.pthread_mutex_t;
- Priority : Integer;
- Owner_Priority : Integer;
- end record;
-
- type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased System.OS_Interface.pthread_mutex_t;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- type Private_Data is record
- Thread : aliased System.OS_Interface.pthread_t;
- -- pragma Atomic (Thread);
- -- Unfortunately, the above fails because Thread is 64 bits.
-
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the
- -- same value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they
- -- are updated in atomic fashion.
-
- CV : aliased System.OS_Interface.pthread_cond_t;
-
- L : aliased RTS_Lock;
- -- Protection for all components is lock L
- end record;
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-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- --
--- 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 LynxOS Family version of this package.
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with System.OS_Interface;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- -- Should be used for implementation of protected objects
-
- type RTS_Lock is limited private;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the latter serves only as a semaphore so that
- -- we do not check for ceiling violations.
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper declared
- -- local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := System.OS_Interface.Alternate_Stack_Size;
- -- Import value from System.OS_Interface
-
-private
-
- type Lock is record
- RW : aliased System.OS_Interface.pthread_rwlock_t;
- WO : aliased System.OS_Interface.pthread_mutex_t;
- end record;
-
- type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased System.OS_Interface.pthread_mutex_t;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- type Private_Data is limited record
- Thread : aliased System.OS_Interface.pthread_t;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
- -- value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they are
- -- updated in atomic fashion.
-
- LWP : aliased System.OS_Interface.pthread_t;
- -- The purpose of this field is to provide a better tasking support on
- -- gdb. The order of the two first fields (Thread and LWP) is important.
- -- On targets where lwp is not relevant, this is equivalent to Thread.
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Should be commented ??? (in all versions of taspri)
-
- L : aliased RTS_Lock;
- -- Protection for all components is lock L
- end record;
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-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 --
--- <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 a NT (native) version of this package
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with System.OS_Interface;
-with System.Win32;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- -- Should be used for implementation of protected objects
-
- type RTS_Lock is limited private;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the later one serves only as a semaphore so
- -- that do not check for ceiling violations.
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper
- -- declared local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
-private
-
- type Lock is record
- Mutex : aliased System.OS_Interface.CRITICAL_SECTION;
- Priority : Integer;
- Owner_Priority : Integer;
- end record;
-
- type Condition_Variable is new System.Win32.HANDLE;
-
- type RTS_Lock is new System.OS_Interface.CRITICAL_SECTION;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased System.OS_Interface.CRITICAL_SECTION;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased Win32.HANDLE;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- type Private_Data is limited record
- Thread : aliased Win32.HANDLE;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb).
- -- They put the same value (thr_self value). We do not want to
- -- use lock on those operations and the only thing we have to
- -- make sure is that they are updated in atomic fashion.
-
- Thread_Id : aliased Win32.DWORD;
- -- Used to provide a better tasking support in gdb
-
- CV : aliased Condition_Variable;
- -- Condition Variable used to implement Sleep/Wakeup
-
- L : aliased RTS_Lock;
- -- Protection for all components is lock L
- end record;
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-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- --
--- 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 a POSIX-like version of this package where no alternate stack
--- is needed for stack checking.
-
--- Note: this file can only be used for POSIX compliant systems
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with System.OS_Interface;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- -- Should be used for implementation of protected objects
-
- type RTS_Lock is limited private;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the later one serves only as a semaphore so
- -- that do not check for ceiling violations.
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper declared
- -- local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
-private
-
- type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
-
- type Lock is record
- WO : aliased RTS_Lock;
- RW : aliased System.OS_Interface.pthread_rwlock_t;
- end record;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased RTS_Lock;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- type Private_Data is limited record
- Thread : aliased System.OS_Interface.pthread_t;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
- -- value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they are
- -- updated in atomic fashion.
-
- LWP : aliased System.Address;
- -- The purpose of this field is to provide a better tasking support on
- -- gdb. The order of the two first fields (Thread and LWP) is important.
- -- On targets where lwp is not relevant, this is equivalent to Thread.
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Should be commented ??? (in all versions of taspri)
-
- L : aliased RTS_Lock;
- -- Protection for all components is lock L
- end record;
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2017, Florida State University --
--- Copyright (C) 1995-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- --
--- 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 a POSIX-like version of this package
-
--- Note: this file can only be used for POSIX compliant systems
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with System.OS_Interface;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- -- Should be used for implementation of protected objects
-
- type RTS_Lock is limited private;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the latter serves only as a semaphore so that
- -- we do not check for ceiling violations.
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper declared
- -- local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := System.OS_Interface.Alternate_Stack_Size;
- -- Import value from System.OS_Interface
-
-private
-
- type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
-
- type Lock is record
- RW : aliased System.OS_Interface.pthread_rwlock_t;
- WO : aliased RTS_Lock;
- end record;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased RTS_Lock;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- type Private_Data is limited record
- Thread : aliased System.OS_Interface.pthread_t;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
- -- value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they are
- -- updated in atomic fashion.
-
- LWP : aliased System.Address;
- -- The purpose of this field is to provide a better tasking support on
- -- gdb. The order of the two first fields (Thread and LWP) is important.
- -- On targets where lwp is not relevant, this is equivalent to Thread.
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Should be commented ??? (in all versions of taspri)
-
- L : aliased RTS_Lock;
- -- Protection for all components is lock L
- end record;
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 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 --
--- <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 a Solaris version of this package
-
--- This package provides low-level support for most tasking features
-
-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 System.OS_Interface;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- type Lock_Ptr is access all Lock;
- -- Should be used for implementation of protected objects
-
- type RTS_Lock is limited private;
- type RTS_Lock_Ptr is access all RTS_Lock;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the later one serves only as a semaphore so
- -- that do not check for ceiling violations.
-
- function To_Lock_Ptr is
- new Ada.Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr);
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper
- -- declared local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
-private
-
- type Private_Task_Serial_Number is mod 2 ** Long_Long_Integer'Size;
- -- Used to give each task a unique serial number
-
- type Base_Lock is new System.OS_Interface.mutex_t;
-
- type Owner_Int is new Integer;
- for Owner_Int'Alignment use Standard'Maximum_Alignment;
-
- type Owner_ID is access all Owner_Int;
-
- function To_Owner_ID is
- new Ada.Unchecked_Conversion (System.Address, Owner_ID);
-
- type Lock is record
- L : aliased Base_Lock;
- Ceiling : System.Any_Priority := System.Any_Priority'First;
- Saved_Priority : System.Any_Priority := System.Any_Priority'First;
- Owner : Owner_ID;
- Next : Lock_Ptr;
- Level : Private_Task_Serial_Number := 0;
- Buddy : Owner_ID;
- Frozen : Boolean := False;
- end record;
-
- type RTS_Lock is new Lock;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased System.OS_Interface.mutex_t;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased System.OS_Interface.cond_t;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- -- Note that task support on gdb relies on the fact that the first two
- -- fields of Private_Data are Thread and LWP.
-
- type Private_Data is limited record
- Thread : aliased System.OS_Interface.thread_t;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
- -- value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they are
- -- updated in atomic fashion.
-
- LWP : System.OS_Interface.lwpid_t;
- -- The LWP id of the thread. Set by self in Enter_Task
-
- CV : aliased System.OS_Interface.cond_t;
- L : aliased RTS_Lock;
- -- Protection for all components is lock L
-
- Active_Priority : System.Any_Priority := System.Any_Priority'First;
- -- Simulated active priority, used iff Priority_Ceiling_Support is True
-
- Locking : Lock_Ptr;
- Locks : Lock_Ptr;
- Wakeups : Natural := 0;
- end record;
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-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 --
--- <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 a VxWorks version of this package
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with System.OS_Interface;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- -- Should be used for implementation of protected objects
-
- type RTS_Lock is limited private;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the later one serves only as a semaphore so
- -- that do not check for ceiling violations.
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper
- -- declared local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
-private
-
- type Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit);
-
- type Lock is record
- Mutex : System.OS_Interface.SEM_ID;
- Protocol : Priority_Type;
-
- Prio_Ceiling : System.OS_Interface.int;
- -- Priority ceiling of lock
- end record;
-
- type RTS_Lock is new Lock;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased System.OS_Interface.SEM_ID;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased System.OS_Interface.SEM_ID;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- type Private_Data is limited record
- Thread : aliased System.OS_Interface.t_id := 0;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb).
- -- They put the same value (thr_self value). We do not want to
- -- use lock on those operations and the only thing we have to
- -- make sure is that they are updated in atomic fashion.
-
- LWP : aliased System.OS_Interface.t_id := 0;
- -- The purpose of this field is to provide a better tasking support on
- -- gdb. The order of the two first fields (Thread and LWP) is important.
- -- On targets where lwp is not relevant, this is equivalent to Thread.
-
- CV : aliased System.OS_Interface.SEM_ID;
-
- L : aliased RTS_Lock;
- -- Protection for all components is lock L
- end record;
-
-end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-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 --
+-- <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 a no tasking version of this package
+
+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.
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is new Integer;
+
+ type RTS_Lock is new Integer;
+
+ type Suspension_Object is new Integer;
+
+ type Task_Body_Access is access procedure;
+
+ type Private_Data is limited record
+ Thread : aliased Integer;
+ CV : aliased Integer;
+ L : aliased RTS_Lock;
+ end record;
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2014, 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 a HP-UX version of this package
+
+-- This package provides low-level support for most tasking features
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with System.OS_Interface;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the later one serves only as a semaphore so
+ -- that do not check for ceiling violations.
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+private
+ type Lock is record
+ L : aliased System.OS_Interface.pthread_mutex_t;
+ Priority : Integer;
+ Owner_Priority : Integer;
+ end record;
+
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased System.OS_Interface.pthread_mutex_t;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ type Private_Data is record
+ Thread : aliased System.OS_Interface.pthread_t;
+ -- pragma Atomic (Thread);
+ -- Unfortunately, the above fails because Thread is 64 bits.
+
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the
+ -- same value (thr_self value). We do not want to use lock on those
+ -- operations and the only thing we have to make sure is that they
+ -- are updated in atomic fashion.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-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- --
+-- 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 LynxOS Family version of this package.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with System.OS_Interface;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the latter serves only as a semaphore so that
+ -- we do not check for ceiling violations.
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper declared
+ -- local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := System.OS_Interface.Alternate_Stack_Size;
+ -- Import value from System.OS_Interface
+
+private
+
+ type Lock is record
+ RW : aliased System.OS_Interface.pthread_rwlock_t;
+ WO : aliased System.OS_Interface.pthread_mutex_t;
+ end record;
+
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased System.OS_Interface.pthread_mutex_t;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ type Private_Data is limited record
+ Thread : aliased System.OS_Interface.pthread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
+ -- value (thr_self value). We do not want to use lock on those
+ -- operations and the only thing we have to make sure is that they are
+ -- updated in atomic fashion.
+
+ LWP : aliased System.OS_Interface.pthread_t;
+ -- The purpose of this field is to provide a better tasking support on
+ -- gdb. The order of the two first fields (Thread and LWP) is important.
+ -- On targets where lwp is not relevant, this is equivalent to Thread.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Should be commented ??? (in all versions of taspri)
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-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 --
+-- <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 a NT (native) version of this package
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with System.OS_Interface;
+with System.Win32;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the later one serves only as a semaphore so
+ -- that do not check for ceiling violations.
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+private
+
+ type Lock is record
+ Mutex : aliased System.OS_Interface.CRITICAL_SECTION;
+ Priority : Integer;
+ Owner_Priority : Integer;
+ end record;
+
+ type Condition_Variable is new System.Win32.HANDLE;
+
+ type RTS_Lock is new System.OS_Interface.CRITICAL_SECTION;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased System.OS_Interface.CRITICAL_SECTION;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased Win32.HANDLE;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ type Private_Data is limited record
+ Thread : aliased Win32.HANDLE;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ Thread_Id : aliased Win32.DWORD;
+ -- Used to provide a better tasking support in gdb
+
+ CV : aliased Condition_Variable;
+ -- Condition Variable used to implement Sleep/Wakeup
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-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- --
+-- 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 a POSIX-like version of this package where no alternate stack
+-- is needed for stack checking.
+
+-- Note: this file can only be used for POSIX compliant systems
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with System.OS_Interface;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the later one serves only as a semaphore so
+ -- that do not check for ceiling violations.
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper declared
+ -- local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+private
+
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+
+ type Lock is record
+ WO : aliased RTS_Lock;
+ RW : aliased System.OS_Interface.pthread_rwlock_t;
+ end record;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased RTS_Lock;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ type Private_Data is limited record
+ Thread : aliased System.OS_Interface.pthread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
+ -- value (thr_self value). We do not want to use lock on those
+ -- operations and the only thing we have to make sure is that they are
+ -- updated in atomic fashion.
+
+ LWP : aliased System.Address;
+ -- The purpose of this field is to provide a better tasking support on
+ -- gdb. The order of the two first fields (Thread and LWP) is important.
+ -- On targets where lwp is not relevant, this is equivalent to Thread.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Should be commented ??? (in all versions of taspri)
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-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- --
+-- 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 a POSIX-like version of this package
+
+-- Note: this file can only be used for POSIX compliant systems
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with System.OS_Interface;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the latter serves only as a semaphore so that
+ -- we do not check for ceiling violations.
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper declared
+ -- local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := System.OS_Interface.Alternate_Stack_Size;
+ -- Import value from System.OS_Interface
+
+private
+
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+
+ type Lock is record
+ RW : aliased System.OS_Interface.pthread_rwlock_t;
+ WO : aliased RTS_Lock;
+ end record;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased RTS_Lock;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ type Private_Data is limited record
+ Thread : aliased System.OS_Interface.pthread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
+ -- value (thr_self value). We do not want to use lock on those
+ -- operations and the only thing we have to make sure is that they are
+ -- updated in atomic fashion.
+
+ LWP : aliased System.Address;
+ -- The purpose of this field is to provide a better tasking support on
+ -- gdb. The order of the two first fields (Thread and LWP) is important.
+ -- On targets where lwp is not relevant, this is equivalent to Thread.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Should be commented ??? (in all versions of taspri)
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 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 --
+-- <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 a Solaris version of this package
+
+-- This package provides low-level support for most tasking features
+
+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 System.OS_Interface;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ type Lock_Ptr is access all Lock;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ type RTS_Lock_Ptr is access all RTS_Lock;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the later one serves only as a semaphore so
+ -- that do not check for ceiling violations.
+
+ function To_Lock_Ptr is
+ new Ada.Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr);
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+private
+
+ type Private_Task_Serial_Number is mod 2 ** Long_Long_Integer'Size;
+ -- Used to give each task a unique serial number
+
+ type Base_Lock is new System.OS_Interface.mutex_t;
+
+ type Owner_Int is new Integer;
+ for Owner_Int'Alignment use Standard'Maximum_Alignment;
+
+ type Owner_ID is access all Owner_Int;
+
+ function To_Owner_ID is
+ new Ada.Unchecked_Conversion (System.Address, Owner_ID);
+
+ type Lock is record
+ L : aliased Base_Lock;
+ Ceiling : System.Any_Priority := System.Any_Priority'First;
+ Saved_Priority : System.Any_Priority := System.Any_Priority'First;
+ Owner : Owner_ID;
+ Next : Lock_Ptr;
+ Level : Private_Task_Serial_Number := 0;
+ Buddy : Owner_ID;
+ Frozen : Boolean := False;
+ end record;
+
+ type RTS_Lock is new Lock;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased System.OS_Interface.mutex_t;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased System.OS_Interface.cond_t;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ -- Note that task support on gdb relies on the fact that the first two
+ -- fields of Private_Data are Thread and LWP.
+
+ type Private_Data is limited record
+ Thread : aliased System.OS_Interface.thread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
+ -- value (thr_self value). We do not want to use lock on those
+ -- operations and the only thing we have to make sure is that they are
+ -- updated in atomic fashion.
+
+ LWP : System.OS_Interface.lwpid_t;
+ -- The LWP id of the thread. Set by self in Enter_Task
+
+ CV : aliased System.OS_Interface.cond_t;
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+
+ Active_Priority : System.Any_Priority := System.Any_Priority'First;
+ -- Simulated active priority, used iff Priority_Ceiling_Support is True
+
+ Locking : Lock_Ptr;
+ Locks : Lock_Ptr;
+ Wakeups : Natural := 0;
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2001-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 --
+-- <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 a VxWorks version of this package
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with System.OS_Interface;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the later one serves only as a semaphore so
+ -- that do not check for ceiling violations.
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+private
+
+ type Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit);
+
+ type Lock is record
+ Mutex : System.OS_Interface.SEM_ID;
+ Protocol : Priority_Type;
+
+ Prio_Ceiling : System.OS_Interface.int;
+ -- Priority ceiling of lock
+ end record;
+
+ type RTS_Lock is new Lock;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased System.OS_Interface.SEM_ID;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased System.OS_Interface.SEM_ID;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ type Private_Data is limited record
+ Thread : aliased System.OS_Interface.t_id := 0;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ LWP : aliased System.OS_Interface.t_id := 0;
+ -- The purpose of this field is to provide a better tasking support on
+ -- gdb. The order of the two first fields (Thread and LWP) is important.
+ -- On targets where lwp is not relevant, this is equivalent to Thread.
+
+ CV : aliased System.OS_Interface.SEM_ID;
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
--- --
--- 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 --
--- <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 a POSIX version of this package where foreign threads are
--- recognized.
-
-separate (System.Task_Primitives.Operations)
-package body Specific is
-
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_Id associated with a thread
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- pragma Warnings (Off, Environment_Task);
- Result : Interfaces.C.int;
-
- begin
- Result := pthread_key_create (ATCB_Key'Access, null);
- pragma Assert (Result = 0);
- end Initialize;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- begin
- return pthread_getspecific (ATCB_Key) /= System.Null_Address;
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
- pragma Assert (Result = 0);
- end Set;
-
- ----------
- -- Self --
- ----------
-
- -- To make Ada tasks and C threads interoperate better, we have added some
- -- functionality to Self. Suppose a C main program (with threads) calls an
- -- Ada procedure and the Ada procedure calls the tasking runtime system.
- -- Eventually, a call will be made to self. Since the call is not coming
- -- from an Ada task, there will be no corresponding ATCB.
-
- -- What we do in Self is to catch references that do not come from
- -- recognized Ada tasks, and create an ATCB for the calling thread.
-
- -- The new ATCB will be "detached" from the normal Ada task master
- -- hierarchy, much like the existing implicitly created signal-server
- -- tasks.
-
- function Self return Task_Id is
- Result : System.Address;
-
- begin
- Result := pthread_getspecific (ATCB_Key);
-
- -- If the key value is Null then it is a non-Ada task
-
- if Result /= System.Null_Address then
- return To_Task_Id (Result);
- else
- return Register_Foreign_Thread;
- end if;
- end Self;
-
-end Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
--- --
--- 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 --
--- <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 a POSIX-like version of this package
-
-separate (System.Task_Primitives.Operations)
-package body Specific is
-
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_Id associated with a thread
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- pragma Warnings (Off, Environment_Task);
- Result : Interfaces.C.int;
- begin
- Result := pthread_key_create (ATCB_Key'Access, null);
- pragma Assert (Result = 0);
- end Initialize;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- begin
- return pthread_getspecific (ATCB_Key) /= System.Null_Address;
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
- pragma Assert (Result = 0);
- end Set;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_Id is
- begin
- return To_Task_Id (pthread_getspecific (ATCB_Key));
- end Self;
-
-end Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
--- --
--- 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 --
--- <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 a version for Solaris native threads
-
-separate (System.Task_Primitives.Operations)
-package body Specific is
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- pragma Unreferenced (Environment_Task);
- Result : Interfaces.C.int;
- begin
- Result := thr_keycreate (ATCB_Key'Access, System.Null_Address);
- pragma Assert (Result = 0);
- end Initialize;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- Unknown_Task : aliased System.Address;
- Result : Interfaces.C.int;
- begin
- Result := thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access);
- pragma Assert (Result = 0);
- return Unknown_Task /= System.Null_Address;
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- Result : Interfaces.C.int;
- begin
- Result := thr_setspecific (ATCB_Key, To_Address (Self_Id));
- pragma Assert (Result = 0);
- end Set;
-
- ----------
- -- Self --
- ----------
-
- -- To make Ada tasks and C threads interoperate better, we have
- -- added some functionality to Self. Suppose a C main program
- -- (with threads) calls an Ada procedure and the Ada procedure
- -- calls the tasking run-time system. Eventually, a call will be
- -- made to self. Since the call is not coming from an Ada task,
- -- there will be no corresponding ATCB.
-
- -- What we do in Self is to catch references that do not come
- -- from recognized Ada tasks, and create an ATCB for the calling
- -- thread.
-
- -- The new ATCB will be "detached" from the normal Ada task
- -- master hierarchy, much like the existing implicitly created
- -- signal-server tasks.
-
- function Self return Task_Id is
- Result : Interfaces.C.int;
- Self_Id : aliased System.Address;
- begin
- Result := thr_getspecific (ATCB_Key, Self_Id'Unchecked_Access);
- pragma Assert (Result = 0);
-
- if Self_Id = System.Null_Address then
- return Register_Foreign_Thread;
- else
- return To_Task_Id (Self_Id);
- end if;
- end Self;
-
-end Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
--- --
--- 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 --
--- <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 a version of this package using TLS and where foreign threads are
--- recognized.
-
-separate (System.Task_Primitives.Operations)
-package body Specific is
-
- ATCB : aliased Task_Id := null;
- pragma Thread_Local_Storage (ATCB);
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- begin
- ATCB := Environment_Task;
- end Initialize;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- begin
- return ATCB /= null;
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- begin
- ATCB := Self_Id;
- end Set;
-
- ----------
- -- Self --
- ----------
-
- -- To make Ada tasks and C threads interoperate better, we have added some
- -- functionality to Self. Suppose a C main program (with threads) calls an
- -- Ada procedure and the Ada procedure calls the tasking runtime system.
- -- Eventually, a call will be made to self. Since the call is not coming
- -- from an Ada task, there will be no corresponding ATCB.
-
- -- What we do in Self is to catch references that do not come from
- -- recognized Ada tasks, and create an ATCB for the calling thread.
-
- -- The new ATCB will be "detached" from the normal Ada task master
- -- hierarchy, much like the existing implicitly created signal-server
- -- tasks.
-
- function Self return Task_Id is
- Result : constant Task_Id := ATCB;
- begin
- if Result /= null then
- return Result;
- else
- -- If the value is Null then it is a non-Ada task
-
- return Register_Foreign_Thread;
- end if;
- end Self;
-
-end Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-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 --
--- <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 a VxWorks version of this package using Thread_Local_Storage
--- support (VxWorks 6.6 and higher). The implementation is based on __threads
--- support.
-
-separate (System.Task_Primitives.Operations)
-package body Specific is
-
- ATCB : aliased Task_Id := null;
- -- Ada Task_Id associated with a thread
- pragma Thread_Local_Storage (ATCB);
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- null;
- end Initialize;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- begin
- return ATCB /= Null_Task;
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- begin
- ATCB := Self_Id;
- end Set;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_Id is
- begin
- return ATCB;
- end Self;
-
-end Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
--- --
--- 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 --
--- <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 a VxWorks version of this package where foreign threads are
--- recognized. The implementation is based on VxWorks taskVarLib.
-
-separate (System.Task_Primitives.Operations)
-package body Specific is
-
- ATCB_Key : aliased System.Address := System.Null_Address;
- -- Key used to find the Ada Task_Id associated with a thread
-
- ATCB_Key_Addr : System.Address := ATCB_Key'Address;
- pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr");
- -- Exported to support the temporary AE653 task registration
- -- implementation. This mechanism is used to minimize impact on other
- -- targets.
-
- Stack_Limit : aliased System.Address;
-
- pragma Import (C, Stack_Limit, "__gnat_stack_limit");
-
- type Set_Stack_Limit_Proc_Acc is access procedure;
- pragma Convention (C, Set_Stack_Limit_Proc_Acc);
-
- Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
- pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
- -- Procedure to be called when a task is created to set stack limit if
- -- limit checking is used.
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- null;
- end Initialize;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- begin
- return taskVarGet (taskIdSelf, ATCB_Key'Access) /= ERROR;
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- Result : STATUS;
-
- begin
- -- If argument is null, destroy task specific data, to make API
- -- consistent with other platforms, and thus compatible with the
- -- shared version of s-tpoaal.adb.
-
- if Self_Id = null then
- Result := taskVarDelete (taskIdSelf, ATCB_Key'Access);
- pragma Assert (Result /= ERROR);
- return;
- end if;
-
- if not Is_Valid_Task then
- Result := taskVarAdd (Self_Id.Common.LL.Thread, ATCB_Key'Access);
- pragma Assert (Result = OK);
-
- if Stack_Check_Limits
- and then Result /= ERROR
- and then Set_Stack_Limit_Hook /= null
- then
- -- This will be initialized from taskInfoGet() once the task is
- -- is running.
-
- Result :=
- taskVarAdd (Self_Id.Common.LL.Thread, Stack_Limit'Access);
- pragma Assert (Result /= ERROR);
- end if;
- end if;
-
- Result :=
- taskVarSet
- (Self_Id.Common.LL.Thread,
- ATCB_Key'Access,
- To_Address (Self_Id));
- pragma Assert (Result /= ERROR);
- end Set;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_Id is
- begin
- return To_Task_Id (ATCB_Key);
- end Self;
-
-end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- 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 --
+-- <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 a POSIX version of this package where foreign threads are
+-- recognized.
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_Id associated with a thread
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ pragma Warnings (Off, Environment_Task);
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_key_create (ATCB_Key'Access, null);
+ pragma Assert (Result = 0);
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return pthread_getspecific (ATCB_Key) /= System.Null_Address;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
+ pragma Assert (Result = 0);
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ -- To make Ada tasks and C threads interoperate better, we have added some
+ -- functionality to Self. Suppose a C main program (with threads) calls an
+ -- Ada procedure and the Ada procedure calls the tasking runtime system.
+ -- Eventually, a call will be made to self. Since the call is not coming
+ -- from an Ada task, there will be no corresponding ATCB.
+
+ -- What we do in Self is to catch references that do not come from
+ -- recognized Ada tasks, and create an ATCB for the calling thread.
+
+ -- The new ATCB will be "detached" from the normal Ada task master
+ -- hierarchy, much like the existing implicitly created signal-server
+ -- tasks.
+
+ function Self return Task_Id is
+ Result : System.Address;
+
+ begin
+ Result := pthread_getspecific (ATCB_Key);
+
+ -- If the key value is Null then it is a non-Ada task
+
+ if Result /= System.Null_Address then
+ return To_Task_Id (Result);
+ else
+ return Register_Foreign_Thread;
+ end if;
+ end Self;
+
+end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- 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 --
+-- <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 a POSIX-like version of this package
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_Id associated with a thread
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ pragma Warnings (Off, Environment_Task);
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_key_create (ATCB_Key'Access, null);
+ pragma Assert (Result = 0);
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return pthread_getspecific (ATCB_Key) /= System.Null_Address;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
+ pragma Assert (Result = 0);
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id is
+ begin
+ return To_Task_Id (pthread_getspecific (ATCB_Key));
+ end Self;
+
+end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- 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 --
+-- <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 a version for Solaris native threads
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ pragma Unreferenced (Environment_Task);
+ Result : Interfaces.C.int;
+ begin
+ Result := thr_keycreate (ATCB_Key'Access, System.Null_Address);
+ pragma Assert (Result = 0);
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ Unknown_Task : aliased System.Address;
+ Result : Interfaces.C.int;
+ begin
+ Result := thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return Unknown_Task /= System.Null_Address;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ Result := thr_setspecific (ATCB_Key, To_Address (Self_Id));
+ pragma Assert (Result = 0);
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ -- To make Ada tasks and C threads interoperate better, we have
+ -- added some functionality to Self. Suppose a C main program
+ -- (with threads) calls an Ada procedure and the Ada procedure
+ -- calls the tasking run-time system. Eventually, a call will be
+ -- made to self. Since the call is not coming from an Ada task,
+ -- there will be no corresponding ATCB.
+
+ -- What we do in Self is to catch references that do not come
+ -- from recognized Ada tasks, and create an ATCB for the calling
+ -- thread.
+
+ -- The new ATCB will be "detached" from the normal Ada task
+ -- master hierarchy, much like the existing implicitly created
+ -- signal-server tasks.
+
+ function Self return Task_Id is
+ Result : Interfaces.C.int;
+ Self_Id : aliased System.Address;
+ begin
+ Result := thr_getspecific (ATCB_Key, Self_Id'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ if Self_Id = System.Null_Address then
+ return Register_Foreign_Thread;
+ else
+ return To_Task_Id (Self_Id);
+ end if;
+ end Self;
+
+end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- 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 --
+-- <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 a version of this package using TLS and where foreign threads are
+-- recognized.
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ATCB : aliased Task_Id := null;
+ pragma Thread_Local_Storage (ATCB);
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ begin
+ ATCB := Environment_Task;
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return ATCB /= null;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ begin
+ ATCB := Self_Id;
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ -- To make Ada tasks and C threads interoperate better, we have added some
+ -- functionality to Self. Suppose a C main program (with threads) calls an
+ -- Ada procedure and the Ada procedure calls the tasking runtime system.
+ -- Eventually, a call will be made to self. Since the call is not coming
+ -- from an Ada task, there will be no corresponding ATCB.
+
+ -- What we do in Self is to catch references that do not come from
+ -- recognized Ada tasks, and create an ATCB for the calling thread.
+
+ -- The new ATCB will be "detached" from the normal Ada task master
+ -- hierarchy, much like the existing implicitly created signal-server
+ -- tasks.
+
+ function Self return Task_Id is
+ Result : constant Task_Id := ATCB;
+ begin
+ if Result /= null then
+ return Result;
+ else
+ -- If the value is Null then it is a non-Ada task
+
+ return Register_Foreign_Thread;
+ end if;
+ end Self;
+
+end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-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 --
+-- <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 a VxWorks version of this package using Thread_Local_Storage
+-- support (VxWorks 6.6 and higher). The implementation is based on __threads
+-- support.
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ATCB : aliased Task_Id := null;
+ -- Ada Task_Id associated with a thread
+ pragma Thread_Local_Storage (ATCB);
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return ATCB /= Null_Task;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ begin
+ ATCB := Self_Id;
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id is
+ begin
+ return ATCB;
+ end Self;
+
+end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- 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 --
+-- <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 a VxWorks version of this package where foreign threads are
+-- recognized. The implementation is based on VxWorks taskVarLib.
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ATCB_Key : aliased System.Address := System.Null_Address;
+ -- Key used to find the Ada Task_Id associated with a thread
+
+ ATCB_Key_Addr : System.Address := ATCB_Key'Address;
+ pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr");
+ -- Exported to support the temporary AE653 task registration
+ -- implementation. This mechanism is used to minimize impact on other
+ -- targets.
+
+ Stack_Limit : aliased System.Address;
+
+ pragma Import (C, Stack_Limit, "__gnat_stack_limit");
+
+ type Set_Stack_Limit_Proc_Acc is access procedure;
+ pragma Convention (C, Set_Stack_Limit_Proc_Acc);
+
+ Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
+ pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
+ -- Procedure to be called when a task is created to set stack limit if
+ -- limit checking is used.
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return taskVarGet (taskIdSelf, ATCB_Key'Access) /= ERROR;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ Result : STATUS;
+
+ begin
+ -- If argument is null, destroy task specific data, to make API
+ -- consistent with other platforms, and thus compatible with the
+ -- shared version of s-tpoaal.adb.
+
+ if Self_Id = null then
+ Result := taskVarDelete (taskIdSelf, ATCB_Key'Access);
+ pragma Assert (Result /= ERROR);
+ return;
+ end if;
+
+ if not Is_Valid_Task then
+ Result := taskVarAdd (Self_Id.Common.LL.Thread, ATCB_Key'Access);
+ pragma Assert (Result = OK);
+
+ if Stack_Check_Limits
+ and then Result /= ERROR
+ and then Set_Stack_Limit_Hook /= null
+ then
+ -- This will be initialized from taskInfoGet() once the task is
+ -- is running.
+
+ Result :=
+ taskVarAdd (Self_Id.Common.LL.Thread, Stack_Limit'Access);
+ pragma Assert (Result /= ERROR);
+ end if;
+ end if;
+
+ Result :=
+ taskVarSet
+ (Self_Id.Common.LL.Thread,
+ ATCB_Key'Access,
+ To_Address (Self_Id));
+ pragma Assert (Result /= ERROR);
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id is
+ begin
+ return To_Task_Id (ATCB_Key);
+ end Self;
+
+end Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S . E X T --
--- --
--- B o d y --
--- --
--- Copyright (C) 2008-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides vxworks specific support functions needed
--- by System.OS_Interface.
-
--- This is the VxWorks <= 6.5 kernel version of this package
--- Also works for 6.6 uniprocessor
-
-package body System.VxWorks.Ext is
-
- ERROR : constant := -1;
-
- --------------
- -- Int_Lock --
- --------------
-
- function intLock return int;
- pragma Import (C, intLock, "intLock");
-
- function Int_Lock return int renames intLock;
-
- ----------------
- -- Int_Unlock --
- ----------------
-
- function intUnlock (Old : int) return int;
- pragma Import (C, intUnlock, "intUnlock");
-
- function Int_Unlock (Old : int) return int renames intUnlock;
-
- ---------------
- -- semDelete --
- ---------------
-
- function semDelete (Sem : SEM_ID) return int is
- function Os_Sem_Delete (Sem : SEM_ID) return int;
- pragma Import (C, Os_Sem_Delete, "semDelete");
- begin
- return Os_Sem_Delete (Sem);
- end semDelete;
-
- ------------------------
- -- taskCpuAffinitySet --
- ------------------------
-
- function taskCpuAffinitySet (tid : t_id; CPU : int) return int is
- pragma Unreferenced (tid, CPU);
- begin
- return ERROR;
- end taskCpuAffinitySet;
-
- -------------------------
- -- taskMaskAffinitySet --
- -------------------------
-
- function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is
- pragma Unreferenced (tid, CPU_Set);
- begin
- return ERROR;
- end taskMaskAffinitySet;
-
- --------------
- -- taskCont --
- --------------
-
- function Task_Cont (tid : t_id) return int is
- function taskCont (tid : t_id) return int;
- pragma Import (C, taskCont, "taskCont");
- begin
- return taskCont (tid);
- end Task_Cont;
-
- --------------
- -- taskStop --
- --------------
-
- function Task_Stop (tid : t_id) return int is
- function taskStop (tid : t_id) return int;
- pragma Import (C, taskStop, "taskStop");
- begin
- return taskStop (tid);
- end Task_Stop;
-
-end System.VxWorks.Ext;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S . E X T --
--- --
--- S p e c --
--- --
--- Copyright (C) 2008-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides vxworks specific support functions needed
--- by System.OS_Interface.
-
--- This is the VxWorks 6 kernel version of this package
-
-with Interfaces.C;
-
-package System.VxWorks.Ext is
- pragma Preelaborate;
-
- subtype SEM_ID is Long_Integer;
- -- typedef struct semaphore *SEM_ID;
-
- type sigset_t is mod 2 ** Long_Long_Integer'Size;
-
- type t_id is new Long_Integer;
- subtype int is Interfaces.C.int;
- subtype unsigned is Interfaces.C.unsigned;
-
- type Interrupt_Handler is access procedure (parameter : System.Address);
- pragma Convention (C, Interrupt_Handler);
-
- type Interrupt_Vector is new System.Address;
-
- function Int_Lock return int;
- pragma Convention (C, Int_Lock);
-
- function Int_Unlock (Old : int) return int;
- pragma Convention (C, Int_Unlock);
-
- function Interrupt_Connect
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler;
- Parameter : System.Address := System.Null_Address) return int;
- pragma Import (C, Interrupt_Connect, "intConnect");
-
- function Interrupt_Context return int;
- pragma Import (C, Interrupt_Context, "intContext");
-
- function Interrupt_Number_To_Vector
- (intNum : int) return Interrupt_Vector;
- pragma Import (C, Interrupt_Number_To_Vector, "__gnat_inum_to_ivec");
-
- function semDelete (Sem : SEM_ID) return int;
- pragma Convention (C, semDelete);
-
- function Task_Cont (tid : t_id) return int;
- pragma Convention (C, Task_Cont);
-
- function Task_Stop (tid : t_id) return int;
- pragma Convention (C, Task_Stop);
-
- function kill (pid : t_id; sig : int) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return t_id;
- pragma Import (C, getpid, "taskIdSelf");
-
- function Set_Time_Slice (ticks : int) return int;
- pragma Import (C, Set_Time_Slice, "kernelTimeSlice");
-
- type UINT64 is mod 2 ** Long_Long_Integer'Size;
-
- function tickGet return UINT64;
- -- Needed for ravenscar-cert
- pragma Import (C, tickGet, "tick64Get");
-
- --------------------------------
- -- Processor Affinity for SMP --
- --------------------------------
-
- function taskCpuAffinitySet (tid : t_id; CPU : int) return int;
- pragma Convention (C, taskCpuAffinitySet);
- -- For SMP run-times set the CPU affinity.
- -- For uniprocessor systems return ERROR status.
-
- function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int;
- pragma Convention (C, taskMaskAffinitySet);
- -- For SMP run-times set the CPU mask affinity.
- -- For uniprocessor systems return ERROR status.
-
-end System.VxWorks.Ext;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S . E X T --
--- --
--- B o d y --
--- --
--- Copyright (C) 2008-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides VxWorks specific support functions needed
--- by System.OS_Interface.
-
--- This is the VxWorks 6 RTP/SMP version of this package
-
-package body System.VxWorks.Ext is
-
- ERROR : constant := -1;
-
- --------------
- -- Int_Lock --
- --------------
-
- function Int_Lock return int is
- begin
- return ERROR;
- end Int_Lock;
-
- ----------------
- -- Int_Unlock --
- ----------------
-
- function Int_Unlock (Old : int) return int is
- pragma Unreferenced (Old);
- begin
- return ERROR;
- end Int_Unlock;
-
- -----------------------
- -- Interrupt_Connect --
- -----------------------
-
- function Interrupt_Connect
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler;
- Parameter : System.Address := System.Null_Address) return int
- is
- pragma Unreferenced (Vector, Handler, Parameter);
- begin
- return ERROR;
- end Interrupt_Connect;
-
- -----------------------
- -- Interrupt_Context --
- -----------------------
-
- function Interrupt_Context return int is
- begin
- -- For RTPs, never in an interrupt context
-
- return 0;
- end Interrupt_Context;
-
- --------------------------------
- -- Interrupt_Number_To_Vector --
- --------------------------------
-
- function Interrupt_Number_To_Vector
- (intNum : int) return Interrupt_Vector
- is
- pragma Unreferenced (intNum);
- begin
- return 0;
- end Interrupt_Number_To_Vector;
-
- ---------------
- -- semDelete --
- ---------------
-
- function semDelete (Sem : SEM_ID) return int is
- function OS_semDelete (Sem : SEM_ID) return int;
- pragma Import (C, OS_semDelete, "semDelete");
- begin
- return OS_semDelete (Sem);
- end semDelete;
-
- --------------------
- -- Set_Time_Slice --
- --------------------
-
- function Set_Time_Slice (ticks : int) return int is
- pragma Unreferenced (ticks);
- begin
- return ERROR;
- end Set_Time_Slice;
-
- ------------------------
- -- taskCpuAffinitySet --
- ------------------------
-
- function taskCpuAffinitySet (tid : t_id; CPU : int) return int
- is
- function Set_Affinity (tid : t_id; CPU : int) return int;
- pragma Import (C, Set_Affinity, "__gnat_set_affinity");
- begin
- return Set_Affinity (tid, CPU);
- end taskCpuAffinitySet;
-
- -------------------------
- -- taskMaskAffinitySet --
- -------------------------
-
- function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is
- function Set_Affinity (tid : t_id; CPU_Set : unsigned) return int;
- pragma Import (C, Set_Affinity, "__gnat_set_affinity_mask");
- begin
- return Set_Affinity (tid, CPU_Set);
- end taskMaskAffinitySet;
-
-end System.VxWorks.Ext;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S . E X T --
--- --
--- B o d y --
--- --
--- Copyright (C) 2008-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides VxWorks specific support functions needed
--- by System.OS_Interface.
-
--- This is the VxWorks 6 RTP version of this package
-
-package body System.VxWorks.Ext is
-
- ERROR : constant := -1;
-
- --------------
- -- Int_Lock --
- --------------
-
- function Int_Lock return int is
- begin
- return ERROR;
- end Int_Lock;
-
- ----------------
- -- Int_Unlock --
- ----------------
-
- function Int_Unlock (Old : int) return int is
- pragma Unreferenced (Old);
- begin
- return ERROR;
- end Int_Unlock;
-
- -----------------------
- -- Interrupt_Connect --
- -----------------------
-
- function Interrupt_Connect
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler;
- Parameter : System.Address := System.Null_Address) return int
- is
- pragma Unreferenced (Vector, Handler, Parameter);
- begin
- return ERROR;
- end Interrupt_Connect;
-
- -----------------------
- -- Interrupt_Context --
- -----------------------
-
- function Interrupt_Context return int is
- begin
- -- For RTPs, never in an interrupt context
-
- return 0;
- end Interrupt_Context;
-
- --------------------------------
- -- Interrupt_Number_To_Vector --
- --------------------------------
-
- function Interrupt_Number_To_Vector
- (intNum : int) return Interrupt_Vector
- is
- pragma Unreferenced (intNum);
- begin
- return 0;
- end Interrupt_Number_To_Vector;
-
- ---------------
- -- semDelete --
- ---------------
-
- function semDelete (Sem : SEM_ID) return int is
- function OS_semDelete (Sem : SEM_ID) return int;
- pragma Import (C, OS_semDelete, "semDelete");
- begin
- return OS_semDelete (Sem);
- end semDelete;
-
- --------------------
- -- Set_Time_Slice --
- --------------------
-
- function Set_Time_Slice (ticks : int) return int is
- pragma Unreferenced (ticks);
- begin
- return ERROR;
- end Set_Time_Slice;
-
- ------------------------
- -- taskCpuAffinitySet --
- ------------------------
-
- function taskCpuAffinitySet (tid : t_id; CPU : int) return int is
- pragma Unreferenced (tid, CPU);
- begin
- return ERROR;
- end taskCpuAffinitySet;
-
- -------------------------
- -- taskMaskAffinitySet --
- -------------------------
-
- function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is
- pragma Unreferenced (tid, CPU_Set);
- begin
- return ERROR;
- end taskMaskAffinitySet;
-
-end System.VxWorks.Ext;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S . E X T --
--- --
--- S p e c --
--- --
--- Copyright (C) 2008-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides vxworks specific support functions needed
--- by System.OS_Interface.
-
--- This is the VxWorks 6 RTP version of this package
-
-with Interfaces.C;
-
-package System.VxWorks.Ext is
- pragma Preelaborate;
-
- subtype SEM_ID is Long_Integer;
- -- typedef struct semaphore *SEM_ID;
-
- type sigset_t is mod 2 ** Long_Long_Integer'Size;
-
- type t_id is new Long_Integer;
- subtype int is Interfaces.C.int;
- subtype unsigned is Interfaces.C.unsigned;
-
- type Interrupt_Handler is access procedure (parameter : System.Address);
- pragma Convention (C, Interrupt_Handler);
-
- type Interrupt_Vector is new System.Address;
-
- function Int_Lock return int;
- pragma Inline (Int_Lock);
-
- function Int_Unlock (Old : int) return int;
- pragma Inline (Int_Unlock);
-
- function Interrupt_Connect
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler;
- Parameter : System.Address := System.Null_Address) return int;
- pragma Convention (C, Interrupt_Connect);
-
- function Interrupt_Context return int;
- pragma Convention (C, Interrupt_Context);
-
- function Interrupt_Number_To_Vector
- (intNum : int) return Interrupt_Vector;
- pragma Convention (C, Interrupt_Number_To_Vector);
-
- function semDelete (Sem : SEM_ID) return int;
- pragma Convention (C, semDelete);
-
- function Task_Cont (tid : t_id) return int;
- pragma Import (C, Task_Cont, "taskResume");
-
- function Task_Stop (tid : t_id) return int;
- pragma Import (C, Task_Stop, "taskSuspend");
-
- function kill (pid : t_id; sig : int) return int;
- pragma Import (C, kill, "taskKill");
-
- function getpid return t_id;
- pragma Import (C, getpid, "getpid");
-
- function Set_Time_Slice (ticks : int) return int;
- pragma Inline (Set_Time_Slice);
-
- --------------------------------
- -- Processor Affinity for SMP --
- --------------------------------
-
- function taskCpuAffinitySet (tid : t_id; CPU : int) return int;
- pragma Convention (C, taskCpuAffinitySet);
- -- For SMP run-times set the CPU affinity.
- -- For uniprocessor systems return ERROR status.
-
- function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int;
- pragma Convention (C, taskMaskAffinitySet);
- -- For SMP run-times set the CPU mask affinity.
- -- For uniprocessor systems return ERROR status.
-
-end System.VxWorks.Ext;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S . E X T --
--- --
--- S p e c --
--- --
--- Copyright (C) 2008-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides VxWorks specific support functions needed
--- by System.OS_Interface.
-
--- This is the VxWorks 653 vThreads version of this package
-
-with Interfaces.C;
-
-package System.VxWorks.Ext is
- pragma Preelaborate;
-
- subtype SEM_ID is Long_Integer;
- -- typedef struct semaphore *SEM_ID;
-
- type sigset_t is mod 2 ** Interfaces.C.long'Size;
-
- type t_id is new Long_Integer;
- subtype int is Interfaces.C.int;
- subtype unsigned is Interfaces.C.unsigned;
-
- type Interrupt_Handler is access procedure (parameter : System.Address);
- pragma Convention (C, Interrupt_Handler);
-
- type Interrupt_Vector is new System.Address;
- function Int_Lock return int;
- pragma Inline (Int_Lock);
-
- function Int_Unlock (Old : int) return int;
- pragma Inline (Int_Unlock);
-
- function Interrupt_Connect
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler;
- Parameter : System.Address := System.Null_Address) return int;
- pragma Convention (C, Interrupt_Connect);
-
- function Interrupt_Context return int;
- pragma Convention (C, Interrupt_Context);
-
- function Interrupt_Number_To_Vector
- (intNum : int) return Interrupt_Vector;
- pragma Convention (C, Interrupt_Number_To_Vector);
-
- function semDelete (Sem : SEM_ID) return int;
- pragma Convention (C, semDelete);
-
- function Task_Cont (tid : t_id) return int;
- pragma Import (C, Task_Cont, "taskResume");
-
- function Task_Stop (tid : t_id) return int;
- pragma Import (C, Task_Stop, "taskSuspend");
-
- function kill (pid : t_id; sig : int) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return t_id;
- pragma Import (C, getpid, "taskIdSelf");
-
- function Set_Time_Slice (ticks : int) return int;
- pragma Import (C, Set_Time_Slice, "kernelTimeSlice");
-
- type UINT64 is mod 2 ** Long_Long_Integer'Size;
-
- function tickGet return UINT64;
- -- "tickGet" not available for cert vThreads:
- pragma Import (C, tickGet, "tick64Get");
-
- --------------------------------
- -- Processor Affinity for SMP --
- --------------------------------
-
- function taskCpuAffinitySet (tid : t_id; CPU : int) return int;
- pragma Convention (C, taskCpuAffinitySet);
- -- For SMP run-times set the CPU affinity.
- -- For uniprocessor systems return ERROR status.
-
- function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int;
- pragma Convention (C, taskMaskAffinitySet);
- -- For SMP run-times set the CPU mask affinity.
- -- For uniprocessor systems return ERROR status.
-
-end System.VxWorks.Ext;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2008-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides vxworks specific support functions needed
+-- by System.OS_Interface.
+
+-- This is the VxWorks <= 6.5 kernel version of this package
+-- Also works for 6.6 uniprocessor
+
+package body System.VxWorks.Ext is
+
+ ERROR : constant := -1;
+
+ --------------
+ -- Int_Lock --
+ --------------
+
+ function intLock return int;
+ pragma Import (C, intLock, "intLock");
+
+ function Int_Lock return int renames intLock;
+
+ ----------------
+ -- Int_Unlock --
+ ----------------
+
+ function intUnlock (Old : int) return int;
+ pragma Import (C, intUnlock, "intUnlock");
+
+ function Int_Unlock (Old : int) return int renames intUnlock;
+
+ ---------------
+ -- semDelete --
+ ---------------
+
+ function semDelete (Sem : SEM_ID) return int is
+ function Os_Sem_Delete (Sem : SEM_ID) return int;
+ pragma Import (C, Os_Sem_Delete, "semDelete");
+ begin
+ return Os_Sem_Delete (Sem);
+ end semDelete;
+
+ ------------------------
+ -- taskCpuAffinitySet --
+ ------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int is
+ pragma Unreferenced (tid, CPU);
+ begin
+ return ERROR;
+ end taskCpuAffinitySet;
+
+ -------------------------
+ -- taskMaskAffinitySet --
+ -------------------------
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is
+ pragma Unreferenced (tid, CPU_Set);
+ begin
+ return ERROR;
+ end taskMaskAffinitySet;
+
+ --------------
+ -- taskCont --
+ --------------
+
+ function Task_Cont (tid : t_id) return int is
+ function taskCont (tid : t_id) return int;
+ pragma Import (C, taskCont, "taskCont");
+ begin
+ return taskCont (tid);
+ end Task_Cont;
+
+ --------------
+ -- taskStop --
+ --------------
+
+ function Task_Stop (tid : t_id) return int is
+ function taskStop (tid : t_id) return int;
+ pragma Import (C, taskStop, "taskStop");
+ begin
+ return taskStop (tid);
+ end Task_Stop;
+
+end System.VxWorks.Ext;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides vxworks specific support functions needed
+-- by System.OS_Interface.
+
+-- This is the VxWorks 6 kernel version of this package
+
+with Interfaces.C;
+
+package System.VxWorks.Ext is
+ pragma Preelaborate;
+
+ subtype SEM_ID is Long_Integer;
+ -- typedef struct semaphore *SEM_ID;
+
+ type sigset_t is mod 2 ** Long_Long_Integer'Size;
+
+ type t_id is new Long_Integer;
+ subtype int is Interfaces.C.int;
+ subtype unsigned is Interfaces.C.unsigned;
+
+ type Interrupt_Handler is access procedure (parameter : System.Address);
+ pragma Convention (C, Interrupt_Handler);
+
+ type Interrupt_Vector is new System.Address;
+
+ function Int_Lock return int;
+ pragma Convention (C, Int_Lock);
+
+ function Int_Unlock (Old : int) return int;
+ pragma Convention (C, Int_Unlock);
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int;
+ pragma Import (C, Interrupt_Connect, "intConnect");
+
+ function Interrupt_Context return int;
+ pragma Import (C, Interrupt_Context, "intContext");
+
+ function Interrupt_Number_To_Vector
+ (intNum : int) return Interrupt_Vector;
+ pragma Import (C, Interrupt_Number_To_Vector, "__gnat_inum_to_ivec");
+
+ function semDelete (Sem : SEM_ID) return int;
+ pragma Convention (C, semDelete);
+
+ function Task_Cont (tid : t_id) return int;
+ pragma Convention (C, Task_Cont);
+
+ function Task_Stop (tid : t_id) return int;
+ pragma Convention (C, Task_Stop);
+
+ function kill (pid : t_id; sig : int) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return t_id;
+ pragma Import (C, getpid, "taskIdSelf");
+
+ function Set_Time_Slice (ticks : int) return int;
+ pragma Import (C, Set_Time_Slice, "kernelTimeSlice");
+
+ type UINT64 is mod 2 ** Long_Long_Integer'Size;
+
+ function tickGet return UINT64;
+ -- Needed for ravenscar-cert
+ pragma Import (C, tickGet, "tick64Get");
+
+ --------------------------------
+ -- Processor Affinity for SMP --
+ --------------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int;
+ pragma Convention (C, taskCpuAffinitySet);
+ -- For SMP run-times set the CPU affinity.
+ -- For uniprocessor systems return ERROR status.
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int;
+ pragma Convention (C, taskMaskAffinitySet);
+ -- For SMP run-times set the CPU mask affinity.
+ -- For uniprocessor systems return ERROR status.
+
+end System.VxWorks.Ext;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2008-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides VxWorks specific support functions needed
+-- by System.OS_Interface.
+
+-- This is the VxWorks 6 RTP/SMP version of this package
+
+package body System.VxWorks.Ext is
+
+ ERROR : constant := -1;
+
+ --------------
+ -- Int_Lock --
+ --------------
+
+ function Int_Lock return int is
+ begin
+ return ERROR;
+ end Int_Lock;
+
+ ----------------
+ -- Int_Unlock --
+ ----------------
+
+ function Int_Unlock (Old : int) return int is
+ pragma Unreferenced (Old);
+ begin
+ return ERROR;
+ end Int_Unlock;
+
+ -----------------------
+ -- Interrupt_Connect --
+ -----------------------
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int
+ is
+ pragma Unreferenced (Vector, Handler, Parameter);
+ begin
+ return ERROR;
+ end Interrupt_Connect;
+
+ -----------------------
+ -- Interrupt_Context --
+ -----------------------
+
+ function Interrupt_Context return int is
+ begin
+ -- For RTPs, never in an interrupt context
+
+ return 0;
+ end Interrupt_Context;
+
+ --------------------------------
+ -- Interrupt_Number_To_Vector --
+ --------------------------------
+
+ function Interrupt_Number_To_Vector
+ (intNum : int) return Interrupt_Vector
+ is
+ pragma Unreferenced (intNum);
+ begin
+ return 0;
+ end Interrupt_Number_To_Vector;
+
+ ---------------
+ -- semDelete --
+ ---------------
+
+ function semDelete (Sem : SEM_ID) return int is
+ function OS_semDelete (Sem : SEM_ID) return int;
+ pragma Import (C, OS_semDelete, "semDelete");
+ begin
+ return OS_semDelete (Sem);
+ end semDelete;
+
+ --------------------
+ -- Set_Time_Slice --
+ --------------------
+
+ function Set_Time_Slice (ticks : int) return int is
+ pragma Unreferenced (ticks);
+ begin
+ return ERROR;
+ end Set_Time_Slice;
+
+ ------------------------
+ -- taskCpuAffinitySet --
+ ------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int
+ is
+ function Set_Affinity (tid : t_id; CPU : int) return int;
+ pragma Import (C, Set_Affinity, "__gnat_set_affinity");
+ begin
+ return Set_Affinity (tid, CPU);
+ end taskCpuAffinitySet;
+
+ -------------------------
+ -- taskMaskAffinitySet --
+ -------------------------
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is
+ function Set_Affinity (tid : t_id; CPU_Set : unsigned) return int;
+ pragma Import (C, Set_Affinity, "__gnat_set_affinity_mask");
+ begin
+ return Set_Affinity (tid, CPU_Set);
+ end taskMaskAffinitySet;
+
+end System.VxWorks.Ext;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2008-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides VxWorks specific support functions needed
+-- by System.OS_Interface.
+
+-- This is the VxWorks 6 RTP version of this package
+
+package body System.VxWorks.Ext is
+
+ ERROR : constant := -1;
+
+ --------------
+ -- Int_Lock --
+ --------------
+
+ function Int_Lock return int is
+ begin
+ return ERROR;
+ end Int_Lock;
+
+ ----------------
+ -- Int_Unlock --
+ ----------------
+
+ function Int_Unlock (Old : int) return int is
+ pragma Unreferenced (Old);
+ begin
+ return ERROR;
+ end Int_Unlock;
+
+ -----------------------
+ -- Interrupt_Connect --
+ -----------------------
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int
+ is
+ pragma Unreferenced (Vector, Handler, Parameter);
+ begin
+ return ERROR;
+ end Interrupt_Connect;
+
+ -----------------------
+ -- Interrupt_Context --
+ -----------------------
+
+ function Interrupt_Context return int is
+ begin
+ -- For RTPs, never in an interrupt context
+
+ return 0;
+ end Interrupt_Context;
+
+ --------------------------------
+ -- Interrupt_Number_To_Vector --
+ --------------------------------
+
+ function Interrupt_Number_To_Vector
+ (intNum : int) return Interrupt_Vector
+ is
+ pragma Unreferenced (intNum);
+ begin
+ return 0;
+ end Interrupt_Number_To_Vector;
+
+ ---------------
+ -- semDelete --
+ ---------------
+
+ function semDelete (Sem : SEM_ID) return int is
+ function OS_semDelete (Sem : SEM_ID) return int;
+ pragma Import (C, OS_semDelete, "semDelete");
+ begin
+ return OS_semDelete (Sem);
+ end semDelete;
+
+ --------------------
+ -- Set_Time_Slice --
+ --------------------
+
+ function Set_Time_Slice (ticks : int) return int is
+ pragma Unreferenced (ticks);
+ begin
+ return ERROR;
+ end Set_Time_Slice;
+
+ ------------------------
+ -- taskCpuAffinitySet --
+ ------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int is
+ pragma Unreferenced (tid, CPU);
+ begin
+ return ERROR;
+ end taskCpuAffinitySet;
+
+ -------------------------
+ -- taskMaskAffinitySet --
+ -------------------------
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is
+ pragma Unreferenced (tid, CPU_Set);
+ begin
+ return ERROR;
+ end taskMaskAffinitySet;
+
+end System.VxWorks.Ext;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides vxworks specific support functions needed
+-- by System.OS_Interface.
+
+-- This is the VxWorks 6 RTP version of this package
+
+with Interfaces.C;
+
+package System.VxWorks.Ext is
+ pragma Preelaborate;
+
+ subtype SEM_ID is Long_Integer;
+ -- typedef struct semaphore *SEM_ID;
+
+ type sigset_t is mod 2 ** Long_Long_Integer'Size;
+
+ type t_id is new Long_Integer;
+ subtype int is Interfaces.C.int;
+ subtype unsigned is Interfaces.C.unsigned;
+
+ type Interrupt_Handler is access procedure (parameter : System.Address);
+ pragma Convention (C, Interrupt_Handler);
+
+ type Interrupt_Vector is new System.Address;
+
+ function Int_Lock return int;
+ pragma Inline (Int_Lock);
+
+ function Int_Unlock (Old : int) return int;
+ pragma Inline (Int_Unlock);
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int;
+ pragma Convention (C, Interrupt_Connect);
+
+ function Interrupt_Context return int;
+ pragma Convention (C, Interrupt_Context);
+
+ function Interrupt_Number_To_Vector
+ (intNum : int) return Interrupt_Vector;
+ pragma Convention (C, Interrupt_Number_To_Vector);
+
+ function semDelete (Sem : SEM_ID) return int;
+ pragma Convention (C, semDelete);
+
+ function Task_Cont (tid : t_id) return int;
+ pragma Import (C, Task_Cont, "taskResume");
+
+ function Task_Stop (tid : t_id) return int;
+ pragma Import (C, Task_Stop, "taskSuspend");
+
+ function kill (pid : t_id; sig : int) return int;
+ pragma Import (C, kill, "taskKill");
+
+ function getpid return t_id;
+ pragma Import (C, getpid, "getpid");
+
+ function Set_Time_Slice (ticks : int) return int;
+ pragma Inline (Set_Time_Slice);
+
+ --------------------------------
+ -- Processor Affinity for SMP --
+ --------------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int;
+ pragma Convention (C, taskCpuAffinitySet);
+ -- For SMP run-times set the CPU affinity.
+ -- For uniprocessor systems return ERROR status.
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int;
+ pragma Convention (C, taskMaskAffinitySet);
+ -- For SMP run-times set the CPU mask affinity.
+ -- For uniprocessor systems return ERROR status.
+
+end System.VxWorks.Ext;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008-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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides VxWorks specific support functions needed
+-- by System.OS_Interface.
+
+-- This is the VxWorks 653 vThreads version of this package
+
+with Interfaces.C;
+
+package System.VxWorks.Ext is
+ pragma Preelaborate;
+
+ subtype SEM_ID is Long_Integer;
+ -- typedef struct semaphore *SEM_ID;
+
+ type sigset_t is mod 2 ** Interfaces.C.long'Size;
+
+ type t_id is new Long_Integer;
+ subtype int is Interfaces.C.int;
+ subtype unsigned is Interfaces.C.unsigned;
+
+ type Interrupt_Handler is access procedure (parameter : System.Address);
+ pragma Convention (C, Interrupt_Handler);
+
+ type Interrupt_Vector is new System.Address;
+ function Int_Lock return int;
+ pragma Inline (Int_Lock);
+
+ function Int_Unlock (Old : int) return int;
+ pragma Inline (Int_Unlock);
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int;
+ pragma Convention (C, Interrupt_Connect);
+
+ function Interrupt_Context return int;
+ pragma Convention (C, Interrupt_Context);
+
+ function Interrupt_Number_To_Vector
+ (intNum : int) return Interrupt_Vector;
+ pragma Convention (C, Interrupt_Number_To_Vector);
+
+ function semDelete (Sem : SEM_ID) return int;
+ pragma Convention (C, semDelete);
+
+ function Task_Cont (tid : t_id) return int;
+ pragma Import (C, Task_Cont, "taskResume");
+
+ function Task_Stop (tid : t_id) return int;
+ pragma Import (C, Task_Stop, "taskSuspend");
+
+ function kill (pid : t_id; sig : int) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return t_id;
+ pragma Import (C, getpid, "taskIdSelf");
+
+ function Set_Time_Slice (ticks : int) return int;
+ pragma Import (C, Set_Time_Slice, "kernelTimeSlice");
+
+ type UINT64 is mod 2 ** Long_Long_Integer'Size;
+
+ function tickGet return UINT64;
+ -- "tickGet" not available for cert vThreads:
+ pragma Import (C, tickGet, "tick64Get");
+
+ --------------------------------
+ -- Processor Affinity for SMP --
+ --------------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int;
+ pragma Convention (C, taskCpuAffinitySet);
+ -- For SMP run-times set the CPU affinity.
+ -- For uniprocessor systems return ERROR status.
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int;
+ pragma Convention (C, taskMaskAffinitySet);
+ -- For SMP run-times set the CPU mask affinity.
+ -- For uniprocessor systems return ERROR status.
+
+end System.VxWorks.Ext;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1998-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 --
--- <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 ARM VxWorks version of this package
-
-with Interfaces.C;
-
-package System.VxWorks is
- pragma Preelaborate (System.VxWorks);
-
- package IC renames Interfaces.C;
-
- -- Floating point context record. ARM version
-
- FP_SGPR_NUM_REGS : constant := 32;
- type Fpr_Sgpr_Array is array (1 .. FP_SGPR_NUM_REGS) of IC.unsigned;
-
- -- The record definition below matches what arch/arm/fppArmLib.h says
-
- type FP_CONTEXT is record
- fpsid : IC.unsigned; -- system ID register
- fpscr : IC.unsigned; -- status and control register
- fpexc : IC.unsigned; -- exception register
- fpinst : IC.unsigned; -- instruction register
- fpinst2 : IC.unsigned; -- instruction register 2
- mfvfr0 : IC.unsigned; -- media and VFP feature Register 0
- mfvfr1 : IC.unsigned; -- media and VFP feature Register 1
- pad : IC.unsigned;
- vfp_gpr : Fpr_Sgpr_Array;
- end record;
-
- for FP_CONTEXT'Alignment use 4;
- pragma Convention (C, FP_CONTEXT);
-
- Num_HW_Interrupts : constant := 256;
- -- Number of entries in hardware interrupt vector table
-
-end System.VxWorks;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1998-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 --
--- <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 PPC VxWorks version of this package
-
-with Interfaces.C;
-
-package System.VxWorks is
- pragma Preelaborate;
-
- package IC renames Interfaces.C;
-
- -- Floating point context record. PPC version
-
- FP_NUM_DREGS : constant := 32;
- type Fpr_Array is array (1 .. FP_NUM_DREGS) of IC.double;
-
- type FP_CONTEXT is record
- fpr : Fpr_Array;
- fpcsr : IC.int;
- fpcsrCopy : IC.int;
- end record;
- pragma Convention (C, FP_CONTEXT);
-
- Num_HW_Interrupts : constant := 256;
-
-end System.VxWorks;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1998-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 --
--- <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 x86 VxWorks version of this package
-
-package System.VxWorks is
- pragma Preelaborate;
-
- -- Floating point context record. x86 version
-
- -- There are two kinds of FP_CONTEXT for this architecture, corresponding
- -- to newer and older processors. The type is defined in fppI86lib.h as a
- -- union. The form used depends on the versions of the save and restore
- -- routines that are selected by the user (these versions are provided in
- -- vxwork.ads). Since we do not examine the contents of these objects, it
- -- is sufficient to declare the type as of the required size: 512 bytes.
-
- type FP_CONTEXT is array (1 .. 128) of Integer;
- for FP_CONTEXT'Alignment use 4;
- for FP_CONTEXT'Size use 512 * Storage_Unit;
- pragma Convention (C, FP_CONTEXT);
-
- Num_HW_Interrupts : constant := 256;
- -- Number of entries in hardware interrupt vector table
-
-end System.VxWorks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1998-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 --
+-- <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 ARM VxWorks version of this package
+
+with Interfaces.C;
+
+package System.VxWorks is
+ pragma Preelaborate (System.VxWorks);
+
+ package IC renames Interfaces.C;
+
+ -- Floating point context record. ARM version
+
+ FP_SGPR_NUM_REGS : constant := 32;
+ type Fpr_Sgpr_Array is array (1 .. FP_SGPR_NUM_REGS) of IC.unsigned;
+
+ -- The record definition below matches what arch/arm/fppArmLib.h says
+
+ type FP_CONTEXT is record
+ fpsid : IC.unsigned; -- system ID register
+ fpscr : IC.unsigned; -- status and control register
+ fpexc : IC.unsigned; -- exception register
+ fpinst : IC.unsigned; -- instruction register
+ fpinst2 : IC.unsigned; -- instruction register 2
+ mfvfr0 : IC.unsigned; -- media and VFP feature Register 0
+ mfvfr1 : IC.unsigned; -- media and VFP feature Register 1
+ pad : IC.unsigned;
+ vfp_gpr : Fpr_Sgpr_Array;
+ end record;
+
+ for FP_CONTEXT'Alignment use 4;
+ pragma Convention (C, FP_CONTEXT);
+
+ Num_HW_Interrupts : constant := 256;
+ -- Number of entries in hardware interrupt vector table
+
+end System.VxWorks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1998-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 --
+-- <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 PPC VxWorks version of this package
+
+with Interfaces.C;
+
+package System.VxWorks is
+ pragma Preelaborate;
+
+ package IC renames Interfaces.C;
+
+ -- Floating point context record. PPC version
+
+ FP_NUM_DREGS : constant := 32;
+ type Fpr_Array is array (1 .. FP_NUM_DREGS) of IC.double;
+
+ type FP_CONTEXT is record
+ fpr : Fpr_Array;
+ fpcsr : IC.int;
+ fpcsrCopy : IC.int;
+ end record;
+ pragma Convention (C, FP_CONTEXT);
+
+ Num_HW_Interrupts : constant := 256;
+
+end System.VxWorks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1998-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 --
+-- <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 x86 VxWorks version of this package
+
+package System.VxWorks is
+ pragma Preelaborate;
+
+ -- Floating point context record. x86 version
+
+ -- There are two kinds of FP_CONTEXT for this architecture, corresponding
+ -- to newer and older processors. The type is defined in fppI86lib.h as a
+ -- union. The form used depends on the versions of the save and restore
+ -- routines that are selected by the user (these versions are provided in
+ -- vxwork.ads). Since we do not examine the contents of these objects, it
+ -- is sufficient to declare the type as of the required size: 512 bytes.
+
+ type FP_CONTEXT is array (1 .. 128) of Integer;
+ for FP_CONTEXT'Alignment use 4;
+ for FP_CONTEXT'Size use 512 * Storage_Unit;
+ pragma Convention (C, FP_CONTEXT);
+
+ Num_HW_Interrupts : constant := 256;
+ -- Number of entries in hardware interrupt vector table
+
+end System.VxWorks;
projects / gcc.git / commitdiff