From: Arnaud Charlet Date: Mon, 11 Sep 2017 09:18:42 +0000 (+0200) Subject: libgnarl: Rename ?-[a-z]*-* into ?-[a-z]*__* X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=2b9d0dc00b4d77713e85f02476ef920af3b5f763;p=gcc.git libgnarl: Rename ?-[a-z]*-* into ?-[a-z]*__* 2017-09-11 Jerome Lambourg * libgnarl: Rename ?-[a-z]*-* into ?-[a-z]*__* * gcc-interface/Makefile.in: Take this renaming into account. From-SVN: r251965 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4b62600d5cb..93d9f6a5429 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2017-09-11 Jerome Lambourg + + * libgnarl: Rename ?-[a-z]*-* into ?-[a-z]*__* + * gcc-interface/Makefile.in: Take this renaming into account. + +2017-09-11 Arnaud Charlet + + * s-auxdec-empty.ads, s-auxdec-empty.adb, 9drpc.adb: Removed, no + longer used. + 2017-09-11 Yannick Moy * sem_util.adb (Check_Result_And_Post_State): diff --git a/gcc/ada/libgnarl/a-exetim-darwin.adb b/gcc/ada/libgnarl/a-exetim-darwin.adb deleted file mode 100644 index a417d912728..00000000000 --- a/gcc/ada/libgnarl/a-exetim-darwin.adb +++ /dev/null @@ -1,210 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/a-exetim-default.ads b/gcc/ada/libgnarl/a-exetim-default.ads deleted file mode 100644 index 8bf751e17e9..00000000000 --- a/gcc/ada/libgnarl/a-exetim-default.ads +++ /dev/null @@ -1,133 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/a-exetim-mingw.adb b/gcc/ada/libgnarl/a-exetim-mingw.adb deleted file mode 100644 index 264ba9d5322..00000000000 --- a/gcc/ada/libgnarl/a-exetim-mingw.adb +++ /dev/null @@ -1,174 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/a-exetim-mingw.ads b/gcc/ada/libgnarl/a-exetim-mingw.ads deleted file mode 100644 index d4295c6f1ca..00000000000 --- a/gcc/ada/libgnarl/a-exetim-mingw.ads +++ /dev/null @@ -1,134 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/a-exetim-posix.adb b/gcc/ada/libgnarl/a-exetim-posix.adb deleted file mode 100644 index 10000bf23e1..00000000000 --- a/gcc/ada/libgnarl/a-exetim-posix.adb +++ /dev/null @@ -1,185 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/a-exetim__darwin.adb b/gcc/ada/libgnarl/a-exetim__darwin.adb new file mode 100644 index 00000000000..a417d912728 --- /dev/null +++ b/gcc/ada/libgnarl/a-exetim__darwin.adb @@ -0,0 +1,210 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/a-exetim__default.ads b/gcc/ada/libgnarl/a-exetim__default.ads new file mode 100644 index 00000000000..8bf751e17e9 --- /dev/null +++ b/gcc/ada/libgnarl/a-exetim__default.ads @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/a-exetim__mingw.adb b/gcc/ada/libgnarl/a-exetim__mingw.adb new file mode 100644 index 00000000000..264ba9d5322 --- /dev/null +++ b/gcc/ada/libgnarl/a-exetim__mingw.adb @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/a-exetim__mingw.ads b/gcc/ada/libgnarl/a-exetim__mingw.ads new file mode 100644 index 00000000000..d4295c6f1ca --- /dev/null +++ b/gcc/ada/libgnarl/a-exetim__mingw.ads @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/a-exetim__posix.adb b/gcc/ada/libgnarl/a-exetim__posix.adb new file mode 100644 index 00000000000..10000bf23e1 --- /dev/null +++ b/gcc/ada/libgnarl/a-exetim__posix.adb @@ -0,0 +1,185 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/a-intnam-aix.ads b/gcc/ada/libgnarl/a-intnam-aix.ads deleted file mode 100644 index 65391f01390..00000000000 --- a/gcc/ada/libgnarl/a-intnam-aix.ads +++ /dev/null @@ -1,201 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a 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; diff --git a/gcc/ada/libgnarl/a-intnam-darwin.ads b/gcc/ada/libgnarl/a-intnam-darwin.ads deleted file mode 100644 index e538788d243..00000000000 --- a/gcc/ada/libgnarl/a-intnam-darwin.ads +++ /dev/null @@ -1,153 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is 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; diff --git a/gcc/ada/libgnarl/a-intnam-dragonfly.ads b/gcc/ada/libgnarl/a-intnam-dragonfly.ads deleted file mode 100644 index 1de973523f5..00000000000 --- a/gcc/ada/libgnarl/a-intnam-dragonfly.ads +++ /dev/null @@ -1,136 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/a-intnam-dummy.ads b/gcc/ada/libgnarl/a-intnam-dummy.ads deleted file mode 100644 index 0e7afa6bb8e..00000000000 --- a/gcc/ada/libgnarl/a-intnam-dummy.ads +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/a-intnam-freebsd.ads b/gcc/ada/libgnarl/a-intnam-freebsd.ads deleted file mode 100644 index 69ae877cfd5..00000000000 --- a/gcc/ada/libgnarl/a-intnam-freebsd.ads +++ /dev/null @@ -1,136 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is 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; diff --git a/gcc/ada/libgnarl/a-intnam-hpux.ads b/gcc/ada/libgnarl/a-intnam-hpux.ads deleted file mode 100644 index 0b4b1eda727..00000000000 --- a/gcc/ada/libgnarl/a-intnam-hpux.ads +++ /dev/null @@ -1,154 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a 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; diff --git a/gcc/ada/libgnarl/a-intnam-linux.ads b/gcc/ada/libgnarl/a-intnam-linux.ads deleted file mode 100644 index 5bb4011c95f..00000000000 --- a/gcc/ada/libgnarl/a-intnam-linux.ads +++ /dev/null @@ -1,163 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a 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; diff --git a/gcc/ada/libgnarl/a-intnam-lynxos.ads b/gcc/ada/libgnarl/a-intnam-lynxos.ads deleted file mode 100644 index 813a0966802..00000000000 --- a/gcc/ada/libgnarl/a-intnam-lynxos.ads +++ /dev/null @@ -1,166 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a 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; diff --git a/gcc/ada/libgnarl/a-intnam-mingw.ads b/gcc/ada/libgnarl/a-intnam-mingw.ads deleted file mode 100644 index 66bc46908af..00000000000 --- a/gcc/ada/libgnarl/a-intnam-mingw.ads +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/a-intnam-rtems.ads b/gcc/ada/libgnarl/a-intnam-rtems.ads deleted file mode 100644 index 43a5281c363..00000000000 --- a/gcc/ada/libgnarl/a-intnam-rtems.ads +++ /dev/null @@ -1,114 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/a-intnam-solaris.ads b/gcc/ada/libgnarl/a-intnam-solaris.ads deleted file mode 100644 index 1113eced0d8..00000000000 --- a/gcc/ada/libgnarl/a-intnam-solaris.ads +++ /dev/null @@ -1,179 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a 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; diff --git a/gcc/ada/libgnarl/a-intnam-vxworks.ads b/gcc/ada/libgnarl/a-intnam-vxworks.ads deleted file mode 100644 index 8b5aa37d019..00000000000 --- a/gcc/ada/libgnarl/a-intnam-vxworks.ads +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/a-intnam__aix.ads b/gcc/ada/libgnarl/a-intnam__aix.ads new file mode 100644 index 00000000000..65391f01390 --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam__aix.ads @@ -0,0 +1,201 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a 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; diff --git a/gcc/ada/libgnarl/a-intnam__darwin.ads b/gcc/ada/libgnarl/a-intnam__darwin.ads new file mode 100644 index 00000000000..e538788d243 --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam__darwin.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is 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; diff --git a/gcc/ada/libgnarl/a-intnam__dragonfly.ads b/gcc/ada/libgnarl/a-intnam__dragonfly.ads new file mode 100644 index 00000000000..1de973523f5 --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam__dragonfly.ads @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/a-intnam__dummy.ads b/gcc/ada/libgnarl/a-intnam__dummy.ads new file mode 100644 index 00000000000..0e7afa6bb8e --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam__dummy.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/a-intnam__freebsd.ads b/gcc/ada/libgnarl/a-intnam__freebsd.ads new file mode 100644 index 00000000000..69ae877cfd5 --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam__freebsd.ads @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is 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; diff --git a/gcc/ada/libgnarl/a-intnam__hpux.ads b/gcc/ada/libgnarl/a-intnam__hpux.ads new file mode 100644 index 00000000000..0b4b1eda727 --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam__hpux.ads @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a 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; diff --git a/gcc/ada/libgnarl/a-intnam__linux.ads b/gcc/ada/libgnarl/a-intnam__linux.ads new file mode 100644 index 00000000000..5bb4011c95f --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam__linux.ads @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a 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; diff --git a/gcc/ada/libgnarl/a-intnam__lynxos.ads b/gcc/ada/libgnarl/a-intnam__lynxos.ads new file mode 100644 index 00000000000..813a0966802 --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam__lynxos.ads @@ -0,0 +1,166 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a 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; diff --git a/gcc/ada/libgnarl/a-intnam__mingw.ads b/gcc/ada/libgnarl/a-intnam__mingw.ads new file mode 100644 index 00000000000..66bc46908af --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam__mingw.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/a-intnam__rtems.ads b/gcc/ada/libgnarl/a-intnam__rtems.ads new file mode 100644 index 00000000000..43a5281c363 --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam__rtems.ads @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/a-intnam__solaris.ads b/gcc/ada/libgnarl/a-intnam__solaris.ads new file mode 100644 index 00000000000..1113eced0d8 --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam__solaris.ads @@ -0,0 +1,179 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a 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; diff --git a/gcc/ada/libgnarl/a-intnam__vxworks.ads b/gcc/ada/libgnarl/a-intnam__vxworks.ads new file mode 100644 index 00000000000..8b5aa37d019 --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam__vxworks.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/a-synbar-posix.adb b/gcc/ada/libgnarl/a-synbar-posix.adb deleted file mode 100644 index 2e78a81fab6..00000000000 --- a/gcc/ada/libgnarl/a-synbar-posix.adb +++ /dev/null @@ -1,111 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/a-synbar-posix.ads b/gcc/ada/libgnarl/a-synbar-posix.ads deleted file mode 100644 index 564f2e3fb5c..00000000000 --- a/gcc/ada/libgnarl/a-synbar-posix.ads +++ /dev/null @@ -1,84 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/a-synbar__posix.adb b/gcc/ada/libgnarl/a-synbar__posix.adb new file mode 100644 index 00000000000..2e78a81fab6 --- /dev/null +++ b/gcc/ada/libgnarl/a-synbar__posix.adb @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/a-synbar__posix.ads b/gcc/ada/libgnarl/a-synbar__posix.ads new file mode 100644 index 00000000000..564f2e3fb5c --- /dev/null +++ b/gcc/ada/libgnarl/a-synbar__posix.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-inmaop-dummy.adb b/gcc/ada/libgnarl/s-inmaop-dummy.adb deleted file mode 100644 index 2d9a1bc3f2d..00000000000 --- a/gcc/ada/libgnarl/s-inmaop-dummy.adb +++ /dev/null @@ -1,201 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-inmaop-posix.adb b/gcc/ada/libgnarl/s-inmaop-posix.adb deleted file mode 100644 index a671fcc7779..00000000000 --- a/gcc/ada/libgnarl/s-inmaop-posix.adb +++ /dev/null @@ -1,336 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-inmaop-vxworks.adb b/gcc/ada/libgnarl/s-inmaop-vxworks.adb deleted file mode 100644 index cbe84c87aaa..00000000000 --- a/gcc/ada/libgnarl/s-inmaop-vxworks.adb +++ /dev/null @@ -1,261 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-inmaop__dummy.adb b/gcc/ada/libgnarl/s-inmaop__dummy.adb new file mode 100644 index 00000000000..2d9a1bc3f2d --- /dev/null +++ b/gcc/ada/libgnarl/s-inmaop__dummy.adb @@ -0,0 +1,201 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-inmaop__posix.adb b/gcc/ada/libgnarl/s-inmaop__posix.adb new file mode 100644 index 00000000000..a671fcc7779 --- /dev/null +++ b/gcc/ada/libgnarl/s-inmaop__posix.adb @@ -0,0 +1,336 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-inmaop__vxworks.adb b/gcc/ada/libgnarl/s-inmaop__vxworks.adb new file mode 100644 index 00000000000..cbe84c87aaa --- /dev/null +++ b/gcc/ada/libgnarl/s-inmaop__vxworks.adb @@ -0,0 +1,261 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-interr-dummy.adb b/gcc/ada/libgnarl/s-interr-dummy.adb deleted file mode 100644 index 2612c2776ab..00000000000 --- a/gcc/ada/libgnarl/s-interr-dummy.adb +++ /dev/null @@ -1,307 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-interr-hwint.adb b/gcc/ada/libgnarl/s-interr-hwint.adb deleted file mode 100644 index 8e2950f30fb..00000000000 --- a/gcc/ada/libgnarl/s-interr-hwint.adb +++ /dev/null @@ -1,1110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-interr-sigaction.adb b/gcc/ada/libgnarl/s-interr-sigaction.adb deleted file mode 100644 index 8e9fa8544a0..00000000000 --- a/gcc/ada/libgnarl/s-interr-sigaction.adb +++ /dev/null @@ -1,668 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-interr-vxworks.adb b/gcc/ada/libgnarl/s-interr-vxworks.adb deleted file mode 100644 index a85d8c6b235..00000000000 --- a/gcc/ada/libgnarl/s-interr-vxworks.adb +++ /dev/null @@ -1,1127 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-interr__dummy.adb b/gcc/ada/libgnarl/s-interr__dummy.adb new file mode 100644 index 00000000000..2612c2776ab --- /dev/null +++ b/gcc/ada/libgnarl/s-interr__dummy.adb @@ -0,0 +1,307 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-interr__hwint.adb b/gcc/ada/libgnarl/s-interr__hwint.adb new file mode 100644 index 00000000000..8e2950f30fb --- /dev/null +++ b/gcc/ada/libgnarl/s-interr__hwint.adb @@ -0,0 +1,1110 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-interr__sigaction.adb b/gcc/ada/libgnarl/s-interr__sigaction.adb new file mode 100644 index 00000000000..8e9fa8544a0 --- /dev/null +++ b/gcc/ada/libgnarl/s-interr__sigaction.adb @@ -0,0 +1,668 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-interr__vxworks.adb b/gcc/ada/libgnarl/s-interr__vxworks.adb new file mode 100644 index 00000000000..a85d8c6b235 --- /dev/null +++ b/gcc/ada/libgnarl/s-interr__vxworks.adb @@ -0,0 +1,1127 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-intman-android.adb b/gcc/ada/libgnarl/s-intman-android.adb deleted file mode 100644 index 35c4f0a2d4b..00000000000 --- a/gcc/ada/libgnarl/s-intman-android.adb +++ /dev/null @@ -1,325 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-intman-dummy.adb b/gcc/ada/libgnarl/s-intman-dummy.adb deleted file mode 100644 index e063f35c719..00000000000 --- a/gcc/ada/libgnarl/s-intman-dummy.adb +++ /dev/null @@ -1,45 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-intman-lynxos.adb b/gcc/ada/libgnarl/s-intman-lynxos.adb deleted file mode 100644 index 9048e49c59b..00000000000 --- a/gcc/ada/libgnarl/s-intman-lynxos.adb +++ /dev/null @@ -1,292 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the 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; diff --git a/gcc/ada/libgnarl/s-intman-mingw.adb b/gcc/ada/libgnarl/s-intman-mingw.adb deleted file mode 100644 index f190e6a2f05..00000000000 --- a/gcc/ada/libgnarl/s-intman-mingw.adb +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-intman-posix.adb b/gcc/ada/libgnarl/s-intman-posix.adb deleted file mode 100644 index 3b132f65f80..00000000000 --- a/gcc/ada/libgnarl/s-intman-posix.adb +++ /dev/null @@ -1,288 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the 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; diff --git a/gcc/ada/libgnarl/s-intman-solaris.adb b/gcc/ada/libgnarl/s-intman-solaris.adb deleted file mode 100644 index 46670acdf6c..00000000000 --- a/gcc/ada/libgnarl/s-intman-solaris.adb +++ /dev/null @@ -1,232 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is 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; diff --git a/gcc/ada/libgnarl/s-intman-susv3.adb b/gcc/ada/libgnarl/s-intman-susv3.adb deleted file mode 100644 index eabd836263d..00000000000 --- a/gcc/ada/libgnarl/s-intman-susv3.adb +++ /dev/null @@ -1,170 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the 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; diff --git a/gcc/ada/libgnarl/s-intman-vxworks.adb b/gcc/ada/libgnarl/s-intman-vxworks.adb deleted file mode 100644 index 67f7db36a0d..00000000000 --- a/gcc/ada/libgnarl/s-intman-vxworks.adb +++ /dev/null @@ -1,94 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the 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; diff --git a/gcc/ada/libgnarl/s-intman-vxworks.ads b/gcc/ada/libgnarl/s-intman-vxworks.ads deleted file mode 100644 index 4f4db30aaca..00000000000 --- a/gcc/ada/libgnarl/s-intman-vxworks.ads +++ /dev/null @@ -1,105 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-intman__android.adb b/gcc/ada/libgnarl/s-intman__android.adb new file mode 100644 index 00000000000..35c4f0a2d4b --- /dev/null +++ b/gcc/ada/libgnarl/s-intman__android.adb @@ -0,0 +1,325 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-intman__dummy.adb b/gcc/ada/libgnarl/s-intman__dummy.adb new file mode 100644 index 00000000000..e063f35c719 --- /dev/null +++ b/gcc/ada/libgnarl/s-intman__dummy.adb @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-intman__lynxos.adb b/gcc/ada/libgnarl/s-intman__lynxos.adb new file mode 100644 index 00000000000..9048e49c59b --- /dev/null +++ b/gcc/ada/libgnarl/s-intman__lynxos.adb @@ -0,0 +1,292 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the 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; diff --git a/gcc/ada/libgnarl/s-intman__mingw.adb b/gcc/ada/libgnarl/s-intman__mingw.adb new file mode 100644 index 00000000000..f190e6a2f05 --- /dev/null +++ b/gcc/ada/libgnarl/s-intman__mingw.adb @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-intman__posix.adb b/gcc/ada/libgnarl/s-intman__posix.adb new file mode 100644 index 00000000000..3b132f65f80 --- /dev/null +++ b/gcc/ada/libgnarl/s-intman__posix.adb @@ -0,0 +1,288 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the 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; diff --git a/gcc/ada/libgnarl/s-intman__solaris.adb b/gcc/ada/libgnarl/s-intman__solaris.adb new file mode 100644 index 00000000000..46670acdf6c --- /dev/null +++ b/gcc/ada/libgnarl/s-intman__solaris.adb @@ -0,0 +1,232 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is 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; diff --git a/gcc/ada/libgnarl/s-intman__susv3.adb b/gcc/ada/libgnarl/s-intman__susv3.adb new file mode 100644 index 00000000000..eabd836263d --- /dev/null +++ b/gcc/ada/libgnarl/s-intman__susv3.adb @@ -0,0 +1,170 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the 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; diff --git a/gcc/ada/libgnarl/s-intman__vxworks.adb b/gcc/ada/libgnarl/s-intman__vxworks.adb new file mode 100644 index 00000000000..67f7db36a0d --- /dev/null +++ b/gcc/ada/libgnarl/s-intman__vxworks.adb @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the 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; diff --git a/gcc/ada/libgnarl/s-intman__vxworks.ads b/gcc/ada/libgnarl/s-intman__vxworks.ads new file mode 100644 index 00000000000..4f4db30aaca --- /dev/null +++ b/gcc/ada/libgnarl/s-intman__vxworks.ads @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-linux-alpha.ads b/gcc/ada/libgnarl/s-linux-alpha.ads deleted file mode 100644 index dd748bc40e4..00000000000 --- a/gcc/ada/libgnarl/s-linux-alpha.ads +++ /dev/null @@ -1,135 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- -- ------------------------------------------------------------------------------- - --- 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; diff --git a/gcc/ada/libgnarl/s-linux-android.ads b/gcc/ada/libgnarl/s-linux-android.ads deleted file mode 100644 index 6e208395976..00000000000 --- a/gcc/ada/libgnarl/s-linux-android.ads +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-linux-hppa.ads b/gcc/ada/libgnarl/s-linux-hppa.ads deleted file mode 100644 index dc01307a966..00000000000 --- a/gcc/ada/libgnarl/s-linux-hppa.ads +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- -- ------------------------------------------------------------------------------- - --- 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; diff --git a/gcc/ada/libgnarl/s-linux-mips.ads b/gcc/ada/libgnarl/s-linux-mips.ads deleted file mode 100644 index 6ec4a8b7576..00000000000 --- a/gcc/ada/libgnarl/s-linux-mips.ads +++ /dev/null @@ -1,134 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- ------------------------------------------------------------------------------- - --- 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; diff --git a/gcc/ada/libgnarl/s-linux-sparc.ads b/gcc/ada/libgnarl/s-linux-sparc.ads deleted file mode 100644 index c9dcd009780..00000000000 --- a/gcc/ada/libgnarl/s-linux-sparc.ads +++ /dev/null @@ -1,133 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- -- ------------------------------------------------------------------------------- - --- 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; diff --git a/gcc/ada/libgnarl/s-linux-x32.ads b/gcc/ada/libgnarl/s-linux-x32.ads deleted file mode 100644 index 823d806ea84..00000000000 --- a/gcc/ada/libgnarl/s-linux-x32.ads +++ /dev/null @@ -1,126 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- -- ------------------------------------------------------------------------------- - --- 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; diff --git a/gcc/ada/libgnarl/s-linux__alpha.ads b/gcc/ada/libgnarl/s-linux__alpha.ads new file mode 100644 index 00000000000..dd748bc40e4 --- /dev/null +++ b/gcc/ada/libgnarl/s-linux__alpha.ads @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- -- +------------------------------------------------------------------------------ + +-- 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; diff --git a/gcc/ada/libgnarl/s-linux__android.ads b/gcc/ada/libgnarl/s-linux__android.ads new file mode 100644 index 00000000000..6e208395976 --- /dev/null +++ b/gcc/ada/libgnarl/s-linux__android.ads @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-linux__hppa.ads b/gcc/ada/libgnarl/s-linux__hppa.ads new file mode 100644 index 00000000000..dc01307a966 --- /dev/null +++ b/gcc/ada/libgnarl/s-linux__hppa.ads @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- -- +------------------------------------------------------------------------------ + +-- 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; diff --git a/gcc/ada/libgnarl/s-linux__mips.ads b/gcc/ada/libgnarl/s-linux__mips.ads new file mode 100644 index 00000000000..6ec4a8b7576 --- /dev/null +++ b/gcc/ada/libgnarl/s-linux__mips.ads @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- 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; diff --git a/gcc/ada/libgnarl/s-linux__sparc.ads b/gcc/ada/libgnarl/s-linux__sparc.ads new file mode 100644 index 00000000000..c9dcd009780 --- /dev/null +++ b/gcc/ada/libgnarl/s-linux__sparc.ads @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- -- +------------------------------------------------------------------------------ + +-- 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; diff --git a/gcc/ada/libgnarl/s-linux__x32.ads b/gcc/ada/libgnarl/s-linux__x32.ads new file mode 100644 index 00000000000..823d806ea84 --- /dev/null +++ b/gcc/ada/libgnarl/s-linux__x32.ads @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- -- +------------------------------------------------------------------------------ + +-- 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; diff --git a/gcc/ada/libgnarl/s-mudido-affinity.adb b/gcc/ada/libgnarl/s-mudido-affinity.adb deleted file mode 100644 index b0a5fdd1898..00000000000 --- a/gcc/ada/libgnarl/s-mudido-affinity.adb +++ /dev/null @@ -1,401 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-mudido__affinity.adb b/gcc/ada/libgnarl/s-mudido__affinity.adb new file mode 100644 index 00000000000..b0a5fdd1898 --- /dev/null +++ b/gcc/ada/libgnarl/s-mudido__affinity.adb @@ -0,0 +1,401 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte-aix.adb b/gcc/ada/libgnarl/s-osinte-aix.adb deleted file mode 100644 index a708eafeab1..00000000000 --- a/gcc/ada/libgnarl/s-osinte-aix.adb +++ /dev/null @@ -1,190 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-aix.ads b/gcc/ada/libgnarl/s-osinte-aix.ads deleted file mode 100644 index be5f64dc73e..00000000000 --- a/gcc/ada/libgnarl/s-osinte-aix.ads +++ /dev/null @@ -1,610 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-android.adb b/gcc/ada/libgnarl/s-osinte-android.adb deleted file mode 100644 index fcb504f2e61..00000000000 --- a/gcc/ada/libgnarl/s-osinte-android.adb +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-android.ads b/gcc/ada/libgnarl/s-osinte-android.ads deleted file mode 100644 index d13af018c93..00000000000 --- a/gcc/ada/libgnarl/s-osinte-android.ads +++ /dev/null @@ -1,644 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is 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; diff --git a/gcc/ada/libgnarl/s-osinte-darwin.adb b/gcc/ada/libgnarl/s-osinte-darwin.adb deleted file mode 100644 index dcac8c095b8..00000000000 --- a/gcc/ada/libgnarl/s-osinte-darwin.adb +++ /dev/null @@ -1,194 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-darwin.ads b/gcc/ada/libgnarl/s-osinte-darwin.ads deleted file mode 100644 index b86b5c901bc..00000000000 --- a/gcc/ada/libgnarl/s-osinte-darwin.ads +++ /dev/null @@ -1,601 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-dragonfly.adb b/gcc/ada/libgnarl/s-osinte-dragonfly.adb deleted file mode 100644 index dc9e19c1984..00000000000 --- a/gcc/ada/libgnarl/s-osinte-dragonfly.adb +++ /dev/null @@ -1,116 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-dragonfly.ads b/gcc/ada/libgnarl/s-osinte-dragonfly.ads deleted file mode 100644 index a67702ca82c..00000000000 --- a/gcc/ada/libgnarl/s-osinte-dragonfly.ads +++ /dev/null @@ -1,652 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-dummy.ads b/gcc/ada/libgnarl/s-osinte-dummy.ads deleted file mode 100644 index 09631cf19c1..00000000000 --- a/gcc/ada/libgnarl/s-osinte-dummy.ads +++ /dev/null @@ -1,51 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-freebsd.adb b/gcc/ada/libgnarl/s-osinte-freebsd.adb deleted file mode 100644 index 28aea88a399..00000000000 --- a/gcc/ada/libgnarl/s-osinte-freebsd.adb +++ /dev/null @@ -1,115 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-freebsd.ads b/gcc/ada/libgnarl/s-osinte-freebsd.ads deleted file mode 100644 index bf9bbeeeb27..00000000000 --- a/gcc/ada/libgnarl/s-osinte-freebsd.ads +++ /dev/null @@ -1,652 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-gnu.adb b/gcc/ada/libgnarl/s-osinte-gnu.adb deleted file mode 100644 index fb099acfc7d..00000000000 --- a/gcc/ada/libgnarl/s-osinte-gnu.adb +++ /dev/null @@ -1,144 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-gnu.ads b/gcc/ada/libgnarl/s-osinte-gnu.ads deleted file mode 100644 index 183c5b83f60..00000000000 --- a/gcc/ada/libgnarl/s-osinte-gnu.ads +++ /dev/null @@ -1,800 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-hpux-dce.adb b/gcc/ada/libgnarl/s-osinte-hpux-dce.adb deleted file mode 100644 index a9d46a02e9a..00000000000 --- a/gcc/ada/libgnarl/s-osinte-hpux-dce.adb +++ /dev/null @@ -1,498 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-hpux-dce.ads b/gcc/ada/libgnarl/s-osinte-hpux-dce.ads deleted file mode 100644 index 28fb5ba8569..00000000000 --- a/gcc/ada/libgnarl/s-osinte-hpux-dce.ads +++ /dev/null @@ -1,486 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-hpux.ads b/gcc/ada/libgnarl/s-osinte-hpux.ads deleted file mode 100644 index 08c4b44ae2d..00000000000 --- a/gcc/ada/libgnarl/s-osinte-hpux.ads +++ /dev/null @@ -1,571 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-kfreebsd-gnu.ads b/gcc/ada/libgnarl/s-osinte-kfreebsd-gnu.ads deleted file mode 100644 index 647778bb053..00000000000 --- a/gcc/ada/libgnarl/s-osinte-kfreebsd-gnu.ads +++ /dev/null @@ -1,659 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-linux.ads b/gcc/ada/libgnarl/s-osinte-linux.ads deleted file mode 100644 index 87da7ff01a5..00000000000 --- a/gcc/ada/libgnarl/s-osinte-linux.ads +++ /dev/null @@ -1,678 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-lynxos178.adb b/gcc/ada/libgnarl/s-osinte-lynxos178.adb deleted file mode 100644 index 50e93538af0..00000000000 --- a/gcc/ada/libgnarl/s-osinte-lynxos178.adb +++ /dev/null @@ -1,180 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-lynxos178e.ads b/gcc/ada/libgnarl/s-osinte-lynxos178e.ads deleted file mode 100644 index 5eda0721c4e..00000000000 --- a/gcc/ada/libgnarl/s-osinte-lynxos178e.ads +++ /dev/null @@ -1,627 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-mingw.ads b/gcc/ada/libgnarl/s-osinte-mingw.ads deleted file mode 100644 index ed9bc591dbe..00000000000 --- a/gcc/ada/libgnarl/s-osinte-mingw.ads +++ /dev/null @@ -1,375 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-posix.adb b/gcc/ada/libgnarl/s-osinte-posix.adb deleted file mode 100644 index d8777318e05..00000000000 --- a/gcc/ada/libgnarl/s-osinte-posix.adb +++ /dev/null @@ -1,109 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-rtems.adb b/gcc/ada/libgnarl/s-osinte-rtems.adb deleted file mode 100644 index 9f01128c918..00000000000 --- a/gcc/ada/libgnarl/s-osinte-rtems.adb +++ /dev/null @@ -1,136 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-rtems.ads b/gcc/ada/libgnarl/s-osinte-rtems.ads deleted file mode 100644 index a658bbe8b0d..00000000000 --- a/gcc/ada/libgnarl/s-osinte-rtems.ads +++ /dev/null @@ -1,672 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-solaris.adb b/gcc/ada/libgnarl/s-osinte-solaris.adb deleted file mode 100644 index 40c1a720ac2..00000000000 --- a/gcc/ada/libgnarl/s-osinte-solaris.adb +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-solaris.ads b/gcc/ada/libgnarl/s-osinte-solaris.ads deleted file mode 100644 index 39d05109def..00000000000 --- a/gcc/ada/libgnarl/s-osinte-solaris.ads +++ /dev/null @@ -1,555 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-vxworks.adb b/gcc/ada/libgnarl/s-osinte-vxworks.adb deleted file mode 100644 index 6da3ff5a018..00000000000 --- a/gcc/ada/libgnarl/s-osinte-vxworks.adb +++ /dev/null @@ -1,238 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-vxworks.ads b/gcc/ada/libgnarl/s-osinte-vxworks.ads deleted file mode 100644 index 7ae547d10b4..00000000000 --- a/gcc/ada/libgnarl/s-osinte-vxworks.ads +++ /dev/null @@ -1,523 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte-x32.adb b/gcc/ada/libgnarl/s-osinte-x32.adb deleted file mode 100644 index a2874be3d69..00000000000 --- a/gcc/ada/libgnarl/s-osinte-x32.adb +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-osinte__aix.adb b/gcc/ada/libgnarl/s-osinte__aix.adb new file mode 100644 index 00000000000..a708eafeab1 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__aix.adb @@ -0,0 +1,190 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__aix.ads b/gcc/ada/libgnarl/s-osinte__aix.ads new file mode 100644 index 00000000000..be5f64dc73e --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__aix.ads @@ -0,0 +1,610 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__android.adb b/gcc/ada/libgnarl/s-osinte__android.adb new file mode 100644 index 00000000000..fcb504f2e61 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__android.adb @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__android.ads b/gcc/ada/libgnarl/s-osinte__android.ads new file mode 100644 index 00000000000..d13af018c93 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__android.ads @@ -0,0 +1,644 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is 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; diff --git a/gcc/ada/libgnarl/s-osinte__darwin.adb b/gcc/ada/libgnarl/s-osinte__darwin.adb new file mode 100644 index 00000000000..dcac8c095b8 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__darwin.adb @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__darwin.ads b/gcc/ada/libgnarl/s-osinte__darwin.ads new file mode 100644 index 00000000000..b86b5c901bc --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__darwin.ads @@ -0,0 +1,601 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__dragonfly.adb b/gcc/ada/libgnarl/s-osinte__dragonfly.adb new file mode 100644 index 00000000000..dc9e19c1984 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__dragonfly.adb @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__dragonfly.ads b/gcc/ada/libgnarl/s-osinte__dragonfly.ads new file mode 100644 index 00000000000..a67702ca82c --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__dragonfly.ads @@ -0,0 +1,652 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__dummy.ads b/gcc/ada/libgnarl/s-osinte__dummy.ads new file mode 100644 index 00000000000..09631cf19c1 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__dummy.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__freebsd.adb b/gcc/ada/libgnarl/s-osinte__freebsd.adb new file mode 100644 index 00000000000..28aea88a399 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__freebsd.adb @@ -0,0 +1,115 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__freebsd.ads b/gcc/ada/libgnarl/s-osinte__freebsd.ads new file mode 100644 index 00000000000..bf9bbeeeb27 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__freebsd.ads @@ -0,0 +1,652 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__gnu.adb b/gcc/ada/libgnarl/s-osinte__gnu.adb new file mode 100644 index 00000000000..fb099acfc7d --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__gnu.adb @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__gnu.ads b/gcc/ada/libgnarl/s-osinte__gnu.ads new file mode 100644 index 00000000000..183c5b83f60 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__gnu.ads @@ -0,0 +1,800 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.adb b/gcc/ada/libgnarl/s-osinte__hpux-dce.adb new file mode 100644 index 00000000000..a9d46a02e9a --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__hpux-dce.adb @@ -0,0 +1,498 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__hpux-dce.ads b/gcc/ada/libgnarl/s-osinte__hpux-dce.ads new file mode 100644 index 00000000000..28fb5ba8569 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__hpux-dce.ads @@ -0,0 +1,486 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__hpux.ads b/gcc/ada/libgnarl/s-osinte__hpux.ads new file mode 100644 index 00000000000..08c4b44ae2d --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__hpux.ads @@ -0,0 +1,571 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads b/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads new file mode 100644 index 00000000000..647778bb053 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads @@ -0,0 +1,659 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__linux.ads b/gcc/ada/libgnarl/s-osinte__linux.ads new file mode 100644 index 00000000000..87da7ff01a5 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__linux.ads @@ -0,0 +1,678 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__lynxos178.adb b/gcc/ada/libgnarl/s-osinte__lynxos178.adb new file mode 100644 index 00000000000..50e93538af0 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__lynxos178.adb @@ -0,0 +1,180 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__lynxos178e.ads b/gcc/ada/libgnarl/s-osinte__lynxos178e.ads new file mode 100644 index 00000000000..5eda0721c4e --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__lynxos178e.ads @@ -0,0 +1,627 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__mingw.ads b/gcc/ada/libgnarl/s-osinte__mingw.ads new file mode 100644 index 00000000000..ed9bc591dbe --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__mingw.ads @@ -0,0 +1,375 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__posix.adb b/gcc/ada/libgnarl/s-osinte__posix.adb new file mode 100644 index 00000000000..d8777318e05 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__posix.adb @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__rtems.adb b/gcc/ada/libgnarl/s-osinte__rtems.adb new file mode 100644 index 00000000000..9f01128c918 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__rtems.adb @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__rtems.ads b/gcc/ada/libgnarl/s-osinte__rtems.ads new file mode 100644 index 00000000000..a658bbe8b0d --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__rtems.ads @@ -0,0 +1,672 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__solaris.adb b/gcc/ada/libgnarl/s-osinte__solaris.adb new file mode 100644 index 00000000000..40c1a720ac2 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__solaris.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__solaris.ads b/gcc/ada/libgnarl/s-osinte__solaris.ads new file mode 100644 index 00000000000..39d05109def --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__solaris.ads @@ -0,0 +1,555 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__vxworks.adb b/gcc/ada/libgnarl/s-osinte__vxworks.adb new file mode 100644 index 00000000000..6da3ff5a018 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__vxworks.adb @@ -0,0 +1,238 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__vxworks.ads b/gcc/ada/libgnarl/s-osinte__vxworks.ads new file mode 100644 index 00000000000..7ae547d10b4 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__vxworks.ads @@ -0,0 +1,523 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-osinte__x32.adb b/gcc/ada/libgnarl/s-osinte__x32.adb new file mode 100644 index 00000000000..a2874be3d69 --- /dev/null +++ b/gcc/ada/libgnarl/s-osinte__x32.adb @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-taprop-dummy.adb b/gcc/ada/libgnarl/s-taprop-dummy.adb deleted file mode 100644 index 5ee5420a7bf..00000000000 --- a/gcc/ada/libgnarl/s-taprop-dummy.adb +++ /dev/null @@ -1,551 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is 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; diff --git a/gcc/ada/libgnarl/s-taprop-hpux-dce.adb b/gcc/ada/libgnarl/s-taprop-hpux-dce.adb deleted file mode 100644 index 1c5dcc1a024..00000000000 --- a/gcc/ada/libgnarl/s-taprop-hpux-dce.adb +++ /dev/null @@ -1,1247 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-taprop-linux.adb b/gcc/ada/libgnarl/s-taprop-linux.adb deleted file mode 100644 index cc49205cf0a..00000000000 --- a/gcc/ada/libgnarl/s-taprop-linux.adb +++ /dev/null @@ -1,1637 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-taprop-mingw.adb b/gcc/ada/libgnarl/s-taprop-mingw.adb deleted file mode 100644 index fa966514568..00000000000 --- a/gcc/ada/libgnarl/s-taprop-mingw.adb +++ /dev/null @@ -1,1406 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is 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; diff --git a/gcc/ada/libgnarl/s-taprop-posix.adb b/gcc/ada/libgnarl/s-taprop-posix.adb deleted file mode 100644 index 3efc1e0de1a..00000000000 --- a/gcc/ada/libgnarl/s-taprop-posix.adb +++ /dev/null @@ -1,1540 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is 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; diff --git a/gcc/ada/libgnarl/s-taprop-solaris.adb b/gcc/ada/libgnarl/s-taprop-solaris.adb deleted file mode 100644 index e97662c12b1..00000000000 --- a/gcc/ada/libgnarl/s-taprop-solaris.adb +++ /dev/null @@ -1,2063 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is 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; diff --git a/gcc/ada/libgnarl/s-taprop-vxworks.adb b/gcc/ada/libgnarl/s-taprop-vxworks.adb deleted file mode 100644 index b77fb106b37..00000000000 --- a/gcc/ada/libgnarl/s-taprop-vxworks.adb +++ /dev/null @@ -1,1472 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the 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; diff --git a/gcc/ada/libgnarl/s-taprop__dummy.adb b/gcc/ada/libgnarl/s-taprop__dummy.adb new file mode 100644 index 00000000000..5ee5420a7bf --- /dev/null +++ b/gcc/ada/libgnarl/s-taprop__dummy.adb @@ -0,0 +1,551 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is 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; diff --git a/gcc/ada/libgnarl/s-taprop__hpux-dce.adb b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb new file mode 100644 index 00000000000..1c5dcc1a024 --- /dev/null +++ b/gcc/ada/libgnarl/s-taprop__hpux-dce.adb @@ -0,0 +1,1247 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb new file mode 100644 index 00000000000..cc49205cf0a --- /dev/null +++ b/gcc/ada/libgnarl/s-taprop__linux.adb @@ -0,0 +1,1637 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-taprop__mingw.adb b/gcc/ada/libgnarl/s-taprop__mingw.adb new file mode 100644 index 00000000000..fa966514568 --- /dev/null +++ b/gcc/ada/libgnarl/s-taprop__mingw.adb @@ -0,0 +1,1406 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is 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; diff --git a/gcc/ada/libgnarl/s-taprop__posix.adb b/gcc/ada/libgnarl/s-taprop__posix.adb new file mode 100644 index 00000000000..3efc1e0de1a --- /dev/null +++ b/gcc/ada/libgnarl/s-taprop__posix.adb @@ -0,0 +1,1540 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is 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; diff --git a/gcc/ada/libgnarl/s-taprop__solaris.adb b/gcc/ada/libgnarl/s-taprop__solaris.adb new file mode 100644 index 00000000000..e97662c12b1 --- /dev/null +++ b/gcc/ada/libgnarl/s-taprop__solaris.adb @@ -0,0 +1,2063 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is 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; diff --git a/gcc/ada/libgnarl/s-taprop__vxworks.adb b/gcc/ada/libgnarl/s-taprop__vxworks.adb new file mode 100644 index 00000000000..b77fb106b37 --- /dev/null +++ b/gcc/ada/libgnarl/s-taprop__vxworks.adb @@ -0,0 +1,1472 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the 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; diff --git a/gcc/ada/libgnarl/s-tasinf-linux.adb b/gcc/ada/libgnarl/s-tasinf-linux.adb deleted file mode 100644 index 6484fb4273c..00000000000 --- a/gcc/ada/libgnarl/s-tasinf-linux.adb +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-tasinf-linux.ads b/gcc/ada/libgnarl/s-tasinf-linux.ads deleted file mode 100644 index 2ca039e2672..00000000000 --- a/gcc/ada/libgnarl/s-tasinf-linux.ads +++ /dev/null @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-tasinf-mingw.adb b/gcc/ada/libgnarl/s-tasinf-mingw.adb deleted file mode 100644 index cde440bad3d..00000000000 --- a/gcc/ada/libgnarl/s-tasinf-mingw.adb +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-tasinf-mingw.ads b/gcc/ada/libgnarl/s-tasinf-mingw.ads deleted file mode 100644 index e8a7eaf41f5..00000000000 --- a/gcc/ada/libgnarl/s-tasinf-mingw.ads +++ /dev/null @@ -1,103 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-tasinf-solaris.adb b/gcc/ada/libgnarl/s-tasinf-solaris.adb deleted file mode 100644 index 02f30fd11f8..00000000000 --- a/gcc/ada/libgnarl/s-tasinf-solaris.adb +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-tasinf-solaris.ads b/gcc/ada/libgnarl/s-tasinf-solaris.ads deleted file mode 100644 index f938f9943dd..00000000000 --- a/gcc/ada/libgnarl/s-tasinf-solaris.ads +++ /dev/null @@ -1,142 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-tasinf-vxworks.ads b/gcc/ada/libgnarl/s-tasinf-vxworks.ads deleted file mode 100644 index 49b71497d7e..00000000000 --- a/gcc/ada/libgnarl/s-tasinf-vxworks.ads +++ /dev/null @@ -1,88 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-tasinf__linux.adb b/gcc/ada/libgnarl/s-tasinf__linux.adb new file mode 100644 index 00000000000..6484fb4273c --- /dev/null +++ b/gcc/ada/libgnarl/s-tasinf__linux.adb @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-tasinf__linux.ads b/gcc/ada/libgnarl/s-tasinf__linux.ads new file mode 100644 index 00000000000..2ca039e2672 --- /dev/null +++ b/gcc/ada/libgnarl/s-tasinf__linux.ads @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-tasinf__mingw.adb b/gcc/ada/libgnarl/s-tasinf__mingw.adb new file mode 100644 index 00000000000..cde440bad3d --- /dev/null +++ b/gcc/ada/libgnarl/s-tasinf__mingw.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-tasinf__mingw.ads b/gcc/ada/libgnarl/s-tasinf__mingw.ads new file mode 100644 index 00000000000..e8a7eaf41f5 --- /dev/null +++ b/gcc/ada/libgnarl/s-tasinf__mingw.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-tasinf__solaris.adb b/gcc/ada/libgnarl/s-tasinf__solaris.adb new file mode 100644 index 00000000000..02f30fd11f8 --- /dev/null +++ b/gcc/ada/libgnarl/s-tasinf__solaris.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-tasinf__solaris.ads b/gcc/ada/libgnarl/s-tasinf__solaris.ads new file mode 100644 index 00000000000..f938f9943dd --- /dev/null +++ b/gcc/ada/libgnarl/s-tasinf__solaris.ads @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-tasinf__vxworks.ads b/gcc/ada/libgnarl/s-tasinf__vxworks.ads new file mode 100644 index 00000000000..49b71497d7e --- /dev/null +++ b/gcc/ada/libgnarl/s-tasinf__vxworks.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-taspri-dummy.ads b/gcc/ada/libgnarl/s-taspri-dummy.ads deleted file mode 100644 index 415157c6c8a..00000000000 --- a/gcc/ada/libgnarl/s-taspri-dummy.ads +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-taspri-hpux-dce.ads b/gcc/ada/libgnarl/s-taspri-hpux-dce.ads deleted file mode 100644 index 137f34b8aed..00000000000 --- a/gcc/ada/libgnarl/s-taspri-hpux-dce.ads +++ /dev/null @@ -1,115 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-taspri-lynxos.ads b/gcc/ada/libgnarl/s-taspri-lynxos.ads deleted file mode 100644 index 298c0699fc5..00000000000 --- a/gcc/ada/libgnarl/s-taspri-lynxos.ads +++ /dev/null @@ -1,118 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-taspri-mingw.ads b/gcc/ada/libgnarl/s-taspri-mingw.ads deleted file mode 100644 index 3a913e60f9c..00000000000 --- a/gcc/ada/libgnarl/s-taspri-mingw.ads +++ /dev/null @@ -1,119 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-taspri-posix-noaltstack.ads b/gcc/ada/libgnarl/s-taspri-posix-noaltstack.ads deleted file mode 100644 index 092689ece76..00000000000 --- a/gcc/ada/libgnarl/s-taspri-posix-noaltstack.ads +++ /dev/null @@ -1,121 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-taspri-posix.ads b/gcc/ada/libgnarl/s-taspri-posix.ads deleted file mode 100644 index 607b8a7380e..00000000000 --- a/gcc/ada/libgnarl/s-taspri-posix.ads +++ /dev/null @@ -1,120 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-taspri-solaris.ads b/gcc/ada/libgnarl/s-taspri-solaris.ads deleted file mode 100644 index c6dbac460ff..00000000000 --- a/gcc/ada/libgnarl/s-taspri-solaris.ads +++ /dev/null @@ -1,151 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-taspri-vxworks.ads b/gcc/ada/libgnarl/s-taspri-vxworks.ads deleted file mode 100644 index 3450b362f0b..00000000000 --- a/gcc/ada/libgnarl/s-taspri-vxworks.ads +++ /dev/null @@ -1,121 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-taspri__dummy.ads b/gcc/ada/libgnarl/s-taspri__dummy.ads new file mode 100644 index 00000000000..415157c6c8a --- /dev/null +++ b/gcc/ada/libgnarl/s-taspri__dummy.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-taspri__hpux-dce.ads b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads new file mode 100644 index 00000000000..137f34b8aed --- /dev/null +++ b/gcc/ada/libgnarl/s-taspri__hpux-dce.ads @@ -0,0 +1,115 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-taspri__lynxos.ads b/gcc/ada/libgnarl/s-taspri__lynxos.ads new file mode 100644 index 00000000000..298c0699fc5 --- /dev/null +++ b/gcc/ada/libgnarl/s-taspri__lynxos.ads @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-taspri__mingw.ads b/gcc/ada/libgnarl/s-taspri__mingw.ads new file mode 100644 index 00000000000..3a913e60f9c --- /dev/null +++ b/gcc/ada/libgnarl/s-taspri__mingw.ads @@ -0,0 +1,119 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads b/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads new file mode 100644 index 00000000000..092689ece76 --- /dev/null +++ b/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-taspri__posix.ads b/gcc/ada/libgnarl/s-taspri__posix.ads new file mode 100644 index 00000000000..607b8a7380e --- /dev/null +++ b/gcc/ada/libgnarl/s-taspri__posix.ads @@ -0,0 +1,120 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-taspri__solaris.ads b/gcc/ada/libgnarl/s-taspri__solaris.ads new file mode 100644 index 00000000000..c6dbac460ff --- /dev/null +++ b/gcc/ada/libgnarl/s-taspri__solaris.ads @@ -0,0 +1,151 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-taspri__vxworks.ads b/gcc/ada/libgnarl/s-taspri__vxworks.ads new file mode 100644 index 00000000000..3450b362f0b --- /dev/null +++ b/gcc/ada/libgnarl/s-taspri__vxworks.ads @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-tpopsp-posix-foreign.adb b/gcc/ada/libgnarl/s-tpopsp-posix-foreign.adb deleted file mode 100644 index 66f979ea8f1..00000000000 --- a/gcc/ada/libgnarl/s-tpopsp-posix-foreign.adb +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-tpopsp-posix.adb b/gcc/ada/libgnarl/s-tpopsp-posix.adb deleted file mode 100644 index f38308fd033..00000000000 --- a/gcc/ada/libgnarl/s-tpopsp-posix.adb +++ /dev/null @@ -1,81 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-tpopsp-solaris.adb b/gcc/ada/libgnarl/s-tpopsp-solaris.adb deleted file mode 100644 index 7c00d057ee4..00000000000 --- a/gcc/ada/libgnarl/s-tpopsp-solaris.adb +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-tpopsp-tls.adb b/gcc/ada/libgnarl/s-tpopsp-tls.adb deleted file mode 100644 index d21d2bebe14..00000000000 --- a/gcc/ada/libgnarl/s-tpopsp-tls.adb +++ /dev/null @@ -1,97 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-tpopsp-vxworks-tls.adb b/gcc/ada/libgnarl/s-tpopsp-vxworks-tls.adb deleted file mode 100644 index 744ec488ac6..00000000000 --- a/gcc/ada/libgnarl/s-tpopsp-vxworks-tls.adb +++ /dev/null @@ -1,79 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-tpopsp-vxworks.adb b/gcc/ada/libgnarl/s-tpopsp-vxworks.adb deleted file mode 100644 index bc343b1e16c..00000000000 --- a/gcc/ada/libgnarl/s-tpopsp-vxworks.adb +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-tpopsp__posix-foreign.adb b/gcc/ada/libgnarl/s-tpopsp__posix-foreign.adb new file mode 100644 index 00000000000..66f979ea8f1 --- /dev/null +++ b/gcc/ada/libgnarl/s-tpopsp__posix-foreign.adb @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-tpopsp__posix.adb b/gcc/ada/libgnarl/s-tpopsp__posix.adb new file mode 100644 index 00000000000..f38308fd033 --- /dev/null +++ b/gcc/ada/libgnarl/s-tpopsp__posix.adb @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-tpopsp__solaris.adb b/gcc/ada/libgnarl/s-tpopsp__solaris.adb new file mode 100644 index 00000000000..7c00d057ee4 --- /dev/null +++ b/gcc/ada/libgnarl/s-tpopsp__solaris.adb @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-tpopsp__tls.adb b/gcc/ada/libgnarl/s-tpopsp__tls.adb new file mode 100644 index 00000000000..d21d2bebe14 --- /dev/null +++ b/gcc/ada/libgnarl/s-tpopsp__tls.adb @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-tpopsp__vxworks-tls.adb b/gcc/ada/libgnarl/s-tpopsp__vxworks-tls.adb new file mode 100644 index 00000000000..744ec488ac6 --- /dev/null +++ b/gcc/ada/libgnarl/s-tpopsp__vxworks-tls.adb @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-tpopsp__vxworks.adb b/gcc/ada/libgnarl/s-tpopsp__vxworks.adb new file mode 100644 index 00000000000..bc343b1e16c --- /dev/null +++ b/gcc/ada/libgnarl/s-tpopsp__vxworks.adb @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-vxwext-kernel.adb b/gcc/ada/libgnarl/s-vxwext-kernel.adb deleted file mode 100644 index 9b43b3b7900..00000000000 --- a/gcc/ada/libgnarl/s-vxwext-kernel.adb +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- ------------------------------------------------------------------------------- - --- 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; diff --git a/gcc/ada/libgnarl/s-vxwext-kernel.ads b/gcc/ada/libgnarl/s-vxwext-kernel.ads deleted file mode 100644 index 914f281c2b5..00000000000 --- a/gcc/ada/libgnarl/s-vxwext-kernel.ads +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- ------------------------------------------------------------------------------- - --- 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; diff --git a/gcc/ada/libgnarl/s-vxwext-rtp-smp.adb b/gcc/ada/libgnarl/s-vxwext-rtp-smp.adb deleted file mode 100644 index 18ad35fdc35..00000000000 --- a/gcc/ada/libgnarl/s-vxwext-rtp-smp.adb +++ /dev/null @@ -1,138 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- ------------------------------------------------------------------------------- - --- 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; diff --git a/gcc/ada/libgnarl/s-vxwext-rtp.adb b/gcc/ada/libgnarl/s-vxwext-rtp.adb deleted file mode 100644 index f53aba1055c..00000000000 --- a/gcc/ada/libgnarl/s-vxwext-rtp.adb +++ /dev/null @@ -1,135 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- ------------------------------------------------------------------------------- - --- 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; diff --git a/gcc/ada/libgnarl/s-vxwext-rtp.ads b/gcc/ada/libgnarl/s-vxwext-rtp.ads deleted file mode 100644 index e4235a9984f..00000000000 --- a/gcc/ada/libgnarl/s-vxwext-rtp.ads +++ /dev/null @@ -1,104 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- ------------------------------------------------------------------------------- - --- 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; diff --git a/gcc/ada/libgnarl/s-vxwext-vthreads.ads b/gcc/ada/libgnarl/s-vxwext-vthreads.ads deleted file mode 100644 index 6fb923b5ee7..00000000000 --- a/gcc/ada/libgnarl/s-vxwext-vthreads.ads +++ /dev/null @@ -1,109 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- ------------------------------------------------------------------------------- - --- 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; diff --git a/gcc/ada/libgnarl/s-vxwext__kernel.adb b/gcc/ada/libgnarl/s-vxwext__kernel.adb new file mode 100644 index 00000000000..9b43b3b7900 --- /dev/null +++ b/gcc/ada/libgnarl/s-vxwext__kernel.adb @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- 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; diff --git a/gcc/ada/libgnarl/s-vxwext__kernel.ads b/gcc/ada/libgnarl/s-vxwext__kernel.ads new file mode 100644 index 00000000000..914f281c2b5 --- /dev/null +++ b/gcc/ada/libgnarl/s-vxwext__kernel.ads @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- 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; diff --git a/gcc/ada/libgnarl/s-vxwext__rtp-smp.adb b/gcc/ada/libgnarl/s-vxwext__rtp-smp.adb new file mode 100644 index 00000000000..18ad35fdc35 --- /dev/null +++ b/gcc/ada/libgnarl/s-vxwext__rtp-smp.adb @@ -0,0 +1,138 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- 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; diff --git a/gcc/ada/libgnarl/s-vxwext__rtp.adb b/gcc/ada/libgnarl/s-vxwext__rtp.adb new file mode 100644 index 00000000000..f53aba1055c --- /dev/null +++ b/gcc/ada/libgnarl/s-vxwext__rtp.adb @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- 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; diff --git a/gcc/ada/libgnarl/s-vxwext__rtp.ads b/gcc/ada/libgnarl/s-vxwext__rtp.ads new file mode 100644 index 00000000000..e4235a9984f --- /dev/null +++ b/gcc/ada/libgnarl/s-vxwext__rtp.ads @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- 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; diff --git a/gcc/ada/libgnarl/s-vxwext__vthreads.ads b/gcc/ada/libgnarl/s-vxwext__vthreads.ads new file mode 100644 index 00000000000..6fb923b5ee7 --- /dev/null +++ b/gcc/ada/libgnarl/s-vxwext__vthreads.ads @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- 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; diff --git a/gcc/ada/libgnarl/s-vxwork-arm.ads b/gcc/ada/libgnarl/s-vxwork-arm.ads deleted file mode 100644 index ec9c294b6c4..00000000000 --- a/gcc/ada/libgnarl/s-vxwork-arm.ads +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-vxwork-ppc.ads b/gcc/ada/libgnarl/s-vxwork-ppc.ads deleted file mode 100644 index 3c7f4a0766d..00000000000 --- a/gcc/ada/libgnarl/s-vxwork-ppc.ads +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-vxwork-x86.ads b/gcc/ada/libgnarl/s-vxwork-x86.ads deleted file mode 100644 index f40a78a004c..00000000000 --- a/gcc/ada/libgnarl/s-vxwork-x86.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/libgnarl/s-vxwork__arm.ads b/gcc/ada/libgnarl/s-vxwork__arm.ads new file mode 100644 index 00000000000..ec9c294b6c4 --- /dev/null +++ b/gcc/ada/libgnarl/s-vxwork__arm.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-vxwork__ppc.ads b/gcc/ada/libgnarl/s-vxwork__ppc.ads new file mode 100644 index 00000000000..3c7f4a0766d --- /dev/null +++ b/gcc/ada/libgnarl/s-vxwork__ppc.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/libgnarl/s-vxwork__x86.ads b/gcc/ada/libgnarl/s-vxwork__x86.ads new file mode 100644 index 00000000000..f40a78a004c --- /dev/null +++ b/gcc/ada/libgnarl/s-vxwork__x86.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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;