From: Nicolas Roche Date: Fri, 8 Sep 2017 13:14:59 +0000 (+0000) Subject: Makefile.in, [...]: Move libgnarl sources to libgnarl subdir. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=cfc29a96f8909d8112d7b3e81984801eb3bb505e;p=gcc.git Makefile.in, [...]: Move libgnarl sources to libgnarl subdir. 2017-09-08 Nicolas Roche * gcc-interface/Makefile.in, a-extiti.ads, s-taprop-linux.adb, s-osinte-solaris.adb, a-intnam.ads, s-osinte-solaris.ads, s-tpobop.adb, s-intman-android.adb, s-tasinf.adb, s-tpobop.ads, s-tasinf.ads, i-vxinco.adb, a-exetim-posix.adb, i-vxinco.ads, a-astaco.adb, a-astaco.ads, s-tporft.adb, s-tpoaal.adb, a-taside.adb, a-taside.ads, s-tpopsp-posix.adb, s-tasdeb.adb, s-tasdeb.ads, s-tpoben.adb, a-dinopr.ads, s-inmaop-vxworks.adb, s-tpoben.ads, s-interr-vxworks.adb, s-interr-dummy.adb, s-tassta.adb, a-intnam-mingw.ads, s-tassta.ads, s-taasde.adb, a-stcoed.ads, s-taasde.ads, s-osinte-darwin.adb, s-proinf.adb, s-taprop-dummy.adb, s-osinte-darwin.ads, s-proinf.ads, s-linux.ads, a-intnam-linux.ads, s-tasren.adb, s-tasren.ads, s-mudido.adb, g-semaph.adb, s-mudido.ads, s-taprop-posix.adb, g-semaph.ads, s-osinte-mingw.ads, s-vxwork-x86.ads, s-tposen.adb, s-linux-sparc.ads, s-taprop-vxworks.adb, s-tasini.adb, s-tposen.ads, s-tasini.ads, a-etgrbu.ads, s-interr-hwint.adb, s-osinte-linux.ads, s-taprop.ads, s-tasque.adb, s-tasque.ads, s-taenca.adb, s-taspri-vxworks.ads, s-taenca.ads, a-dynpri.adb, s-tpopsp-solaris.adb, a-dynpri.ads, s-taprop-hpux-dce.adb, a-interr.adb, a-intnam-freebsd.ads, s-tarest.adb, a-interr.ads, s-intman-susv3.adb, a-synbar.adb, a-intnam-dummy.ads, s-tadeca.adb, s-osinte-vxworks.adb, s-tarest.ads, s-taskin.adb, a-synbar.ads, s-taspri-hpux-dce.ads, s-tadeca.ads, s-osinte-vxworks.ads, s-taskin.ads, s-intman-solaris.adb, a-sytaco.adb, s-vxwext-kernel.adb, s-mudido-affinity.adb, a-sytaco.ads, s-vxwext-kernel.ads, s-taprob.adb, s-intman-mingw.adb, s-taprob.ads, s-osinte-kfreebsd-gnu.ads, s-osinte-dummy.ads, s-osinte-gnu.adb, s-osinte-rtems.adb, s-interr.adb, s-inmaop.ads, s-vxwext-rtp.adb, s-osinte-gnu.ads, s-osinte-rtems.ads, a-synbar-posix.adb, s-interr.ads, s-taspri-posix-noaltstack.ads, s-vxwext-rtp.ads, a-synbar-posix.ads, a-extiin.ads, s-osinte-posix.adb, s-tpinop.adb, s-tasres.ads, s-tpinop.ads, a-disedf.ads, a-diroro.ads, s-linux-alpha.ads, a-tasatt.adb, s-solita.adb, a-intnam-solaris.ads, a-tasatt.ads, s-solita.ads, s-tasinf-solaris.adb, s-tasinf-solaris.ads, s-vxwork-arm.ads, s-tpopsp-posix-foreign.adb, s-intman-dummy.adb, s-intman.ads, s-stusta.adb, s-stusta.ads, s-intman-posix.adb, s-tpopsp-vxworks.adb, s-inmaop-dummy.adb, s-taspri-mingw.ads, a-intnam-darwin.ads, s-osinte-aix.adb, s-osinte-dragonfly.adb, s-osinte-aix.ads, s-tasinf-mingw.adb, s-osinte-dragonfly.ads, s-linux-hppa.ads, s-osinte-x32.adb, s-inmaop-posix.adb, s-tasinf-mingw.ads, s-intman-vxworks.adb, s-linux-mips.ads, s-intman-vxworks.ads, s-osinte-android.adb, s-tasinf-linux.adb, s-osinte-android.ads, s-vxwork-ppc.ads, s-tasinf-linux.ads, a-dispat.adb, a-dispat.ads, s-tadert.adb, g-thread.adb, s-tadert.ads, g-thread.ads, a-intnam-hpux.ads, s-linux-android.ads, s-tataat.adb, a-exetim.ads, s-tataat.ads, a-reatim.adb, a-reatim.ads, thread.c, g-boubuf.adb, s-osinte-freebsd.adb, g-boubuf.ads, s-osinte-freebsd.ads, s-tasuti.adb, s-taspri-dummy.ads, a-exetim-mingw.adb, s-linux-x32.ads, s-tasuti.ads, g-signal.adb, a-exetim-mingw.ads, s-interr-sigaction.adb, g-signal.ads, s-osinte-hpux.ads, a-intnam-vxworks.ads, s-osinte-hpux-dce.adb, s-taspri-posix.ads, s-osinte-hpux-dce.ads, s-tasinf-vxworks.ads, g-tastus.ads, s-tpopsp-tls.adb, s-taprop-solaris.adb, a-retide.adb, a-exetim-darwin.adb, a-retide.ads, s-vxwext.adb, s-vxwext.ads, a-rttiev.adb, a-rttiev.ads, g-boumai.ads, a-exetim-default.ads, s-taprop-mingw.adb, s-taspri-solaris.ads, a-intnam-aix.ads: Move libgnarl sources to libgnarl subdir. From-SVN: r251891 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0ee9488bd3a..61dc74024be 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,60 @@ +2017-09-08 Nicolas Roche + + * gcc-interface/Makefile.in, a-extiti.ads, s-taprop-linux.adb, + s-osinte-solaris.adb, a-intnam.ads, s-osinte-solaris.ads, + s-tpobop.adb, s-intman-android.adb, s-tasinf.adb, s-tpobop.ads, + s-tasinf.ads, i-vxinco.adb, a-exetim-posix.adb, i-vxinco.ads, + a-astaco.adb, a-astaco.ads, s-tporft.adb, s-tpoaal.adb, a-taside.adb, + a-taside.ads, s-tpopsp-posix.adb, s-tasdeb.adb, s-tasdeb.ads, + s-tpoben.adb, a-dinopr.ads, s-inmaop-vxworks.adb, s-tpoben.ads, + s-interr-vxworks.adb, s-interr-dummy.adb, s-tassta.adb, + a-intnam-mingw.ads, s-tassta.ads, s-taasde.adb, a-stcoed.ads, + s-taasde.ads, s-osinte-darwin.adb, s-proinf.adb, s-taprop-dummy.adb, + s-osinte-darwin.ads, s-proinf.ads, s-linux.ads, a-intnam-linux.ads, + s-tasren.adb, s-tasren.ads, s-mudido.adb, g-semaph.adb, s-mudido.ads, + s-taprop-posix.adb, g-semaph.ads, s-osinte-mingw.ads, s-vxwork-x86.ads, + s-tposen.adb, s-linux-sparc.ads, s-taprop-vxworks.adb, s-tasini.adb, + s-tposen.ads, s-tasini.ads, a-etgrbu.ads, s-interr-hwint.adb, + s-osinte-linux.ads, s-taprop.ads, s-tasque.adb, s-tasque.ads, + s-taenca.adb, s-taspri-vxworks.ads, s-taenca.ads, a-dynpri.adb, + s-tpopsp-solaris.adb, a-dynpri.ads, s-taprop-hpux-dce.adb, + a-interr.adb, a-intnam-freebsd.ads, s-tarest.adb, a-interr.ads, + s-intman-susv3.adb, a-synbar.adb, a-intnam-dummy.ads, s-tadeca.adb, + s-osinte-vxworks.adb, s-tarest.ads, s-taskin.adb, a-synbar.ads, + s-taspri-hpux-dce.ads, s-tadeca.ads, s-osinte-vxworks.ads, + s-taskin.ads, s-intman-solaris.adb, a-sytaco.adb, s-vxwext-kernel.adb, + s-mudido-affinity.adb, a-sytaco.ads, s-vxwext-kernel.ads, s-taprob.adb, + s-intman-mingw.adb, s-taprob.ads, s-osinte-kfreebsd-gnu.ads, + s-osinte-dummy.ads, s-osinte-gnu.adb, s-osinte-rtems.adb, s-interr.adb, + s-inmaop.ads, s-vxwext-rtp.adb, s-osinte-gnu.ads, s-osinte-rtems.ads, + a-synbar-posix.adb, s-interr.ads, s-taspri-posix-noaltstack.ads, + s-vxwext-rtp.ads, a-synbar-posix.ads, a-extiin.ads, s-osinte-posix.adb, + s-tpinop.adb, s-tasres.ads, s-tpinop.ads, a-disedf.ads, a-diroro.ads, + s-linux-alpha.ads, a-tasatt.adb, s-solita.adb, a-intnam-solaris.ads, + a-tasatt.ads, s-solita.ads, s-tasinf-solaris.adb, s-tasinf-solaris.ads, + s-vxwork-arm.ads, s-tpopsp-posix-foreign.adb, s-intman-dummy.adb, + s-intman.ads, s-stusta.adb, s-stusta.ads, s-intman-posix.adb, + s-tpopsp-vxworks.adb, s-inmaop-dummy.adb, s-taspri-mingw.ads, + a-intnam-darwin.ads, s-osinte-aix.adb, s-osinte-dragonfly.adb, + s-osinte-aix.ads, s-tasinf-mingw.adb, s-osinte-dragonfly.ads, + s-linux-hppa.ads, s-osinte-x32.adb, s-inmaop-posix.adb, + s-tasinf-mingw.ads, s-intman-vxworks.adb, s-linux-mips.ads, + s-intman-vxworks.ads, s-osinte-android.adb, s-tasinf-linux.adb, + s-osinte-android.ads, s-vxwork-ppc.ads, s-tasinf-linux.ads, + a-dispat.adb, a-dispat.ads, s-tadert.adb, g-thread.adb, s-tadert.ads, + g-thread.ads, a-intnam-hpux.ads, s-linux-android.ads, s-tataat.adb, + a-exetim.ads, s-tataat.ads, a-reatim.adb, a-reatim.ads, thread.c, + g-boubuf.adb, s-osinte-freebsd.adb, g-boubuf.ads, s-osinte-freebsd.ads, + s-tasuti.adb, s-taspri-dummy.ads, a-exetim-mingw.adb, s-linux-x32.ads, + s-tasuti.ads, g-signal.adb, a-exetim-mingw.ads, s-interr-sigaction.adb, + g-signal.ads, s-osinte-hpux.ads, a-intnam-vxworks.ads, + s-osinte-hpux-dce.adb, s-taspri-posix.ads, s-osinte-hpux-dce.ads, + s-tasinf-vxworks.ads, g-tastus.ads, s-tpopsp-tls.adb, + s-taprop-solaris.adb, a-retide.adb, a-exetim-darwin.adb, a-retide.ads, + s-vxwext.adb, s-vxwext.ads, a-rttiev.adb, a-rttiev.ads, g-boumai.ads, + a-exetim-default.ads, s-taprop-mingw.adb, s-taspri-solaris.ads, + a-intnam-aix.ads: Move libgnarl sources to libgnarl subdir. + 2017-09-08 Arnaud Charlet * doc/share/conf.py, doc/share/latex_elements.py, diff --git a/gcc/ada/a-astaco.adb b/gcc/ada/a-astaco.adb deleted file mode 100644 index 3e4f362591f..00000000000 --- a/gcc/ada/a-astaco.adb +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . A S Y N C H R O N O U S _ T A S K _ C O N T R O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, 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 a dummy body, which will not normally be compiled when used with --- standard versions of GNAT, which do not support this package. See comments --- in spec for further details. - -package body Ada.Asynchronous_Task_Control is - - -------------- - -- Continue -- - -------------- - - procedure Continue (T : Ada.Task_Identification.Task_Id) is - begin - null; - end Continue; - - ---------- - -- Hold -- - ---------- - - procedure Hold (T : Ada.Task_Identification.Task_Id) is - begin - raise Program_Error; - end Hold; - - ------------- - -- Is_Held -- - ------------- - - function Is_Held (T : Ada.Task_Identification.Task_Id) return Boolean is - begin - return False; - end Is_Held; - -end Ada.Asynchronous_Task_Control; diff --git a/gcc/ada/a-astaco.ads b/gcc/ada/a-astaco.ads deleted file mode 100644 index 1fa7c25697d..00000000000 --- a/gcc/ada/a-astaco.ads +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . A S Y N C H R O N O U S _ T A S K _ C O N T R O L -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This unit is not implemented in typical GNAT implementations that lie on --- top of operating systems, because it is infeasible to implement in such --- environments. The RM anticipates this situation (RM D.11(10)), and permits --- an implementation to leave this unimplemented even if the Real-Time Systems --- annex is fully supported. - --- If a target environment provides appropriate support for this package, then --- the Unimplemented_Unit pragma should be removed from this spec, and an --- appropriate body provided. The framework for such a body is included in the --- distributed sources. - -with Ada.Task_Identification; - -package Ada.Asynchronous_Task_Control is - pragma Preelaborate; - -- In accordance with Ada 2005 AI-362 - - pragma Unimplemented_Unit; - - procedure Hold (T : Ada.Task_Identification.Task_Id); - - procedure Continue (T : Ada.Task_Identification.Task_Id); - - function Is_Held (T : Ada.Task_Identification.Task_Id) return Boolean; - -end Ada.Asynchronous_Task_Control; diff --git a/gcc/ada/a-dinopr.ads b/gcc/ada/a-dinopr.ads deleted file mode 100644 index 396aeaeae97..00000000000 --- a/gcc/ada/a-dinopr.ads +++ /dev/null @@ -1,31 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I S P A T C H I N G . N O N _ P R E E M P T I V E -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This unit is not implemented in typical GNAT implementations that lie on --- top of operating systems, because it is infeasible to implement in such --- environments. - --- If a target environment provides appropriate support for this package, --- then the Unimplemented_Unit pragma should be removed from this spec and --- an appropriate body provided. - -package Ada.Dispatching.Non_Preemptive is - pragma Preelaborate (Non_Preemptive); - - pragma Unimplemented_Unit; - - procedure Yield_To_Higher; - procedure Yield_To_Same_Or_Higher renames Yield; -end Ada.Dispatching.Non_Preemptive; diff --git a/gcc/ada/a-diroro.ads b/gcc/ada/a-diroro.ads deleted file mode 100644 index 2cdaeb1f2b1..00000000000 --- a/gcc/ada/a-diroro.ads +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I S P A T C H I N G . R O U N D _ R O B I N -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with System; -with Ada.Real_Time; - -package Ada.Dispatching.Round_Robin is - - pragma Unimplemented_Unit; - - Default_Quantum : constant Ada.Real_Time.Time_Span := - Ada.Real_Time.Milliseconds (10); - - procedure Set_Quantum - (Pri : System.Priority; - Quantum : Ada.Real_Time.Time_Span); - - procedure Set_Quantum - (Low, High : System.Priority; - Quantum : Ada.Real_Time.Time_Span); - - function Actual_Quantum - (Pri : System.Priority) return Ada.Real_Time.Time_Span; - - function Is_Round_Robin (Pri : System.Priority) return Boolean; - -end Ada.Dispatching.Round_Robin; diff --git a/gcc/ada/a-disedf.ads b/gcc/ada/a-disedf.ads deleted file mode 100644 index 4b28a6db333..00000000000 --- a/gcc/ada/a-disedf.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I S P A T C H I N G . E D F -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This unit is not implemented in typical GNAT implementations that lie on --- top of operating systems, because it is infeasible to implement in such --- environments. - --- If a target environment provides appropriate support for this package, --- then the Unimplemented_Unit pragma should be removed from this spec and --- an appropriate body provided. - -with Ada.Real_Time; -with Ada.Task_Identification; - -package Ada.Dispatching.EDF is - pragma Preelaborate; - - pragma Unimplemented_Unit; - - subtype Deadline is Ada.Real_Time.Time; - - Default_Deadline : constant Deadline := Ada.Real_Time.Time_Last; - - procedure Set_Deadline - (D : Deadline; - T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task); - - procedure Delay_Until_And_Set_Deadline - (Delay_Until_Time : Ada.Real_Time.Time; - Deadline_Offset : Ada.Real_Time.Time_Span); - - function Get_Deadline - (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) - return Deadline - with - SPARK_Mode, - Volatile_Function, - Global => Ada.Task_Identification.Tasking_State; - -end Ada.Dispatching.EDF; diff --git a/gcc/ada/a-dispat.adb b/gcc/ada/a-dispat.adb deleted file mode 100644 index 3525c4e06ff..00000000000 --- a/gcc/ada/a-dispat.adb +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I S P A T C H I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; -with System.Tasking; -with System.Task_Primitives.Operations; - -package body Ada.Dispatching is - - procedure Yield is - Self_Id : constant System.Tasking.Task_Id := - System.Task_Primitives.Operations.Self; - - begin - -- If pragma Detect_Blocking is active, Program_Error must be - -- raised if this potentially blocking operation is called from a - -- protected action. - - if System.Tasking.Detect_Blocking - and then Self_Id.Common.Protected_Action_Nesting > 0 - then - Ada.Exceptions.Raise_Exception - (Program_Error'Identity, "potentially blocking operation"); - else - System.Task_Primitives.Operations.Yield; - end if; - end Yield; - -end Ada.Dispatching; diff --git a/gcc/ada/a-dispat.ads b/gcc/ada/a-dispat.ads deleted file mode 100644 index b4e4d036b11..00000000000 --- a/gcc/ada/a-dispat.ads +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I S P A T C H I N G -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Dispatching is - pragma Preelaborate (Dispatching); - - procedure Yield with - Global => null; - - Dispatching_Policy_Error : exception; -end Ada.Dispatching; diff --git a/gcc/ada/a-dynpri.adb b/gcc/ada/a-dynpri.adb deleted file mode 100644 index 4e67934b7d9..00000000000 --- a/gcc/ada/a-dynpri.adb +++ /dev/null @@ -1,164 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . D Y N A M I C _ P R I O R I T I E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License 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. -- --- -- ------------------------------------------------------------------------------- - -with System.Task_Primitives.Operations; -with System.Tasking; -with System.Parameters; -with System.Soft_Links; - -with Ada.Unchecked_Conversion; - -package body Ada.Dynamic_Priorities is - - package STPO renames System.Task_Primitives.Operations; - package SSL renames System.Soft_Links; - - use System.Parameters; - use System.Tasking; - - function Convert_Ids is new - Ada.Unchecked_Conversion - (Task_Identification.Task_Id, System.Tasking.Task_Id); - - ------------------ - -- Get_Priority -- - ------------------ - - -- Inquire base priority of a task - - function Get_Priority - (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) return System.Any_Priority - is - Target : constant Task_Id := Convert_Ids (T); - Error_Message : constant String := "Trying to get the priority of a "; - - begin - if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then - raise Program_Error with Error_Message & "null task"; - end if; - - if Task_Identification.Is_Terminated (T) then - raise Tasking_Error with Error_Message & "terminated task"; - end if; - - return Target.Common.Base_Priority; - end Get_Priority; - - ------------------ - -- Set_Priority -- - ------------------ - - -- Change base priority of a task dynamically - - procedure Set_Priority - (Priority : System.Any_Priority; - T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) - is - Target : constant Task_Id := Convert_Ids (T); - Error_Message : constant String := "Trying to set the priority of a "; - Yield_Needed : Boolean; - - begin - if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then - raise Program_Error with Error_Message & "null task"; - end if; - - -- Setting the priority of an already-terminated task doesn't do - -- anything (see RM-D.5.1(7)). Note that Get_Priority is different in - -- this regard. - - if Task_Identification.Is_Terminated (T) then - return; - end if; - - SSL.Abort_Defer.all; - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Target); - - Target.Common.Base_Priority := Priority; - - if Target.Common.Call /= null - and then - Target.Common.Call.Acceptor_Prev_Priority /= Priority_Not_Boosted - then - -- Target is within a rendezvous, so ensure the correct priority - -- will be reset when finishing the rendezvous, and only change the - -- priority immediately if the new priority is greater than the - -- current (inherited) priority. - - Target.Common.Call.Acceptor_Prev_Priority := Priority; - - if Priority >= Target.Common.Current_Priority then - Yield_Needed := True; - STPO.Set_Priority (Target, Priority); - else - Yield_Needed := False; - end if; - - else - Yield_Needed := True; - STPO.Set_Priority (Target, Priority); - - if Target.Common.State = Entry_Caller_Sleep then - Target.Pending_Priority_Change := True; - STPO.Wakeup (Target, Target.Common.State); - end if; - end if; - - STPO.Unlock (Target); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - if STPO.Self = Target and then Yield_Needed then - - -- Yield is needed to enforce FIFO task dispatching - - -- LL Set_Priority is made while holding the RTS lock so that it is - -- inheriting high priority until it release all the RTS locks. - - -- If this is used in a system where Ceiling Locking is not enforced - -- we may end up getting two Yield effects. - - STPO.Yield; - end if; - - SSL.Abort_Undefer.all; - end Set_Priority; - -end Ada.Dynamic_Priorities; diff --git a/gcc/ada/a-dynpri.ads b/gcc/ada/a-dynpri.ads deleted file mode 100644 index 24fbbe48d8d..00000000000 --- a/gcc/ada/a-dynpri.ads +++ /dev/null @@ -1,33 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D Y N A M I C _ P R I O R I T I E S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with System; -with Ada.Task_Identification; - -package Ada.Dynamic_Priorities is - pragma Preelaborate; - -- In accordance with Ada 2005 AI-362 - - procedure Set_Priority - (Priority : System.Any_Priority; - T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task); - - function Get_Priority - (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) - return System.Any_Priority; - -end Ada.Dynamic_Priorities; diff --git a/gcc/ada/a-etgrbu.ads b/gcc/ada/a-etgrbu.ads deleted file mode 100644 index f7c21e5cc92..00000000000 --- a/gcc/ada/a-etgrbu.ads +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E X E C U T I O N _ T I M E . G R O U P _ B U D G E T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2015, 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 unit is not implemented in typical GNAT implementations that lie on --- top of operating systems, because it is infeasible to implement in such --- environments. - --- If a target environment provides appropriate support for this package, --- then the Unimplemented_Unit pragma should be removed from this spec and --- an appropriate body provided. - -with System; -with System.Multiprocessors; - -package Ada.Execution_Time.Group_Budgets is - pragma Unimplemented_Unit; - - type Group_Budget - (CPU : System.Multiprocessors.CPU := System.Multiprocessors.CPU'First) - is tagged limited private; - - type Group_Budget_Handler is access - protected procedure (GB : in out Group_Budget); - - type Task_Array is - array (Positive range <>) of Ada.Task_Identification.Task_Id; - - Min_Handler_Ceiling : constant System.Any_Priority := - System.Any_Priority'First; - -- Initial value is an arbitrary choice ??? - - procedure Add_Task - (GB : in out Group_Budget; - T : Ada.Task_Identification.Task_Id); - - procedure Remove_Task - (GB : in out Group_Budget; - T : Ada.Task_Identification.Task_Id); - - function Is_Member - (GB : Group_Budget; - T : Ada.Task_Identification.Task_Id) return Boolean; - - function Is_A_Group_Member - (T : Ada.Task_Identification.Task_Id) return Boolean; - - function Members (GB : Group_Budget) return Task_Array; - - procedure Replenish - (GB : in out Group_Budget; - To : Ada.Real_Time.Time_Span); - - procedure Add - (GB : in out Group_Budget; - Interval : Ada.Real_Time.Time_Span); - - function Budget_Has_Expired (GB : Group_Budget) return Boolean; - - function Budget_Remaining - (GB : Group_Budget) return Ada.Real_Time.Time_Span; - - procedure Set_Handler - (GB : in out Group_Budget; - Handler : Group_Budget_Handler); - - function Current_Handler (GB : Group_Budget) return Group_Budget_Handler; - - procedure Cancel_Handler - (GB : in out Group_Budget; - Cancelled : out Boolean); - - Group_Budget_Error : exception; - -private - type Group_Budget - (CPU : System.Multiprocessors.CPU := System.Multiprocessors.CPU'First) - is tagged limited null record; -end Ada.Execution_Time.Group_Budgets; diff --git a/gcc/ada/a-exetim-darwin.adb b/gcc/ada/a-exetim-darwin.adb deleted file mode 100644 index 36a657cadac..00000000000 --- a/gcc/ada/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-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 -- --- . -- --- -- --- 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/a-exetim-default.ads b/gcc/ada/a-exetim-default.ads deleted file mode 100644 index 50b9bc50fab..00000000000 --- a/gcc/ada/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-2015, 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/a-exetim-mingw.adb b/gcc/ada/a-exetim-mingw.adb deleted file mode 100644 index 44f4ac3b37c..00000000000 --- a/gcc/ada/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-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 -- --- . -- --- -- --- 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/a-exetim-mingw.ads b/gcc/ada/a-exetim-mingw.ads deleted file mode 100644 index d4295c6f1ca..00000000000 --- a/gcc/ada/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/a-exetim-posix.adb b/gcc/ada/a-exetim-posix.adb deleted file mode 100644 index 10000bf23e1..00000000000 --- a/gcc/ada/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/a-exetim.ads b/gcc/ada/a-exetim.ads deleted file mode 100644 index d75b6befb6f..00000000000 --- a/gcc/ada/a-exetim.ads +++ /dev/null @@ -1,119 +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 -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This unit is not implemented in typical GNAT implementations that lie on --- top of operating systems, because it is infeasible to implement in such --- environments. - --- If a target environment provides appropriate support for this package --- then the Unimplemented_Unit pragma should be removed from this spec and --- an appropriate body provided. - -with Ada.Task_Identification; -with Ada.Real_Time; - -package Ada.Execution_Time with - SPARK_Mode -is - pragma Preelaborate; - - pragma Unimplemented_Unit; - - 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; - -end Ada.Execution_Time; diff --git a/gcc/ada/a-extiin.ads b/gcc/ada/a-extiin.ads deleted file mode 100644 index a4edb8f28e7..00000000000 --- a/gcc/ada/a-extiin.ads +++ /dev/null @@ -1,35 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E X E C U T I O N _ T I M E . I N T E R R U P T S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Interrupts; -with Ada.Real_Time; - -package Ada.Execution_Time.Interrupts with - SPARK_Mode -is - - pragma Unimplemented_Unit; - - function Clock (Interrupt : Ada.Interrupts.Interrupt_ID) return CPU_Time - with - Volatile_Function, - Global => Ada.Real_Time.Clock_Time, - Pre => Separate_Interrupt_Clocks_Supported; - - function Supported (Interrupt : Ada.Interrupts.Interrupt_ID) return Boolean - with - Global => null; - -end Ada.Execution_Time.Interrupts; diff --git a/gcc/ada/a-extiti.ads b/gcc/ada/a-extiti.ads deleted file mode 100644 index 411371dec0e..00000000000 --- a/gcc/ada/a-extiti.ads +++ /dev/null @@ -1,61 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E X E C U T I O N _ T I M E . T I M E R S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This unit is not implemented in typical GNAT implementations that lie on --- top of operating systems, because it is infeasible to implement in such --- environments. - --- If a target environment provides appropriate support for this package, --- then the Unimplemented_Unit pragma should be removed from this spec and --- an appropriate body provided. - -with System; - -package Ada.Execution_Time.Timers is - pragma Preelaborate; - - pragma Unimplemented_Unit; - - type Timer (T : not null access constant Ada.Task_Identification.Task_Id) is - tagged limited private; - - type Timer_Handler is access protected procedure (TM : in out Timer); - - Min_Handler_Ceiling : constant System.Any_Priority := System.Priority'Last; - - procedure Set_Handler - (TM : in out Timer; - In_Time : Ada.Real_Time.Time_Span; - Handler : Timer_Handler); - - procedure Set_Handler - (TM : in out Timer; - At_Time : CPU_Time; - Handler : Timer_Handler); - - function Current_Handler (TM : Timer) return Timer_Handler; - - procedure Cancel_Handler - (TM : in out Timer; - Cancelled : out Boolean); - - function Time_Remaining (TM : Timer) return Ada.Real_Time.Time_Span; - - Timer_Resource_Error : exception; - -private - type Timer (T : access Ada.Task_Identification.Task_Id) is - tagged limited null record; -end Ada.Execution_Time.Timers; diff --git a/gcc/ada/a-interr.adb b/gcc/ada/a-interr.adb deleted file mode 100644 index f01ac1ae49d..00000000000 --- a/gcc/ada/a-interr.adb +++ /dev/null @@ -1,139 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2015, 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. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -package body Ada.Interrupts is - - package SI renames System.Interrupts; - - function To_System is new Ada.Unchecked_Conversion - (Parameterless_Handler, SI.Parameterless_Handler); - - function To_Ada is new Ada.Unchecked_Conversion - (SI.Parameterless_Handler, Parameterless_Handler); - - -------------------- - -- Attach_Handler -- - -------------------- - - procedure Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID) - is - begin - SI.Attach_Handler - (To_System (New_Handler), SI.Interrupt_ID (Interrupt), False); - end Attach_Handler; - - --------------------- - -- Current_Handler -- - --------------------- - - function Current_Handler - (Interrupt : Interrupt_ID) return Parameterless_Handler - is - begin - return To_Ada (SI.Current_Handler (SI.Interrupt_ID (Interrupt))); - end Current_Handler; - - -------------------- - -- Detach_Handler -- - -------------------- - - procedure Detach_Handler (Interrupt : Interrupt_ID) is - begin - SI.Detach_Handler (SI.Interrupt_ID (Interrupt), False); - end Detach_Handler; - - ---------------------- - -- Exchange_Handler -- - ---------------------- - - procedure Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID) - is - H : SI.Parameterless_Handler; - - begin - SI.Exchange_Handler - (H, To_System (New_Handler), - SI.Interrupt_ID (Interrupt), False); - Old_Handler := To_Ada (H); - end Exchange_Handler; - - ------------- - -- Get_CPU -- - ------------- - - function Get_CPU - (Interrupt : Interrupt_ID) return System.Multiprocessors.CPU_Range - is - pragma Unreferenced (Interrupt); - - begin - -- The underlying operating system does not indicate the processor on - -- which the handler for Interrupt is executed. - - return System.Multiprocessors.Not_A_Specific_CPU; - end Get_CPU; - - ----------------- - -- Is_Attached -- - ----------------- - - function Is_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - return SI.Is_Handler_Attached (SI.Interrupt_ID (Interrupt)); - end Is_Attached; - - ----------------- - -- Is_Reserved -- - ----------------- - - function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is - begin - return SI.Is_Reserved (SI.Interrupt_ID (Interrupt)); - end Is_Reserved; - - --------------- - -- Reference -- - --------------- - - function Reference (Interrupt : Interrupt_ID) return System.Address is - begin - return SI.Reference (SI.Interrupt_ID (Interrupt)); - end Reference; - -end Ada.Interrupts; diff --git a/gcc/ada/a-interr.ads b/gcc/ada/a-interr.ads deleted file mode 100644 index 562f2781447..00000000000 --- a/gcc/ada/a-interr.ads +++ /dev/null @@ -1,100 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . I N T E R R U P T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, 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 System.Interrupts; -with System.Multiprocessors; -with Ada.Task_Identification; - -package Ada.Interrupts is - - type Interrupt_ID is new System.Interrupts.Ada_Interrupt_ID; - - type Parameterless_Handler is access protected procedure; - - function Is_Reserved (Interrupt : Interrupt_ID) return Boolean with - SPARK_Mode, - Volatile_Function, - Global => Ada.Task_Identification.Tasking_State; - - function Is_Attached (Interrupt : Interrupt_ID) return Boolean with - SPARK_Mode, - Volatile_Function, - Global => Ada.Task_Identification.Tasking_State; - - function Current_Handler - (Interrupt : Interrupt_ID) return Parameterless_Handler - with - SPARK_Mode => Off, - Global => null; - - procedure Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID) - with - SPARK_Mode => Off, - Global => null; - - procedure Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID) - with - SPARK_Mode => Off, - Global => null; - - procedure Detach_Handler (Interrupt : Interrupt_ID) with - SPARK_Mode, - Global => (In_Out => Ada.Task_Identification.Tasking_State); - - function Reference (Interrupt : Interrupt_ID) return System.Address with - SPARK_Mode => Off, - Global => null; - - function Get_CPU - (Interrupt : Interrupt_ID) return System.Multiprocessors.CPU_Range - with - SPARK_Mode, - Volatile_Function, - Global => Ada.Task_Identification.Tasking_State; - -private - pragma Inline (Is_Reserved); - pragma Inline (Is_Attached); - pragma Inline (Current_Handler); - pragma Inline (Attach_Handler); - pragma Inline (Detach_Handler); - pragma Inline (Exchange_Handler); - pragma Inline (Get_CPU); -end Ada.Interrupts; diff --git a/gcc/ada/a-intnam-aix.ads b/gcc/ada/a-intnam-aix.ads deleted file mode 100644 index 308f55f82b5..00000000000 --- a/gcc/ada/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-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 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/a-intnam-darwin.ads b/gcc/ada/a-intnam-darwin.ads deleted file mode 100644 index 4610876490f..00000000000 --- a/gcc/ada/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-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 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/a-intnam-dummy.ads b/gcc/ada/a-intnam-dummy.ads deleted file mode 100644 index 6e71411de2e..00000000000 --- a/gcc/ada/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-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. -- --- -- ------------------------------------------------------------------------------- - --- 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/a-intnam-freebsd.ads b/gcc/ada/a-intnam-freebsd.ads deleted file mode 100644 index 7362f9f156a..00000000000 --- a/gcc/ada/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-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 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/a-intnam-hpux.ads b/gcc/ada/a-intnam-hpux.ads deleted file mode 100644 index db061a96b5c..00000000000 --- a/gcc/ada/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-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 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/a-intnam-linux.ads b/gcc/ada/a-intnam-linux.ads deleted file mode 100644 index 9bbff6b8323..00000000000 --- a/gcc/ada/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-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 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/a-intnam-mingw.ads b/gcc/ada/a-intnam-mingw.ads deleted file mode 100644 index 3a2bcdc179f..00000000000 --- a/gcc/ada/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-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 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/a-intnam-solaris.ads b/gcc/ada/a-intnam-solaris.ads deleted file mode 100644 index 3ed974e7d4c..00000000000 --- a/gcc/ada/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-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 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/a-intnam-vxworks.ads b/gcc/ada/a-intnam-vxworks.ads deleted file mode 100644 index 0c043f45a07..00000000000 --- a/gcc/ada/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-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 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/a-intnam.ads b/gcc/ada/a-intnam.ads deleted file mode 100644 index 48a50dbf2db..00000000000 --- a/gcc/ada/a-intnam.ads +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME 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) 1995-2011, 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 -- --- . -- --- -- ------------------------------------------------------------------------------- - --- 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/a-reatim.adb b/gcc/ada/a-reatim.adb deleted file mode 100644 index 57fcd00bf31..00000000000 --- a/gcc/ada/a-reatim.adb +++ /dev/null @@ -1,390 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . R E A L _ T I M E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2015, 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. -- --- -- ------------------------------------------------------------------------------- - -with System.Tasking; -with Unchecked_Conversion; - -package body Ada.Real_Time with - SPARK_Mode => Off -is - - --------- - -- "*" -- - --------- - - -- Note that Constraint_Error may be propagated - - function "*" (Left : Time_Span; Right : Integer) return Time_Span is - pragma Unsuppress (Overflow_Check); - begin - return Time_Span (Duration (Left) * Right); - end "*"; - - function "*" (Left : Integer; Right : Time_Span) return Time_Span is - pragma Unsuppress (Overflow_Check); - begin - return Time_Span (Left * Duration (Right)); - end "*"; - - --------- - -- "+" -- - --------- - - -- Note that Constraint_Error may be propagated - - function "+" (Left : Time; Right : Time_Span) return Time is - pragma Unsuppress (Overflow_Check); - begin - return Time (Duration (Left) + Duration (Right)); - end "+"; - - function "+" (Left : Time_Span; Right : Time) return Time is - pragma Unsuppress (Overflow_Check); - begin - return Time (Duration (Left) + Duration (Right)); - end "+"; - - function "+" (Left, Right : Time_Span) return Time_Span is - pragma Unsuppress (Overflow_Check); - begin - return Time_Span (Duration (Left) + Duration (Right)); - end "+"; - - --------- - -- "-" -- - --------- - - -- Note that Constraint_Error may be propagated - - function "-" (Left : Time; Right : Time_Span) return Time is - pragma Unsuppress (Overflow_Check); - begin - return Time (Duration (Left) - Duration (Right)); - end "-"; - - function "-" (Left, Right : Time) return Time_Span is - pragma Unsuppress (Overflow_Check); - begin - return Time_Span (Duration (Left) - Duration (Right)); - end "-"; - - function "-" (Left, Right : Time_Span) return Time_Span is - pragma Unsuppress (Overflow_Check); - begin - return Time_Span (Duration (Left) - Duration (Right)); - end "-"; - - function "-" (Right : Time_Span) return Time_Span is - pragma Unsuppress (Overflow_Check); - begin - return Time_Span_Zero - Right; - end "-"; - - --------- - -- "/" -- - --------- - - -- Note that Constraint_Error may be propagated - - function "/" (Left, Right : Time_Span) return Integer is - pragma Unsuppress (Overflow_Check); - pragma Unsuppress (Division_Check); - - -- RM D.8 (27) specifies the effects of operators on Time_Span, and - -- rounding of the division operator in particular, to be the same as - -- effects on integer types. To get the correct rounding we first - -- convert Time_Span to its root type Duration, which is represented as - -- a 64-bit signed integer, and then use integer division. - - type Duration_Rep is range -(2 ** 63) .. +((2 ** 63 - 1)); - - function To_Integer is - new Unchecked_Conversion (Duration, Duration_Rep); - begin - return Integer - (To_Integer (Duration (Left)) / To_Integer (Duration (Right))); - end "/"; - - function "/" (Left : Time_Span; Right : Integer) return Time_Span is - pragma Unsuppress (Overflow_Check); - pragma Unsuppress (Division_Check); - begin - -- Even though checks are unsuppressed, we need an explicit check for - -- the case of largest negative integer divided by minus one, since - -- some library routines we use fail to catch this case. This will be - -- fixed at the compiler level in the future, at which point this test - -- can be removed. - - if Left = Time_Span_First and then Right = -1 then - raise Constraint_Error with "overflow"; - end if; - - return Time_Span (Duration (Left) / Right); - end "/"; - - ----------- - -- Clock -- - ----------- - - function Clock return Time is - begin - return Time (System.Task_Primitives.Operations.Monotonic_Clock); - end Clock; - - ------------------ - -- Microseconds -- - ------------------ - - function Microseconds (US : Integer) return Time_Span is - begin - return Time_Span_Unit * US * 1_000; - end Microseconds; - - ------------------ - -- Milliseconds -- - ------------------ - - function Milliseconds (MS : Integer) return Time_Span is - begin - return Time_Span_Unit * MS * 1_000_000; - end Milliseconds; - - ------------- - -- Minutes -- - ------------- - - function Minutes (M : Integer) return Time_Span is - begin - return Milliseconds (M) * Integer'(60_000); - end Minutes; - - ----------------- - -- Nanoseconds -- - ----------------- - - function Nanoseconds (NS : Integer) return Time_Span is - begin - return Time_Span_Unit * NS; - end Nanoseconds; - - ------------- - -- Seconds -- - ------------- - - function Seconds (S : Integer) return Time_Span is - begin - return Milliseconds (S) * Integer'(1000); - end Seconds; - - ----------- - -- Split -- - ----------- - - procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is - T_Val : Time; - - begin - -- Special-case for Time_First, whose absolute value is anomalous, - -- courtesy of two's complement. - - T_Val := (if T = Time_First then abs (Time_Last) else abs (T)); - - -- Extract the integer part of T, truncating towards zero - - SC := - (if T_Val < 0.5 then 0 else Seconds_Count (Time_Span'(T_Val - 0.5))); - - if T < 0.0 then - SC := -SC; - end if; - - -- If original time is negative, need to truncate towards negative - -- infinity, to make TS non-negative, as per ARM. - - if Time (SC) > T then - SC := SC - 1; - end if; - - TS := Time_Span (Duration (T) - Duration (SC)); - end Split; - - ------------- - -- Time_Of -- - ------------- - - function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - -- We do all our own checks for this function - - -- This is not such a simple case, since TS is already 64 bits, and - -- so we can't just promote everything to a wider type to ensure proper - -- testing for overflow. The situation is that Seconds_Count is a MUCH - -- wider type than Time_Span and Time (both of which have the underlying - -- type Duration). - - -- <------------------- Seconds_Count --------------------> - -- <-- Duration --> - - -- Now it is possible for an SC value outside the Duration range to - -- be "brought back into range" by an appropriate TS value, but there - -- are also clearly SC values that are completely out of range. Note - -- that the above diagram is wildly out of scale, the difference in - -- ranges is much greater than shown. - - -- We can't just go generating out of range Duration values to test for - -- overflow, since Duration is a full range type, so we follow the steps - -- shown below. - - SC_Lo : constant Seconds_Count := - Seconds_Count (Duration (Time_Span_First) + Duration'(0.5)); - SC_Hi : constant Seconds_Count := - Seconds_Count (Duration (Time_Span_Last) - Duration'(0.5)); - -- These are the maximum values of the seconds (integer) part of the - -- Duration range. Used to compute and check the seconds in the result. - - TS_SC : Seconds_Count; - -- Seconds part of input value - - TS_Fraction : Duration; - -- Fractional part of input value, may be negative - - Result_SC : Seconds_Count; - -- Seconds value for result - - Fudge : constant Seconds_Count := 10; - -- Fudge value used to do end point checks far from end point - - FudgeD : constant Duration := Duration (Fudge); - -- Fudge value as Duration - - Fudged_Result : Duration; - -- Result fudged up or down by FudgeD - - procedure Out_Of_Range; - pragma No_Return (Out_Of_Range); - -- Raise exception for result out of range - - ------------------ - -- Out_Of_Range -- - ------------------ - - procedure Out_Of_Range is - begin - raise Constraint_Error with - "result for Ada.Real_Time.Time_Of is out of range"; - end Out_Of_Range; - - -- Start of processing for Time_Of - - begin - -- If SC is so far out of range that there is no possibility of the - -- addition of TS getting it back in range, raise an exception right - -- away. That way we don't have to worry about SC values overflowing. - - if SC < 3 * SC_Lo or else SC > 3 * SC_Hi then - Out_Of_Range; - end if; - - -- Decompose input TS value - - TS_SC := Seconds_Count (Duration (TS)); - TS_Fraction := Duration (TS) - Duration (TS_SC); - - -- Compute result seconds. If clearly out of range, raise error now - - Result_SC := SC + TS_SC; - - if Result_SC < (SC_Lo - 1) or else Result_SC > (SC_Hi + 1) then - Out_Of_Range; - end if; - - -- Now the result is simply Result_SC + TS_Fraction, but we can't just - -- go computing that since it might be out of range. So what we do is - -- to compute a value fudged down or up by 10.0 (arbitrary value, but - -- that will do fine), and check that fudged value, and if in range - -- unfudge it and return the result. - - -- Fudge positive result down, and check high bound - - if Result_SC > 0 then - Fudged_Result := Duration (Result_SC - Fudge) + TS_Fraction; - - if Fudged_Result <= Duration'Last - FudgeD then - return Time (Fudged_Result + FudgeD); - else - Out_Of_Range; - end if; - - -- Same for negative values of seconds, fudge up and check low bound - - else - Fudged_Result := Duration (Result_SC + Fudge) + TS_Fraction; - - if Fudged_Result >= Duration'First + FudgeD then - return Time (Fudged_Result - FudgeD); - else - Out_Of_Range; - end if; - end if; - end Time_Of; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (TS : Time_Span) return Duration is - begin - return Duration (TS); - end To_Duration; - - ------------------ - -- To_Time_Span -- - ------------------ - - function To_Time_Span (D : Duration) return Time_Span is - begin - -- Note regarding AI-00432 requiring range checking on this conversion. - -- In almost all versions of GNAT (and all to which this version of the - -- Ada.Real_Time package apply), the range of Time_Span and Duration are - -- the same, so there is no issue of overflow. - - return Time_Span (D); - end To_Time_Span; - -begin - -- Ensure that the tasking run time is initialized when using clock and/or - -- delay operations. The initialization routine has the required machinery - -- to prevent multiple calls to Initialize. - - System.Tasking.Initialize; -end Ada.Real_Time; diff --git a/gcc/ada/a-reatim.ads b/gcc/ada/a-reatim.ads deleted file mode 100644 index cb84859df63..00000000000 --- a/gcc/ada/a-reatim.ads +++ /dev/null @@ -1,187 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . R E A L _ T I M E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, 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 System.Task_Primitives.Operations; -pragma Elaborate_All (System.Task_Primitives.Operations); - -package Ada.Real_Time with - SPARK_Mode, - Abstract_State => (Clock_Time with Synchronous, - External => (Async_Readers, - Async_Writers)), - Initializes => Clock_Time -is - - pragma Compile_Time_Error - (Duration'Size /= 64, - "this version of Ada.Real_Time requires 64-bit Duration"); - - type Time is private; - Time_First : constant Time; - Time_Last : constant Time; - Time_Unit : constant := 10#1.0#E-9; - - type Time_Span is private; - Time_Span_First : constant Time_Span; - Time_Span_Last : constant Time_Span; - Time_Span_Zero : constant Time_Span; - Time_Span_Unit : constant Time_Span; - - Tick : constant Time_Span; - function Clock return Time with - Volatile_Function, - Global => Clock_Time; - - function "+" (Left : Time; Right : Time_Span) return Time with - Global => null; - function "+" (Left : Time_Span; Right : Time) return Time with - Global => null; - function "-" (Left : Time; Right : Time_Span) return Time with - Global => null; - function "-" (Left : Time; Right : Time) return Time_Span with - Global => null; - - function "<" (Left, Right : Time) return Boolean with - Global => null; - function "<=" (Left, Right : Time) return Boolean with - Global => null; - function ">" (Left, Right : Time) return Boolean with - Global => null; - function ">=" (Left, Right : Time) return Boolean with - Global => null; - - function "+" (Left, Right : Time_Span) return Time_Span with - Global => null; - function "-" (Left, Right : Time_Span) return Time_Span with - Global => null; - function "-" (Right : Time_Span) return Time_Span with - Global => null; - function "*" (Left : Time_Span; Right : Integer) return Time_Span with - Global => null; - function "*" (Left : Integer; Right : Time_Span) return Time_Span with - Global => null; - function "/" (Left, Right : Time_Span) return Integer with - Global => null; - function "/" (Left : Time_Span; Right : Integer) return Time_Span with - Global => null; - - function "abs" (Right : Time_Span) return Time_Span with - Global => null; - - function "<" (Left, Right : Time_Span) return Boolean with - Global => null; - function "<=" (Left, Right : Time_Span) return Boolean with - Global => null; - function ">" (Left, Right : Time_Span) return Boolean with - Global => null; - function ">=" (Left, Right : Time_Span) return Boolean with - Global => null; - - function To_Duration (TS : Time_Span) return Duration with - Global => null; - function To_Time_Span (D : Duration) return Time_Span with - Global => null; - - function Nanoseconds (NS : Integer) return Time_Span with - Global => null; - function Microseconds (US : Integer) return Time_Span with - Global => null; - function Milliseconds (MS : Integer) return Time_Span with - Global => null; - - function Seconds (S : Integer) return Time_Span with - Global => null; - pragma Ada_05 (Seconds); - - function Minutes (M : Integer) return Time_Span with - Global => null; - pragma Ada_05 (Minutes); - - type Seconds_Count is new Long_Long_Integer; - -- Seconds_Count needs 64 bits, since the type Time has the full range of - -- Duration. The delta of Duration is 10 ** (-9), so the maximum number of - -- seconds is 2**63/10**9 = 8*10**9 which does not quite fit in 32 bits. - -- However, rather than make this explicitly 64-bits we derive from - -- Long_Long_Integer. In normal usage this will have the same effect. But - -- in the case of CodePeer with a target configuration file with a maximum - -- integer size of 32, it allows analysis of this unit. - - procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) - with - Global => null; - function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time - with - Global => null; - -private - pragma SPARK_Mode (Off); - - -- Time and Time_Span are represented in 64-bit Duration value in - -- nanoseconds. For example, 1 second and 1 nanosecond is represented - -- as the stored integer 1_000_000_001. This is for the 64-bit Duration - -- case, not clear if this also is used for 32-bit Duration values. - - type Time is new Duration; - - Time_First : constant Time := Time'First; - - Time_Last : constant Time := Time'Last; - - type Time_Span is new Duration; - - Time_Span_First : constant Time_Span := Time_Span'First; - - Time_Span_Last : constant Time_Span := Time_Span'Last; - - Time_Span_Zero : constant Time_Span := 0.0; - - Time_Span_Unit : constant Time_Span := 10#1.0#E-9; - - Tick : constant Time_Span := - Time_Span (System.Task_Primitives.Operations.RT_Resolution); - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "abs"); - - pragma Inline (Microseconds); - pragma Inline (Milliseconds); - pragma Inline (Nanoseconds); - pragma Inline (Seconds); - pragma Inline (Minutes); - -end Ada.Real_Time; diff --git a/gcc/ada/a-retide.adb b/gcc/ada/a-retide.adb deleted file mode 100644 index ecc61f6913a..00000000000 --- a/gcc/ada/a-retide.adb +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . R E A L _ T I M E . D E L A Y S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License 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. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; - -with System.Tasking; -with System.Task_Primitives.Operations; - -package body Ada.Real_Time.Delays is - - package STPO renames System.Task_Primitives.Operations; - - ---------------- - -- Local Data -- - ---------------- - - Absolute_RT : constant := 2; - - ----------------- - -- Delay_Until -- - ----------------- - - procedure Delay_Until (T : Time) is - Self_Id : constant System.Tasking.Task_Id := STPO.Self; - - begin - -- If pragma Detect_Blocking is active, Program_Error must be - -- raised if this potentially blocking operation is called from a - -- protected action. - - if System.Tasking.Detect_Blocking - and then Self_Id.Common.Protected_Action_Nesting > 0 - then - Ada.Exceptions.Raise_Exception - (Program_Error'Identity, "potentially blocking operation"); - else - STPO.Timed_Delay (Self_Id, To_Duration (T), Absolute_RT); - end if; - end Delay_Until; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (T : Time) return Duration is - begin - return To_Duration (Time_Span (T)); - end To_Duration; - -end Ada.Real_Time.Delays; diff --git a/gcc/ada/a-retide.ads b/gcc/ada/a-retide.ads deleted file mode 100644 index 25880c67a37..00000000000 --- a/gcc/ada/a-retide.ads +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . R E A L _ T I M E . D E L A Y S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - --- Implements Real_Time.Time absolute delays - --- Note: the compiler generates direct calls to this interface, in the --- processing of time types. - -package Ada.Real_Time.Delays is - - function To_Duration (T : Real_Time.Time) return Duration; - -- Convert Time to Duration - - procedure Delay_Until (T : Time); - -- Delay until Clock has reached (at least) time T, - -- or the task is aborted to at least the current ATC nesting level. - -- The body of this procedure must perform all the processing - -- required for an abort point. - -end Ada.Real_Time.Delays; diff --git a/gcc/ada/a-rttiev.adb b/gcc/ada/a-rttiev.adb deleted file mode 100644 index ecb0aa7c9d5..00000000000 --- a/gcc/ada/a-rttiev.adb +++ /dev/null @@ -1,367 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . R E A L _ T I M E . T I M I N G _ E V E N T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2014, 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. -- --- -- ------------------------------------------------------------------------------- - -with System.Task_Primitives.Operations; -with System.Tasking.Utilities; -with System.Soft_Links; -with System.Interrupt_Management.Operations; - -with Ada.Containers.Doubly_Linked_Lists; -pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists); - ---------------------------------- --- Ada.Real_Time.Timing_Events -- ---------------------------------- - -package body Ada.Real_Time.Timing_Events is - - use System.Task_Primitives.Operations; - - package SSL renames System.Soft_Links; - - type Any_Timing_Event is access all Timing_Event'Class; - -- We must also handle user-defined types derived from Timing_Event - - ------------ - -- Events -- - ------------ - - package Events is new Ada.Containers.Doubly_Linked_Lists (Any_Timing_Event); - -- Provides the type for the container holding pointers to events - - All_Events : Events.List; - -- The queue of pending events, ordered by increasing timeout value, that - -- have been "set" by the user via Set_Handler. - - Event_Queue_Lock : aliased System.Task_Primitives.RTS_Lock; - -- Used for mutually exclusive access to All_Events - - -- We need to Initialize_Lock before Timer is activated. The purpose of the - -- Dummy package is to get around Ada's syntax rules. - - package Dummy is end Dummy; - package body Dummy is - begin - Initialize_Lock (Event_Queue_Lock'Access, Level => PO_Level); - end Dummy; - - procedure Process_Queued_Events; - -- Examine the queue of pending events for any that have timed out. For - -- those that have timed out, remove them from the queue and invoke their - -- handler (unless the user has cancelled the event by setting the handler - -- pointer to null). Mutually exclusive access is held via Event_Queue_Lock - -- during part of the processing. - - procedure Insert_Into_Queue (This : Any_Timing_Event); - -- Insert the specified event pointer into the queue of pending events - -- with mutually exclusive access via Event_Queue_Lock. - - procedure Remove_From_Queue (This : Any_Timing_Event); - -- Remove the specified event pointer from the queue of pending events with - -- mutually exclusive access via Event_Queue_Lock. This procedure is used - -- by the client-side routines (Set_Handler, etc.). - - ----------- - -- Timer -- - ----------- - - task Timer is - pragma Priority (System.Priority'Last); - end Timer; - - task body Timer is - Period : constant Time_Span := Milliseconds (100); - -- This is a "chiming" clock timer that fires periodically. The period - -- selected is arbitrary and could be changed to suit the application - -- requirements. Obviously a shorter period would give better resolution - -- at the cost of more overhead. - - Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; - pragma Unreferenced (Ignore); - - begin - -- Since this package may be elaborated before System.Interrupt, - -- we need to call Setup_Interrupt_Mask explicitly to ensure that - -- this task has the proper signal mask. - - System.Interrupt_Management.Operations.Setup_Interrupt_Mask; - - loop - Process_Queued_Events; - delay until Clock + Period; - end loop; - end Timer; - - --------------------------- - -- Process_Queued_Events -- - --------------------------- - - procedure Process_Queued_Events is - Next_Event : Any_Timing_Event; - - begin - loop - SSL.Abort_Defer.all; - - Write_Lock (Event_Queue_Lock'Access); - - if All_Events.Is_Empty then - Unlock (Event_Queue_Lock'Access); - SSL.Abort_Undefer.all; - return; - else - Next_Event := All_Events.First_Element; - end if; - - if Next_Event.Timeout > Clock then - - -- We found one that has not yet timed out. The queue is in - -- ascending order by Timeout so there is no need to continue - -- processing (and indeed we must not continue since we always - -- delete the first element). - - Unlock (Event_Queue_Lock'Access); - SSL.Abort_Undefer.all; - return; - end if; - - -- We have an event that has timed out so we will process it. It must - -- be the first in the queue so no search is needed. - - All_Events.Delete_First; - - -- A fundamental issue is that the invocation of the event's handler - -- might call Set_Handler on itself to re-insert itself back into the - -- queue of future events. Thus we cannot hold the lock on the queue - -- while invoking the event's handler. - - Unlock (Event_Queue_Lock'Access); - - SSL.Abort_Undefer.all; - - -- There is no race condition with the user changing the handler - -- pointer while we are processing because we are executing at the - -- highest possible application task priority and are not doing - -- anything to block prior to invoking their handler. - - declare - Handler : constant Timing_Event_Handler := Next_Event.Handler; - - begin - -- The first act is to clear the event, per D.15(13/2). Besides, - -- we cannot clear the handler pointer *after* invoking the - -- handler because the handler may have re-inserted the event via - -- Set_Event. Thus we take a copy and then clear the component. - - Next_Event.Handler := null; - - if Handler /= null then - Handler.all (Timing_Event (Next_Event.all)); - end if; - - -- Ignore exceptions propagated by Handler.all, as required by - -- RM D.15(21/2). - - exception - when others => - null; - end; - end loop; - end Process_Queued_Events; - - ----------------------- - -- Insert_Into_Queue -- - ----------------------- - - procedure Insert_Into_Queue (This : Any_Timing_Event) is - - function Sooner (Left, Right : Any_Timing_Event) return Boolean; - -- Compares events in terms of timeout values - - package By_Timeout is new Events.Generic_Sorting (Sooner); - -- Used to keep the events in ascending order by timeout value - - ------------ - -- Sooner -- - ------------ - - function Sooner (Left, Right : Any_Timing_Event) return Boolean is - begin - return Left.Timeout < Right.Timeout; - end Sooner; - - -- Start of processing for Insert_Into_Queue - - begin - SSL.Abort_Defer.all; - - Write_Lock (Event_Queue_Lock'Access); - - All_Events.Append (This); - - -- A critical property of the implementation of this package is that - -- all occurrences are in ascending order by Timeout. Thus the first - -- event in the queue always has the "next" value for the Timer task - -- to use in its delay statement. - - By_Timeout.Sort (All_Events); - - Unlock (Event_Queue_Lock'Access); - - SSL.Abort_Undefer.all; - end Insert_Into_Queue; - - ----------------------- - -- Remove_From_Queue -- - ----------------------- - - procedure Remove_From_Queue (This : Any_Timing_Event) is - use Events; - Location : Cursor; - - begin - SSL.Abort_Defer.all; - - Write_Lock (Event_Queue_Lock'Access); - - Location := All_Events.Find (This); - - if Location /= No_Element then - All_Events.Delete (Location); - end if; - - Unlock (Event_Queue_Lock'Access); - - SSL.Abort_Undefer.all; - end Remove_From_Queue; - - ----------------- - -- Set_Handler -- - ----------------- - - procedure Set_Handler - (Event : in out Timing_Event; - At_Time : Time; - Handler : Timing_Event_Handler) - is - begin - Remove_From_Queue (Event'Unchecked_Access); - Event.Handler := null; - - -- RM D.15(15/2) required that at this point, we check whether the time - -- has already passed, and if so, call Handler.all directly from here - -- instead of doing the enqueuing below. However, this caused a nasty - -- race condition and potential deadlock. If the current task has - -- already locked the protected object of Handler.all, and the time has - -- passed, deadlock would occur. It has been fixed by AI05-0094-1, which - -- says that the handler should be executed as soon as possible, meaning - -- that the timing event will be executed after the protected action - -- finishes (Handler.all should not be called directly from here). - -- The same comment applies to the other Set_Handler below. - - if Handler /= null then - Event.Timeout := At_Time; - Event.Handler := Handler; - Insert_Into_Queue (Event'Unchecked_Access); - end if; - end Set_Handler; - - ----------------- - -- Set_Handler -- - ----------------- - - procedure Set_Handler - (Event : in out Timing_Event; - In_Time : Time_Span; - Handler : Timing_Event_Handler) - is - begin - Remove_From_Queue (Event'Unchecked_Access); - Event.Handler := null; - - -- See comment in the other Set_Handler above - - if Handler /= null then - Event.Timeout := Clock + In_Time; - Event.Handler := Handler; - Insert_Into_Queue (Event'Unchecked_Access); - end if; - end Set_Handler; - - --------------------- - -- Current_Handler -- - --------------------- - - function Current_Handler - (Event : Timing_Event) return Timing_Event_Handler - is - begin - return Event.Handler; - end Current_Handler; - - -------------------- - -- Cancel_Handler -- - -------------------- - - procedure Cancel_Handler - (Event : in out Timing_Event; - Cancelled : out Boolean) - is - begin - Remove_From_Queue (Event'Unchecked_Access); - Cancelled := Event.Handler /= null; - Event.Handler := null; - end Cancel_Handler; - - ------------------- - -- Time_Of_Event -- - ------------------- - - function Time_Of_Event (Event : Timing_Event) return Time is - begin - -- RM D.15(18/2): Time_First must be returned in the event is not set - - return (if Event.Handler = null then Time_First else Event.Timeout); - end Time_Of_Event; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (This : in out Timing_Event) is - begin - -- D.15 (19/2) says finalization clears the event - - This.Handler := null; - Remove_From_Queue (This'Unchecked_Access); - end Finalize; - -end Ada.Real_Time.Timing_Events; diff --git a/gcc/ada/a-rttiev.ads b/gcc/ada/a-rttiev.ads deleted file mode 100644 index 25f58ca5162..00000000000 --- a/gcc/ada/a-rttiev.ads +++ /dev/null @@ -1,81 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . R E A L _ T I M E . T I M I N G _ E V E N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2005-2009, 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.Finalization; - -package Ada.Real_Time.Timing_Events is - - type Timing_Event is tagged limited private; - - type Timing_Event_Handler - is access protected procedure (Event : in out Timing_Event); - - procedure Set_Handler - (Event : in out Timing_Event; - At_Time : Time; - Handler : Timing_Event_Handler); - - procedure Set_Handler - (Event : in out Timing_Event; - In_Time : Time_Span; - Handler : Timing_Event_Handler); - - function Current_Handler - (Event : Timing_Event) return Timing_Event_Handler; - - procedure Cancel_Handler - (Event : in out Timing_Event; - Cancelled : out Boolean); - - function Time_Of_Event (Event : Timing_Event) return Time; - -private - - type Timing_Event is new Ada.Finalization.Limited_Controlled with record - Timeout : Time := Time_First; - -- The time at which the user's handler should be invoked when the - -- event is "set" (i.e., when Handler is not null). - - Handler : Timing_Event_Handler; - -- An access value designating the protected procedure to be invoked - -- at the Timeout time in the future. When this value is null the event - -- is said to be "cleared" and no timeout is processed. - end record; - - overriding procedure Finalize (This : in out Timing_Event); - -- Finalization procedure is required to satisfy (RM D.15 (19/2)), which - -- says that the object must be cleared on finalization. - -end Ada.Real_Time.Timing_Events; diff --git a/gcc/ada/a-stcoed.ads b/gcc/ada/a-stcoed.ads deleted file mode 100644 index 0d39cc3d762..00000000000 --- a/gcc/ada/a-stcoed.ads +++ /dev/null @@ -1,31 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L . E D F -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This unit is not implemented in typical GNAT implementations that lie on --- top of operating systems, because it is infeasible to implement in such --- environments. - --- If a target environment provides appropriate support for this package, --- then the Unimplemented_Unit pragma should be removed from this spec and --- an appropriate body provided. - -package Ada.Synchronous_Task_Control.EDF is - - pragma Unimplemented_Unit; - - procedure Suspend_Until_True_And_Set_Deadline - (S : in out Suspension_Object; - TS : Ada.Real_Time.Time_Span); -end Ada.Synchronous_Task_Control.EDF; diff --git a/gcc/ada/a-synbar-posix.adb b/gcc/ada/a-synbar-posix.adb deleted file mode 100644 index 62cf23250a1..00000000000 --- a/gcc/ada/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-2014, 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/a-synbar-posix.ads b/gcc/ada/a-synbar-posix.ads deleted file mode 100644 index 4c01852b0e6..00000000000 --- a/gcc/ada/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-2011, 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/a-synbar.adb b/gcc/ada/a-synbar.adb deleted file mode 100644 index 33bb3e478c7..00000000000 --- a/gcc/ada/a-synbar.adb +++ /dev/null @@ -1,78 +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-2011, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Synchronous_Barriers is - - protected body Synchronous_Barrier is - - -- The condition "Wait'Count = Release_Threshold" opens the barrier when - -- the required number of tasks is reached. The condition "Keep_Open" - -- leaves the barrier open while there are queued tasks. While there are - -- tasks in the queue no new task will be queued (no new protected - -- action can be started on a protected object while another protected - -- action on the same protected object is underway, RM 9.5.1 (4)), - -- guaranteeing that the barrier will remain open only for those tasks - -- already inside the queue when the barrier was open. - - entry Wait (Notified : out Boolean) - when Keep_Open or else Wait'Count = Release_Threshold - is - begin - -- If we are executing the entry it means that the required number of - -- tasks have been queued in the entry. Keep_Open barrier will remain - -- true until all queued tasks are out. - - Keep_Open := Wait'Count > 0; - - -- The last released task will close the barrier and get the Notified - -- token. - - Notified := Wait'Count = 0; - end Wait; - end Synchronous_Barrier; - - ---------------------- - -- Wait_For_Release -- - ---------------------- - - procedure Wait_For_Release - (The_Barrier : in out Synchronous_Barrier; - Notified : out Boolean) - is - begin - The_Barrier.Wait (Notified); - end Wait_For_Release; - -end Ada.Synchronous_Barriers; diff --git a/gcc/ada/a-synbar.ads b/gcc/ada/a-synbar.ads deleted file mode 100644 index 6c084c23f43..00000000000 --- a/gcc/ada/a-synbar.ads +++ /dev/null @@ -1,54 +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-2011, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package 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 - protected type Synchronous_Barrier (Release_Threshold : Barrier_Limit) is - entry Wait (Notified : out Boolean); - private - Keep_Open : Boolean := False; - end Synchronous_Barrier; -end Ada.Synchronous_Barriers; diff --git a/gcc/ada/a-sytaco.adb b/gcc/ada/a-sytaco.adb deleted file mode 100644 index ab7c9ad1629..00000000000 --- a/gcc/ada/a-sytaco.adb +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, 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. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; - -with System.Tasking; -with System.Task_Primitives.Operations; - -package body Ada.Synchronous_Task_Control with - SPARK_Mode => Off -is - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - begin - System.Task_Primitives.Operations.Initialize (S.SO); - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - begin - System.Task_Primitives.Operations.Finalize (S.SO); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - return System.Task_Primitives.Operations.Current_State (S.SO); - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - begin - System.Task_Primitives.Operations.Set_False (S.SO); - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - begin - System.Task_Primitives.Operations.Set_True (S.SO); - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - begin - -- This is a potentially blocking (see ARM D.10, par. 10), so that - -- if pragma Detect_Blocking is active then Program_Error must be - -- raised if this operation is called from a protected action. - - if System.Tasking.Detect_Blocking - and then System.Tasking.Self.Common.Protected_Action_Nesting > 0 - then - Ada.Exceptions.Raise_Exception - (Program_Error'Identity, "potentially blocking operation"); - end if; - - System.Task_Primitives.Operations.Suspend_Until_True (S.SO); - end Suspend_Until_True; - -end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/a-sytaco.ads b/gcc/ada/a-sytaco.ads deleted file mode 100644 index 733fc764e23..00000000000 --- a/gcc/ada/a-sytaco.ads +++ /dev/null @@ -1,94 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, 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 System.Task_Primitives; - -with Ada.Finalization; -with Ada.Task_Identification; - -package Ada.Synchronous_Task_Control with - SPARK_Mode -is - pragma Preelaborate; - -- In accordance with Ada 2005 AI-362 - - type Suspension_Object is limited private with - Default_Initial_Condition; - - procedure Set_True (S : in out Suspension_Object) with - Global => null, - Depends => (S => null, - null => S); - - procedure Set_False (S : in out Suspension_Object) with - Global => null, - Depends => (S => null, - null => S); - - function Current_State (S : Suspension_Object) return Boolean with - Volatile_Function, - Global => Ada.Task_Identification.Tasking_State; - - procedure Suspend_Until_True (S : in out Suspension_Object) with - Global => null, - Depends => (S => null, - null => S); - -private - pragma SPARK_Mode (Off); - - procedure Initialize (S : in out Suspension_Object); - -- Initialization for Suspension_Object - - procedure Finalize (S : in out Suspension_Object); - -- Finalization for Suspension_Object - - type Suspension_Object is - new Ada.Finalization.Limited_Controlled with - record - SO : System.Task_Primitives.Suspension_Object; - -- Use low-level suspension objects so that the synchronization - -- functionality provided by this object can be achieved using - -- efficient operating system primitives. - end record; - - pragma Inline (Set_True); - pragma Inline (Set_False); - pragma Inline (Current_State); - pragma Inline (Suspend_Until_True); - pragma Inline (Initialize); - pragma Inline (Finalize); - -end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb deleted file mode 100644 index 97cc06e9030..00000000000 --- a/gcc/ada/a-tasatt.adb +++ /dev/null @@ -1,380 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T A S K _ A T T R I B U T E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2014-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. -- --- -- ------------------------------------------------------------------------------- - -with System.Tasking; -with System.Tasking.Initialization; -with System.Tasking.Task_Attributes; -pragma Elaborate_All (System.Tasking.Task_Attributes); - -with System.Task_Primitives.Operations; - -with Ada.Finalization; use Ada.Finalization; -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -package body Ada.Task_Attributes is - - use System, - System.Tasking.Initialization, - System.Tasking, - System.Tasking.Task_Attributes; - - package STPO renames System.Task_Primitives.Operations; - - type Attribute_Cleanup is new Limited_Controlled with null record; - procedure Finalize (Cleanup : in out Attribute_Cleanup); - -- Finalize all tasks' attributes for this package - - Cleanup : Attribute_Cleanup; - pragma Unreferenced (Cleanup); - -- Will call Finalize when this instantiation gets out of scope - - --------------------------- - -- Unchecked Conversions -- - --------------------------- - - type Real_Attribute is record - Free : Deallocator; - Value : Attribute; - end record; - type Real_Attribute_Access is access all Real_Attribute; - pragma No_Strict_Aliasing (Real_Attribute_Access); - -- Each value in the task control block's Attributes array is either - -- mapped to the attribute value directly if Fast_Path is True, or - -- is in effect a Real_Attribute_Access. - -- - -- Note: the Deallocator field must be first, for compatibility with - -- System.Tasking.Task_Attributes.Attribute_Record and to allow unchecked - -- conversions between Attribute_Access and Real_Attribute_Access. - - function New_Attribute (Val : Attribute) return Atomic_Address; - -- Create a new Real_Attribute using Val, and return its address. The - -- returned value can be converted via To_Real_Attribute. - - procedure Deallocate (Ptr : Atomic_Address); - -- Free memory associated with Ptr, a Real_Attribute_Access in reality - - function To_Real_Attribute is new - Ada.Unchecked_Conversion (Atomic_Address, Real_Attribute_Access); - - pragma Warnings (Off); - -- Kill warning about possible size mismatch - - function To_Address is new - Ada.Unchecked_Conversion (Attribute, Atomic_Address); - function To_Attribute is new - Ada.Unchecked_Conversion (Atomic_Address, Attribute); - - type Unsigned is mod 2 ** Integer'Size; - function To_Address is new - Ada.Unchecked_Conversion (Attribute, System.Address); - function To_Unsigned is new - Ada.Unchecked_Conversion (Attribute, Unsigned); - - pragma Warnings (On); - - function To_Address is new - Ada.Unchecked_Conversion (Real_Attribute_Access, Atomic_Address); - - pragma Warnings (Off); - -- Kill warning about possible aliasing - - function To_Handle is new - Ada.Unchecked_Conversion (System.Address, Attribute_Handle); - - pragma Warnings (On); - - function To_Task_Id is new - Ada.Unchecked_Conversion (Task_Identification.Task_Id, Task_Id); - -- To access TCB of identified task - - procedure Free is new - Ada.Unchecked_Deallocation (Real_Attribute, Real_Attribute_Access); - - Fast_Path : constant Boolean := - (Attribute'Size = Integer'Size - and then Attribute'Alignment <= Atomic_Address'Alignment - and then To_Unsigned (Initial_Value) = 0) - or else (Attribute'Size = System.Address'Size - and then Attribute'Alignment <= Atomic_Address'Alignment - and then To_Address (Initial_Value) = System.Null_Address); - -- If the attribute fits in an Atomic_Address (both size and alignment) - -- and Initial_Value is 0 (or null), then we will map the attribute - -- directly into ATCB.Attributes (Index), otherwise we will create - -- a level of indirection and instead use Attributes (Index) as a - -- Real_Attribute_Access. - - Index : constant Integer := - Next_Index (Require_Finalization => not Fast_Path); - -- Index in the task control block's Attributes array - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Cleanup : in out Attribute_Cleanup) is - pragma Unreferenced (Cleanup); - - begin - STPO.Lock_RTS; - - declare - C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List; - - begin - while C /= null loop - STPO.Write_Lock (C); - - if C.Attributes (Index) /= 0 - and then Require_Finalization (Index) - then - Deallocate (C.Attributes (Index)); - C.Attributes (Index) := 0; - end if; - - STPO.Unlock (C); - C := C.Common.All_Tasks_Link; - end loop; - end; - - Finalize (Index); - STPO.Unlock_RTS; - end Finalize; - - ---------------- - -- Deallocate -- - ---------------- - - procedure Deallocate (Ptr : Atomic_Address) is - Obj : Real_Attribute_Access := To_Real_Attribute (Ptr); - begin - Free (Obj); - end Deallocate; - - ------------------- - -- New_Attribute -- - ------------------- - - function New_Attribute (Val : Attribute) return Atomic_Address is - Tmp : Real_Attribute_Access; - begin - Tmp := new Real_Attribute'(Free => Deallocate'Unrestricted_Access, - Value => Val); - return To_Address (Tmp); - end New_Attribute; - - --------------- - -- Reference -- - --------------- - - function Reference - (T : Task_Identification.Task_Id := Task_Identification.Current_Task) - return Attribute_Handle - is - Self_Id : Task_Id; - TT : constant Task_Id := To_Task_Id (T); - Error_Message : constant String := "trying to get the reference of a "; - Result : Attribute_Handle; - - begin - if TT = null then - raise Program_Error with Error_Message & "null task"; - end if; - - if TT.Common.State = Terminated then - raise Tasking_Error with Error_Message & "terminated task"; - end if; - - if Fast_Path then - -- Kill warning about possible alignment mismatch. If this happens, - -- Fast_Path will be False anyway - pragma Warnings (Off); - return To_Handle (TT.Attributes (Index)'Address); - pragma Warnings (On); - else - Self_Id := STPO.Self; - Task_Lock (Self_Id); - - if TT.Attributes (Index) = 0 then - TT.Attributes (Index) := New_Attribute (Initial_Value); - end if; - - Result := To_Handle - (To_Real_Attribute (TT.Attributes (Index)).Value'Address); - Task_Unlock (Self_Id); - - return Result; - end if; - end Reference; - - ------------------ - -- Reinitialize -- - ------------------ - - procedure Reinitialize - (T : Task_Identification.Task_Id := Task_Identification.Current_Task) - is - Self_Id : Task_Id; - TT : constant Task_Id := To_Task_Id (T); - Error_Message : constant String := "Trying to Reinitialize a "; - - begin - if TT = null then - raise Program_Error with Error_Message & "null task"; - end if; - - if TT.Common.State = Terminated then - raise Tasking_Error with Error_Message & "terminated task"; - end if; - - if Fast_Path then - - -- No finalization needed, simply reset to Initial_Value - - TT.Attributes (Index) := To_Address (Initial_Value); - - else - Self_Id := STPO.Self; - Task_Lock (Self_Id); - - declare - Attr : Atomic_Address renames TT.Attributes (Index); - begin - if Attr /= 0 then - Deallocate (Attr); - Attr := 0; - end if; - end; - - Task_Unlock (Self_Id); - end if; - end Reinitialize; - - --------------- - -- Set_Value -- - --------------- - - procedure Set_Value - (Val : Attribute; - T : Task_Identification.Task_Id := Task_Identification.Current_Task) - is - Self_Id : Task_Id; - TT : constant Task_Id := To_Task_Id (T); - Error_Message : constant String := "trying to set the value of a "; - - begin - if TT = null then - raise Program_Error with Error_Message & "null task"; - end if; - - if TT.Common.State = Terminated then - raise Tasking_Error with Error_Message & "terminated task"; - end if; - - if Fast_Path then - - -- No finalization needed, simply set to Val - - if Attribute'Size = Integer'Size then - TT.Attributes (Index) := Atomic_Address (To_Unsigned (Val)); - else - TT.Attributes (Index) := To_Address (Val); - end if; - - else - Self_Id := STPO.Self; - Task_Lock (Self_Id); - - declare - Attr : Atomic_Address renames TT.Attributes (Index); - - begin - if Attr /= 0 then - Deallocate (Attr); - end if; - - Attr := New_Attribute (Val); - end; - - Task_Unlock (Self_Id); - end if; - end Set_Value; - - ----------- - -- Value -- - ----------- - - function Value - (T : Task_Identification.Task_Id := Task_Identification.Current_Task) - return Attribute - is - Self_Id : Task_Id; - TT : constant Task_Id := To_Task_Id (T); - Error_Message : constant String := "trying to get the value of a "; - - begin - if TT = null then - raise Program_Error with Error_Message & "null task"; - end if; - - if TT.Common.State = Terminated then - raise Tasking_Error with Error_Message & "terminated task"; - end if; - - if Fast_Path then - return To_Attribute (TT.Attributes (Index)); - - else - Self_Id := STPO.Self; - Task_Lock (Self_Id); - - declare - Attr : Atomic_Address renames TT.Attributes (Index); - - begin - if Attr = 0 then - Task_Unlock (Self_Id); - return Initial_Value; - - else - declare - Result : constant Attribute := - To_Real_Attribute (Attr).Value; - begin - Task_Unlock (Self_Id); - return Result; - end; - end if; - end; - end if; - end Value; - -end Ada.Task_Attributes; diff --git a/gcc/ada/a-tasatt.ads b/gcc/ada/a-tasatt.ads deleted file mode 100644 index 857cdd7956b..00000000000 --- a/gcc/ada/a-tasatt.ads +++ /dev/null @@ -1,93 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T A S K _ A T T R I B U T E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2014-2016, 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; - -generic - type Attribute is private; - Initial_Value : Attribute; - -package Ada.Task_Attributes is - - -- Note that this package will use an efficient implementation with no - -- locks and no extra dynamic memory allocation if Attribute is the size - -- of either Integer or System.Address, and Initial_Value is 0 (null for - -- an access type). - - -- Other types and initial values are supported, but will require - -- the use of locking and a level of indirection (meaning extra dynamic - -- memory allocation). - - -- The maximum number of task attributes supported by this implementation - -- is determined by the constant System.Parameters.Max_Attribute_Count. - -- If you exceed this number, Storage_Error will be raised during the - -- elaboration of the instantiation of this package. - - type Attribute_Handle is access all Attribute; - - function Value - (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) return Attribute; - -- Return the value of the corresponding attribute of T. Tasking_Error - -- is raised if T is terminated and Program_Error will be raised if T - -- is Null_Task_Id. - - function Reference - (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) return Attribute_Handle; - -- Return an access value that designates the corresponding attribute of - -- T. Tasking_Error is raised if T is terminated and Program_Error will be - -- raised if T is Null_Task_Id. - - procedure Set_Value - (Val : Attribute; - T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task); - -- Finalize the old value of the attribute of T and assign Val to that - -- attribute. Tasking_Error is raised if T is terminated and Program_Error - -- will be raised if T is Null_Task_Id. - - procedure Reinitialize - (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task); - -- Same as Set_Value (Initial_Value, T). Tasking_Error is raised if T is - -- terminated and Program_Error will be raised if T is Null_Task_Id. - -private - pragma Inline (Value); - pragma Inline (Reference); - pragma Inline (Set_Value); - pragma Inline (Reinitialize); -end Ada.Task_Attributes; diff --git a/gcc/ada/a-taside.adb b/gcc/ada/a-taside.adb deleted file mode 100644 index 9433669a6eb..00000000000 --- a/gcc/ada/a-taside.adb +++ /dev/null @@ -1,219 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T A S K _ I D E N T I F I C A T I O N -- --- -- --- 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. -- --- -- ------------------------------------------------------------------------------- - -with System.Address_Image; -with System.Parameters; -with System.Soft_Links; -with System.Task_Primitives; -with System.Task_Primitives.Operations; -with Ada.Unchecked_Conversion; - -pragma Warnings (Off); --- Allow withing of non-Preelaborated units in Ada 2005 mode where this --- package will be categorized as Preelaborate. See AI-362 for details. --- It is safe in the context of the run-time to violate the rules. - -with System.Tasking.Utilities; - -pragma Warnings (On); - -package body Ada.Task_Identification with - SPARK_Mode => Off -is - - use System.Parameters; - - package STPO renames System.Task_Primitives.Operations; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Convert_Ids (T : Task_Id) return System.Tasking.Task_Id; - function Convert_Ids (T : System.Tasking.Task_Id) return Task_Id; - pragma Inline (Convert_Ids); - -- Conversion functions between different forms of Task_Id - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Task_Id) return Boolean is - begin - return System.Tasking."=" (Convert_Ids (Left), Convert_Ids (Right)); - end "="; - - ----------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_Id) is - begin - if T = Null_Task_Id then - raise Program_Error; - else - System.Tasking.Utilities.Abort_Tasks - (System.Tasking.Task_List'(1 => Convert_Ids (T))); - end if; - end Abort_Task; - - ---------------------------- - -- Activation_Is_Complete -- - ---------------------------- - - function Activation_Is_Complete (T : Task_Id) return Boolean is - use type System.Tasking.Task_Id; - begin - if T = Null_Task_Id then - raise Program_Error; - else - return Convert_Ids (T).Common.Activator = null; - end if; - end Activation_Is_Complete; - - ----------------- - -- Convert_Ids -- - ----------------- - - function Convert_Ids (T : Task_Id) return System.Tasking.Task_Id is - begin - return System.Tasking.Task_Id (T); - end Convert_Ids; - - function Convert_Ids (T : System.Tasking.Task_Id) return Task_Id is - begin - return Task_Id (T); - end Convert_Ids; - - ------------------ - -- Current_Task -- - ------------------ - - function Current_Task return Task_Id is - begin - return Convert_Ids (System.Task_Primitives.Operations.Self); - end Current_Task; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_Id is - begin - return Convert_Ids (System.Task_Primitives.Operations.Environment_Task); - end Environment_Task; - - ----------- - -- Image -- - ----------- - - function Image (T : Task_Id) return String is - function To_Address is new - Ada.Unchecked_Conversion - (Task_Id, System.Task_Primitives.Task_Address); - - begin - if T = Null_Task_Id then - return ""; - - elsif T.Common.Task_Image_Len = 0 then - return System.Address_Image (To_Address (T)); - - else - return T.Common.Task_Image (1 .. T.Common.Task_Image_Len) - & "_" & System.Address_Image (To_Address (T)); - end if; - end Image; - - ----------------- - -- Is_Callable -- - ----------------- - - function Is_Callable (T : Task_Id) return Boolean is - Result : Boolean; - Id : constant System.Tasking.Task_Id := Convert_Ids (T); - begin - if T = Null_Task_Id then - raise Program_Error; - else - System.Soft_Links.Abort_Defer.all; - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Id); - Result := Id.Callable; - STPO.Unlock (Id); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - System.Soft_Links.Abort_Undefer.all; - return Result; - end if; - end Is_Callable; - - ------------------- - -- Is_Terminated -- - ------------------- - - function Is_Terminated (T : Task_Id) return Boolean is - Result : Boolean; - Id : constant System.Tasking.Task_Id := Convert_Ids (T); - - use System.Tasking; - - begin - if T = Null_Task_Id then - raise Program_Error; - else - System.Soft_Links.Abort_Defer.all; - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Id); - Result := Id.Common.State = Terminated; - STPO.Unlock (Id); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - System.Soft_Links.Abort_Undefer.all; - return Result; - end if; - end Is_Terminated; - -end Ada.Task_Identification; diff --git a/gcc/ada/a-taside.ads b/gcc/ada/a-taside.ads deleted file mode 100644 index 72467bf66d3..00000000000 --- a/gcc/ada/a-taside.ads +++ /dev/null @@ -1,97 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T A S K _ I D E N T I F I C A T I O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, 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 System; -with System.Tasking; - -package Ada.Task_Identification with - SPARK_Mode, - Abstract_State => (Tasking_State with Synchronous, - External => (Async_Readers, - Async_Writers)), - Initializes => Tasking_State -is - pragma Preelaborate; - -- In accordance with Ada 2005 AI-362 - - type Task_Id is private; - pragma Preelaborable_Initialization (Task_Id); - - Null_Task_Id : constant Task_Id; - - function "=" (Left, Right : Task_Id) return Boolean with - Global => null; - pragma Inline ("="); - - function Image (T : Task_Id) return String with - Global => null; - - function Current_Task return Task_Id with - Volatile_Function, - Global => Tasking_State; - pragma Inline (Current_Task); - - function Environment_Task return Task_Id with - SPARK_Mode => Off, - Global => null; - pragma Inline (Environment_Task); - - procedure Abort_Task (T : Task_Id) with - Global => null; - pragma Inline (Abort_Task); - -- Note: parameter is mode IN, not IN OUT, per AI-00101 - - function Is_Terminated (T : Task_Id) return Boolean with - Volatile_Function, - Global => Tasking_State; - pragma Inline (Is_Terminated); - - function Is_Callable (T : Task_Id) return Boolean with - Volatile_Function, - Global => Tasking_State; - pragma Inline (Is_Callable); - - function Activation_Is_Complete (T : Task_Id) return Boolean with - Volatile_Function, - Global => Tasking_State; - -private - pragma SPARK_Mode (Off); - - type Task_Id is new System.Tasking.Task_Id; - - Null_Task_Id : constant Task_Id := null; - -end Ada.Task_Identification; diff --git a/gcc/ada/g-boubuf.adb b/gcc/ada/g-boubuf.adb deleted file mode 100644 index 0613f5e06fb..00000000000 --- a/gcc/ada/g-boubuf.adb +++ /dev/null @@ -1,90 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . B O U N D E D _ B U F F E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-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 -- --- . -- --- -- --- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Bounded_Buffers is - - -------------------- - -- Bounded_Buffer -- - -------------------- - - protected body Bounded_Buffer is - - ------------ - -- Insert -- - ------------ - - entry Insert (Item : Element) when Count /= Capacity is - begin - Values (Next_In) := Item; - Next_In := (Next_In mod Capacity) + 1; - Count := Count + 1; - end Insert; - - ------------ - -- Remove -- - ------------ - - entry Remove (Item : out Element) when Count > 0 is - begin - Item := Values (Next_Out); - Next_Out := (Next_Out mod Capacity) + 1; - Count := Count - 1; - end Remove; - - ----------- - -- Empty -- - ----------- - - function Empty return Boolean is - begin - return Count = 0; - end Empty; - - ---------- - -- Full -- - ---------- - - function Full return Boolean is - begin - return Count = Capacity; - end Full; - - ------------ - -- Extent -- - ------------ - - function Extent return Natural is - begin - return Count; - end Extent; - - end Bounded_Buffer; - -end GNAT.Bounded_Buffers; diff --git a/gcc/ada/g-boubuf.ads b/gcc/ada/g-boubuf.ads deleted file mode 100644 index f94641ff620..00000000000 --- a/gcc/ada/g-boubuf.ads +++ /dev/null @@ -1,101 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . B O U N D E D _ B U F F E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - --- This package provides a thread-safe generic bounded buffer abstraction. --- Instances are useful directly or as parts of the implementations of other --- abstractions, such as mailboxes. - --- Bounded_Buffer is declared explicitly as a protected type, rather than as --- a simple limited private type completed as a protected type, so that --- clients may make calls accordingly (i.e., conditional/timed entry calls). - -with System; - -generic - type Element is private; - -- The type of the values contained within buffer objects - -package GNAT.Bounded_Buffers is - pragma Pure; - - type Content is array (Positive range <>) of Element; - -- Content is an internal artefact that cannot be hidden because protected - -- types cannot contain type declarations. - - Default_Ceiling : constant System.Priority := System.Default_Priority; - -- A convenience value for the Ceiling discriminant - - protected type Bounded_Buffer - (Capacity : Positive; - -- Objects of type Bounded_Buffer specify the maximum number of Element - -- values they can hold via the discriminant Capacity. - - Ceiling : System.Priority) - -- Users must specify the ceiling priority for the object. If the - -- Real-Time Systems Annex is not in use this value is not important. - is - pragma Priority (Ceiling); - - entry Insert (Item : Element); - -- Insert Item into the buffer, blocks caller until space is available - - entry Remove (Item : out Element); - -- Remove next available Element from buffer. Blocks caller until an - -- Element is available. - - function Empty return Boolean; - -- Returns whether the instance contains any Elements. - -- Note: State may change immediately after call returns. - - function Full return Boolean; - -- Returns whether any space remains within the instance. - -- Note: State may change immediately after call returns. - - function Extent return Natural; - -- Returns the number of Element values currently held - -- within the instance. - -- Note: State may change immediately after call returns. - - private - Values : Content (1 .. Capacity); - -- The container for the values held by the buffer instance - - Next_In : Positive := 1; - -- The index of the next Element inserted. Wraps around - - Next_Out : Positive := 1; - -- The index of the next Element removed. Wraps around - - Count : Natural := 0; - -- The number of Elements currently held - end Bounded_Buffer; - -end GNAT.Bounded_Buffers; diff --git a/gcc/ada/g-boumai.ads b/gcc/ada/g-boumai.ads deleted file mode 100644 index 8276e62de85..00000000000 --- a/gcc/ada/g-boumai.ads +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . B O U N D E D _ M A I L B O X E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - --- This package provides a thread-safe asynchronous communication facility --- in the form of mailboxes. Individual mailbox objects are bounded in size --- to a value specified by their Capacity discriminants. - --- Mailboxes actually hold references to messages, not the message values --- themselves. - --- Type Mailbox is defined explicitly as a protected type (via derivation --- from a protected type) so that clients may treat them accordingly (for --- example, by making conditional/timed entry calls). - -with System; -with GNAT.Bounded_Buffers; - -generic - type Message (<>) is limited private; - type Message_Reference is access all Message; - -- Mailboxes hold references to Message values, of this type - -package GNAT.Bounded_Mailboxes is - pragma Preelaborate; - - package Message_Refs is - new GNAT.Bounded_Buffers (Message_Reference); - - type Mailbox is new Message_Refs.Bounded_Buffer; - - -- Type Mailbox has two inherited discriminants: - - -- Capacity : Positive; - -- Capacity is the maximum number of Message references - -- possibly contained at any given instant. - - -- Ceiling : System.Priority; - -- Users must specify the ceiling priority for the object. - -- If the Real-Time Systems Annex is not in use this value - -- is not important. - - -- Protected type Mailbox has the following inherited interface: - - -- entry Insert (Item : Message_Reference); - -- Insert Item into the Mailbox. Blocks caller - -- until space is available. - - -- entry Remove (Item : out Message_Reference); - -- Remove next available Message_Reference from Mailbox. - -- Blocks caller until a Message_Reference is available. - - -- function Empty return Boolean; - -- Returns whether the Mailbox contains any Message_References. - -- Note: State may change immediately after call returns. - - -- function Full return Boolean; - -- Returns whether any space remains within the Mailbox. - -- Note: State may change immediately after call returns. - - -- function Extent return Natural; - -- Returns the number of Message_Reference values currently held - -- within the Mailbox. - -- Note: State may change immediately after call returns. - - Default_Ceiling : constant System.Priority := Message_Refs.Default_Ceiling; - -- A convenience value for the Ceiling discriminant - -end GNAT.Bounded_Mailboxes; diff --git a/gcc/ada/g-semaph.adb b/gcc/ada/g-semaph.adb deleted file mode 100644 index e6d4d73dc88..00000000000 --- a/gcc/ada/g-semaph.adb +++ /dev/null @@ -1,84 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E M A P H O R E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Semaphores is - - ------------------------ - -- Counting_Semaphore -- - ------------------------ - - protected body Counting_Semaphore is - - ----------- - -- Seize -- - ----------- - - entry Seize when Count > 0 is - begin - Count := Count - 1; - end Seize; - - ------------- - -- Release -- - ------------- - - procedure Release is - begin - Count := Count + 1; - end Release; - end Counting_Semaphore; - - ---------------------- - -- Binary_Semaphore -- - ---------------------- - - protected body Binary_Semaphore is - - ----------- - -- Seize -- - ----------- - - entry Seize when Available is - begin - Available := False; - end Seize; - - ------------- - -- Release -- - ------------- - - procedure Release is - begin - Available := True; - end Release; - end Binary_Semaphore; - -end GNAT.Semaphores; diff --git a/gcc/ada/g-semaph.ads b/gcc/ada/g-semaph.ads deleted file mode 100644 index 027b78aac65..00000000000 --- a/gcc/ada/g-semaph.ads +++ /dev/null @@ -1,97 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E M A P H O R E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - --- This package provides classic counting semaphores and binary semaphores. --- Both types are visibly defined as protected types so that users can make --- conditional and timed calls when appropriate. - -with System; - -package GNAT.Semaphores is - - Default_Ceiling : constant System.Priority := System.Default_Priority; - -- A convenient value for the priority discriminants that follow - - ------------------------ - -- Counting_Semaphore -- - ------------------------ - - protected type Counting_Semaphore - (Initial_Value : Natural; - -- A counting semaphore contains an internal counter. The initial - -- value of this counter is set by clients via the discriminant. - - Ceiling : System.Priority) - -- Users must specify the ceiling priority for the object. If the - -- Real-Time Systems Annex is not in use this value is not important. - is - pragma Priority (Ceiling); - - entry Seize; - -- Blocks caller until/unless the semaphore's internal counter is - -- greater than zero. Decrements the semaphore's internal counter when - -- executed. - - procedure Release; - -- Increments the semaphore's internal counter - - private - Count : Natural := Initial_Value; - end Counting_Semaphore; - - ---------------------- - -- Binary_Semaphore -- - ---------------------- - - protected type Binary_Semaphore - (Initially_Available : Boolean; - -- Binary semaphores are either available or not; there is no internal - -- count involved. The discriminant value determines whether the - -- individual object is initially available. - - Ceiling : System.Priority) - -- Users must specify the ceiling priority for the object. If the - -- Real-Time Systems Annex is not in use this value is not important. - is - pragma Priority (Ceiling); - - entry Seize; - -- Blocks the caller unless/until semaphore is available. After - -- execution the semaphore is no longer available. - - procedure Release; - -- Makes the semaphore available - - private - Available : Boolean := Initially_Available; - end Binary_Semaphore; - -end GNAT.Semaphores; diff --git a/gcc/ada/g-signal.adb b/gcc/ada/g-signal.adb deleted file mode 100644 index 37ba5946569..00000000000 --- a/gcc/ada/g-signal.adb +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . S I G N A L S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2009, 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. -- --- -- ------------------------------------------------------------------------------- - -with System.Interrupts; - -package body GNAT.Signals is - - package SI renames System.Interrupts; - - ------------------ - -- Block_Signal -- - ------------------ - - procedure Block_Signal (Signal : Ada.Interrupts.Interrupt_ID) is - begin - SI.Block_Interrupt (SI.Interrupt_ID (Signal)); - end Block_Signal; - - ---------------- - -- Is_Blocked -- - ---------------- - - function Is_Blocked (Signal : Ada.Interrupts.Interrupt_ID) return Boolean is - begin - return SI.Is_Blocked (SI.Interrupt_ID (Signal)); - end Is_Blocked; - - -------------------- - -- Unblock_Signal -- - -------------------- - - procedure Unblock_Signal (Signal : Ada.Interrupts.Interrupt_ID) is - begin - SI.Unblock_Interrupt (SI.Interrupt_ID (Signal)); - end Unblock_Signal; - -end GNAT.Signals; diff --git a/gcc/ada/g-signal.ads b/gcc/ada/g-signal.ads deleted file mode 100644 index 2a278046964..00000000000 --- a/gcc/ada/g-signal.ads +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . S I G N A L S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-2009, 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 provides operations for querying and setting the blocked --- status of signals. - --- This package is supported only on targets where Ada.Interrupts.Interrupt_ID --- corresponds to software signals on the target, and where System.Interrupts --- provides the ability to block and unblock signals. - -with Ada.Interrupts; - -package GNAT.Signals is - - procedure Block_Signal (Signal : Ada.Interrupts.Interrupt_ID); - -- Block "Signal" at the process level - - procedure Unblock_Signal (Signal : Ada.Interrupts.Interrupt_ID); - -- Unblock "Signal" at the process level - - function Is_Blocked (Signal : Ada.Interrupts.Interrupt_ID) return Boolean; - -- "Signal" blocked at the process level? - -end GNAT.Signals; diff --git a/gcc/ada/g-tastus.ads b/gcc/ada/g-tastus.ads deleted file mode 100644 index ffb9fe0fe38..00000000000 --- a/gcc/ada/g-tastus.ads +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . T A S K _ S T A C K _ U S A G E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2011, 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 an API to query for tasks stack usage at runtime --- and during debug. - --- See file s-stusta.ads for full documentation of the interface - -with System.Stack_Usage.Tasking; - -package GNAT.Task_Stack_Usage renames System.Stack_Usage.Tasking; diff --git a/gcc/ada/g-thread.adb b/gcc/ada/g-thread.adb deleted file mode 100644 index 28ca19cf638..00000000000 --- a/gcc/ada/g-thread.adb +++ /dev/null @@ -1,186 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T H R E A D S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-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 -- --- . -- --- -- --- 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; use Ada.Task_Identification; -with System.Task_Primitives.Operations; -with System.Tasking; -with System.Tasking.Stages; use System.Tasking.Stages; -with System.OS_Interface; use System.OS_Interface; -with System.Soft_Links; use System.Soft_Links; -with Ada.Unchecked_Conversion; - -package body GNAT.Threads is - - use System; - - package STPO renames System.Task_Primitives.Operations; - - type Thread_Id_Ptr is access all Thread_Id; - - pragma Warnings (Off); - -- The following unchecked conversions are aliasing safe, since they - -- are never used to create pointers to improperly aliased data. - - function To_Addr is new Ada.Unchecked_Conversion (Task_Id, Address); - function To_Id is new Ada.Unchecked_Conversion (Address, Task_Id); - function To_Id is new Ada.Unchecked_Conversion (Address, Tasking.Task_Id); - function To_Tid is new Ada.Unchecked_Conversion - (Address, Ada.Task_Identification.Task_Id); - function To_Thread is new Ada.Unchecked_Conversion (Address, Thread_Id_Ptr); - - pragma Warnings (On); - - type Code_Proc is access procedure (Id : Address; Parm : Void_Ptr); - - task type Thread - (Stsz : Natural; - Prio : Any_Priority; - Parm : Void_Ptr; - Code : Code_Proc) - is - pragma Priority (Prio); - pragma Storage_Size (Stsz); - end Thread; - - task body Thread is - begin - Code.all (To_Addr (Current_Task), Parm); - end Thread; - - type Tptr is access Thread; - - ------------------- - -- Create_Thread -- - ------------------- - - function Create_Thread - (Code : Address; - Parm : Void_Ptr; - Size : Natural; - Prio : Integer) return System.Address - is - TP : Tptr; - - function To_CP is new Ada.Unchecked_Conversion (Address, Code_Proc); - - begin - TP := new Thread (Size, Prio, Parm, To_CP (Code)); - return To_Addr (TP'Identity); - end Create_Thread; - - --------------------- - -- Register_Thread -- - --------------------- - - function Register_Thread return System.Address is - begin - return Task_Primitives.Operations.Register_Foreign_Thread.all'Address; - end Register_Thread; - - ----------------------- - -- Unregister_Thread -- - ----------------------- - - procedure Unregister_Thread is - Self_Id : constant Tasking.Task_Id := Task_Primitives.Operations.Self; - begin - Self_Id.Common.State := Tasking.Terminated; - Destroy_TSD (Self_Id.Common.Compiler_Data); - Free_Task (Self_Id); - end Unregister_Thread; - - -------------------------- - -- Unregister_Thread_Id -- - -------------------------- - - procedure Unregister_Thread_Id (Thread : System.Address) is - Thr : constant Thread_Id := To_Thread (Thread).all; - T : Tasking.Task_Id; - - use type Tasking.Task_Id; - -- This use clause should be removed once a visibility problem - -- with the MaRTE run time has been fixed. ??? - - pragma Warnings (Off); - use type System.OS_Interface.Thread_Id; - pragma Warnings (On); - - begin - STPO.Lock_RTS; - - T := Tasking.All_Tasks_List; - loop - exit when T = null or else STPO.Get_Thread_Id (T) = Thr; - - T := T.Common.All_Tasks_Link; - end loop; - - STPO.Unlock_RTS; - - if T /= null then - T.Common.State := Tasking.Terminated; - Destroy_TSD (T.Common.Compiler_Data); - Free_Task (T); - end if; - end Unregister_Thread_Id; - - -------------------- - -- Destroy_Thread -- - -------------------- - - procedure Destroy_Thread (Id : Address) is - Tid : constant Task_Id := To_Id (Id); - begin - Abort_Task (Tid); - end Destroy_Thread; - - ---------------- - -- Get_Thread -- - ---------------- - - procedure Get_Thread (Id : Address; Thread : Address) is - Thr : constant Thread_Id_Ptr := To_Thread (Thread); - begin - Thr.all := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id)); - end Get_Thread; - - ---------------- - -- To_Task_Id -- - ---------------- - - function To_Task_Id - (Id : System.Address) return Ada.Task_Identification.Task_Id - is - begin - return To_Tid (Id); - end To_Task_Id; - -end GNAT.Threads; diff --git a/gcc/ada/g-thread.ads b/gcc/ada/g-thread.ads deleted file mode 100644 index 32f661b59e7..00000000000 --- a/gcc/ada/g-thread.ads +++ /dev/null @@ -1,149 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T H R E A D S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides facilities for creation or registration of foreign --- threads for use as Ada tasks. In order to execute general Ada code, the --- run-time system must know about all tasks. This package allows foreign --- code, e.g. a C program, to create a thread that the Ada run-time knows --- about, or to register the current thread. - --- For some implementations of GNAT Pro, the registration of foreign threads --- is automatic. However, in such implementations, if the Ada program has no --- tasks at all and no tasking constructs other than delay, then by default --- the non-tasking version of the Ada run-time will be loaded. If foreign --- threads are present, it is important to ensure that the tasking version --- of the Ada run time is loaded. This may be achieved by adding "with --- GNAT.Threads" to any unit in the partition. - -with System; -with Ada.Task_Identification; - -package GNAT.Threads is - - type Void_Ptr is access all Integer; - - function Create_Thread - (Code : System.Address; -- pointer - Parm : Void_Ptr; -- pointer - Size : Natural; -- int - Prio : Integer) -- int - return System.Address; - pragma Export (C, Create_Thread, "__gnat_create_thread"); - -- Creates a thread with the given (Size) stack size in bytes, and - -- the given (Prio) priority. The task will execute a call to the - -- procedure whose address is given by Code. This procedure has - -- the prototype - -- - -- void thread_code (void *id, void *parm); - -- - -- where id is the id of the created task, and parm is the parameter - -- passed to Create_Thread. The called procedure is the body of the - -- code for the task, the task will be automatically terminated when - -- the procedure returns. - -- - -- This function returns the Ada Id of the created task that can then be - -- used as a parameter to the procedures below. - -- - -- C declaration: - -- - -- extern void *__gnat_create_thread - -- (void (*code)(void *, void *), void *parm, int size, int prio); - - function Register_Thread return System.Address; - pragma Export (C, Register_Thread, "__gnat_register_thread"); - -- Create an Ada task Id for the current thread if needed. - -- If the thread could not be registered, System.Null_Address is returned. - -- - -- This function returns the Ada Id of the current task that can then be - -- used as a parameter to the procedures below. - -- - -- C declaration: - -- - -- extern void *__gnat_register_thread (); - -- - -- Here is a typical usage of the Register/Unregister_Thread procedures: - -- - -- void thread_body () - -- { - -- void *task_id = __gnat_register_thread (); - -- ... thread body ... - -- __gnat_unregister_thread (); - -- } - - procedure Unregister_Thread; - pragma Export (C, Unregister_Thread, "__gnat_unregister_thread"); - -- Unregister the current task from the GNAT run time and destroy the - -- memory allocated for its task id. - -- - -- C declaration: - -- - -- extern void __gnat_unregister_thread (); - - procedure Unregister_Thread_Id (Thread : System.Address); - pragma Export (C, Unregister_Thread_Id, "__gnat_unregister_thread_id"); - -- Unregister the task associated with Thread from the GNAT run time and - -- destroy the memory allocated for its task id. - -- If no task id is associated with Thread, do nothing. - -- - -- C declaration: - -- - -- extern void __gnat_unregister_thread_id (pthread_t *thread); - - procedure Destroy_Thread (Id : System.Address); - pragma Export (C, Destroy_Thread, "__gnat_destroy_thread"); - -- This procedure may be used to prematurely abort the created thread. - -- The value Id is the value that was passed to the thread code procedure - -- at activation time. - -- - -- C declaration: - -- - -- extern void __gnat_destroy_thread (void *id); - - procedure Get_Thread (Id : System.Address; Thread : System.Address); - pragma Export (C, Get_Thread, "__gnat_get_thread"); - -- This procedure is used to retrieve the thread id of a given task. - -- The value Id is the value that was passed to the thread code procedure - -- at activation time. - -- Thread is a pointer to a thread id that will be updated by this - -- procedure. - -- - -- C declaration: - -- - -- extern void __gnat_get_thread (void *id, pthread_t *thread); - - function To_Task_Id - (Id : System.Address) - return Ada.Task_Identification.Task_Id; - -- Ada interface only. - -- Given a low level Id, as returned by Create_Thread, return a Task_Id, - -- so that operations in Ada.Task_Identification can be used. - -end GNAT.Threads; diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 9ad7783e43b..ef3dbec1079 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -355,13 +355,13 @@ endif # Non-tasking case: LIBGNAT_TARGET_PAIRS = \ -a-intnam.ads. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Interfaces.VxWorks.Int_Connection is - - Connection_Routine : Interrupt_Connector; - pragma Import (C, Connection_Routine, "__gnat_user_int_connect"); - -- Declared in System.Interrupts. Defaults to the standard OS connector in - -- System.OS_Interface (or Interfaces.VxWorks for restricted runtimes). - - ------------- - -- Connect -- - ------------- - - procedure Connect (Connector : Interrupt_Connector) is - begin - Connection_Routine := Connector; - end Connect; - -end Interfaces.VxWorks.Int_Connection; diff --git a/gcc/ada/i-vxinco.ads b/gcc/ada/i-vxinco.ads deleted file mode 100644 index 04ae6cfe0a4..00000000000 --- a/gcc/ada/i-vxinco.ads +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- I N T E R F A C E S . V X W O R K S . I N T _ C O N N E C T I O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2016, AdaCore --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License 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 package provides users with the ability to use a custom routine for --- connecting hardware interrupts for VxWorks environments that support the --- capability to handle them. The custom routine must have the same profile --- as the VxWorks intConnect() routine. - -with System; - -package Interfaces.VxWorks.Int_Connection is - - type Interrupt_Connector is access function - (Vector : Interrupt_Vector; - Handler : VOIDFUNCPTR; - Parameter : System.Address := System.Null_Address) return STATUS; - pragma Convention (C, Interrupt_Connector); - -- Convention C for compatibility with intConnect(). User alternatives are - -- likely to be imports of C routines anyway. - - procedure Connect (Connector : Interrupt_Connector); - -- Set user-defined interrupt connection routine. Must precede calls to - -- Ada.Interrupts.Attach_Handler, or the default connector from - -- System.OS_Interface (or Interfaces.VxWorks for Ravenscar Cert) will be - -- used. Can be called multiple times to change the connection routine for - -- subsequent calls to Attach_Handler. - -end Interfaces.VxWorks.Int_Connection; diff --git a/gcc/ada/libgnarl/a-astaco.adb b/gcc/ada/libgnarl/a-astaco.adb new file mode 100644 index 00000000000..ecbab5eee28 --- /dev/null +++ b/gcc/ada/libgnarl/a-astaco.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . A S Y N C H R O N O U S _ T A S K _ C O N T R O L -- +-- -- +-- 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 is a dummy body, which will not normally be compiled when used with +-- standard versions of GNAT, which do not support this package. See comments +-- in spec for further details. + +package body Ada.Asynchronous_Task_Control is + + -------------- + -- Continue -- + -------------- + + procedure Continue (T : Ada.Task_Identification.Task_Id) is + begin + null; + end Continue; + + ---------- + -- Hold -- + ---------- + + procedure Hold (T : Ada.Task_Identification.Task_Id) is + begin + raise Program_Error; + end Hold; + + ------------- + -- Is_Held -- + ------------- + + function Is_Held (T : Ada.Task_Identification.Task_Id) return Boolean is + begin + return False; + end Is_Held; + +end Ada.Asynchronous_Task_Control; diff --git a/gcc/ada/libgnarl/a-astaco.ads b/gcc/ada/libgnarl/a-astaco.ads new file mode 100644 index 00000000000..1fa7c25697d --- /dev/null +++ b/gcc/ada/libgnarl/a-astaco.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . A S Y N C H R O N O U S _ T A S K _ C O N T R O L -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. The RM anticipates this situation (RM D.11(10)), and permits +-- an implementation to leave this unimplemented even if the Real-Time Systems +-- annex is fully supported. + +-- If a target environment provides appropriate support for this package, then +-- the Unimplemented_Unit pragma should be removed from this spec, and an +-- appropriate body provided. The framework for such a body is included in the +-- distributed sources. + +with Ada.Task_Identification; + +package Ada.Asynchronous_Task_Control is + pragma Preelaborate; + -- In accordance with Ada 2005 AI-362 + + pragma Unimplemented_Unit; + + procedure Hold (T : Ada.Task_Identification.Task_Id); + + procedure Continue (T : Ada.Task_Identification.Task_Id); + + function Is_Held (T : Ada.Task_Identification.Task_Id) return Boolean; + +end Ada.Asynchronous_Task_Control; diff --git a/gcc/ada/libgnarl/a-dinopr.ads b/gcc/ada/libgnarl/a-dinopr.ads new file mode 100644 index 00000000000..396aeaeae97 --- /dev/null +++ b/gcc/ada/libgnarl/a-dinopr.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G . N O N _ P R E E M P T I V E -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. + +-- If a target environment provides appropriate support for this package, +-- then the Unimplemented_Unit pragma should be removed from this spec and +-- an appropriate body provided. + +package Ada.Dispatching.Non_Preemptive is + pragma Preelaborate (Non_Preemptive); + + pragma Unimplemented_Unit; + + procedure Yield_To_Higher; + procedure Yield_To_Same_Or_Higher renames Yield; +end Ada.Dispatching.Non_Preemptive; diff --git a/gcc/ada/libgnarl/a-diroro.ads b/gcc/ada/libgnarl/a-diroro.ads new file mode 100644 index 00000000000..2cdaeb1f2b1 --- /dev/null +++ b/gcc/ada/libgnarl/a-diroro.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G . R O U N D _ R O B I N -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with System; +with Ada.Real_Time; + +package Ada.Dispatching.Round_Robin is + + pragma Unimplemented_Unit; + + Default_Quantum : constant Ada.Real_Time.Time_Span := + Ada.Real_Time.Milliseconds (10); + + procedure Set_Quantum + (Pri : System.Priority; + Quantum : Ada.Real_Time.Time_Span); + + procedure Set_Quantum + (Low, High : System.Priority; + Quantum : Ada.Real_Time.Time_Span); + + function Actual_Quantum + (Pri : System.Priority) return Ada.Real_Time.Time_Span; + + function Is_Round_Robin (Pri : System.Priority) return Boolean; + +end Ada.Dispatching.Round_Robin; diff --git a/gcc/ada/libgnarl/a-disedf.ads b/gcc/ada/libgnarl/a-disedf.ads new file mode 100644 index 00000000000..4b28a6db333 --- /dev/null +++ b/gcc/ada/libgnarl/a-disedf.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G . E D F -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. + +-- If a target environment provides appropriate support for this package, +-- then the Unimplemented_Unit pragma should be removed from this spec and +-- an appropriate body provided. + +with Ada.Real_Time; +with Ada.Task_Identification; + +package Ada.Dispatching.EDF is + pragma Preelaborate; + + pragma Unimplemented_Unit; + + subtype Deadline is Ada.Real_Time.Time; + + Default_Deadline : constant Deadline := Ada.Real_Time.Time_Last; + + procedure Set_Deadline + (D : Deadline; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + + procedure Delay_Until_And_Set_Deadline + (Delay_Until_Time : Ada.Real_Time.Time; + Deadline_Offset : Ada.Real_Time.Time_Span); + + function Get_Deadline + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return Deadline + with + SPARK_Mode, + Volatile_Function, + Global => Ada.Task_Identification.Tasking_State; + +end Ada.Dispatching.EDF; diff --git a/gcc/ada/libgnarl/a-dispat.adb b/gcc/ada/libgnarl/a-dispat.adb new file mode 100644 index 00000000000..dc9c17426a1 --- /dev/null +++ b/gcc/ada/libgnarl/a-dispat.adb @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2015-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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; +with System.Tasking; +with System.Task_Primitives.Operations; + +package body Ada.Dispatching is + + procedure Yield is + Self_Id : constant System.Tasking.Task_Id := + System.Task_Primitives.Operations.Self; + + begin + -- If pragma Detect_Blocking is active, Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + else + System.Task_Primitives.Operations.Yield; + end if; + end Yield; + +end Ada.Dispatching; diff --git a/gcc/ada/libgnarl/a-dispat.ads b/gcc/ada/libgnarl/a-dispat.ads new file mode 100644 index 00000000000..b4e4d036b11 --- /dev/null +++ b/gcc/ada/libgnarl/a-dispat.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Dispatching is + pragma Preelaborate (Dispatching); + + procedure Yield with + Global => null; + + Dispatching_Policy_Error : exception; +end Ada.Dispatching; diff --git a/gcc/ada/libgnarl/a-dynpri.adb b/gcc/ada/libgnarl/a-dynpri.adb new file mode 100644 index 00000000000..1b91f795e22 --- /dev/null +++ b/gcc/ada/libgnarl/a-dynpri.adb @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . D Y N A M I C _ P R I O R I T I E 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Primitives.Operations; +with System.Tasking; +with System.Parameters; +with System.Soft_Links; + +with Ada.Unchecked_Conversion; + +package body Ada.Dynamic_Priorities is + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + + use System.Parameters; + use System.Tasking; + + function Convert_Ids is new + Ada.Unchecked_Conversion + (Task_Identification.Task_Id, System.Tasking.Task_Id); + + ------------------ + -- Get_Priority -- + ------------------ + + -- Inquire base priority of a task + + function Get_Priority + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return System.Any_Priority + is + Target : constant Task_Id := Convert_Ids (T); + Error_Message : constant String := "Trying to get the priority of a "; + + begin + if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then + raise Program_Error with Error_Message & "null task"; + end if; + + if Task_Identification.Is_Terminated (T) then + raise Tasking_Error with Error_Message & "terminated task"; + end if; + + return Target.Common.Base_Priority; + end Get_Priority; + + ------------------ + -- Set_Priority -- + ------------------ + + -- Change base priority of a task dynamically + + procedure Set_Priority + (Priority : System.Any_Priority; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + is + Target : constant Task_Id := Convert_Ids (T); + Error_Message : constant String := "Trying to set the priority of a "; + Yield_Needed : Boolean; + + begin + if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then + raise Program_Error with Error_Message & "null task"; + end if; + + -- Setting the priority of an already-terminated task doesn't do + -- anything (see RM-D.5.1(7)). Note that Get_Priority is different in + -- this regard. + + if Task_Identification.Is_Terminated (T) then + return; + end if; + + SSL.Abort_Defer.all; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Target); + + Target.Common.Base_Priority := Priority; + + if Target.Common.Call /= null + and then + Target.Common.Call.Acceptor_Prev_Priority /= Priority_Not_Boosted + then + -- Target is within a rendezvous, so ensure the correct priority + -- will be reset when finishing the rendezvous, and only change the + -- priority immediately if the new priority is greater than the + -- current (inherited) priority. + + Target.Common.Call.Acceptor_Prev_Priority := Priority; + + if Priority >= Target.Common.Current_Priority then + Yield_Needed := True; + STPO.Set_Priority (Target, Priority); + else + Yield_Needed := False; + end if; + + else + Yield_Needed := True; + STPO.Set_Priority (Target, Priority); + + if Target.Common.State = Entry_Caller_Sleep then + Target.Pending_Priority_Change := True; + STPO.Wakeup (Target, Target.Common.State); + end if; + end if; + + STPO.Unlock (Target); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + if STPO.Self = Target and then Yield_Needed then + + -- Yield is needed to enforce FIFO task dispatching + + -- LL Set_Priority is made while holding the RTS lock so that it is + -- inheriting high priority until it release all the RTS locks. + + -- If this is used in a system where Ceiling Locking is not enforced + -- we may end up getting two Yield effects. + + STPO.Yield; + end if; + + SSL.Abort_Undefer.all; + end Set_Priority; + +end Ada.Dynamic_Priorities; diff --git a/gcc/ada/libgnarl/a-dynpri.ads b/gcc/ada/libgnarl/a-dynpri.ads new file mode 100644 index 00000000000..24fbbe48d8d --- /dev/null +++ b/gcc/ada/libgnarl/a-dynpri.ads @@ -0,0 +1,33 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D Y N A M I C _ P R I O R I T I E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with System; +with Ada.Task_Identification; + +package Ada.Dynamic_Priorities is + pragma Preelaborate; + -- In accordance with Ada 2005 AI-362 + + procedure Set_Priority + (Priority : System.Any_Priority; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + + function Get_Priority + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + return System.Any_Priority; + +end Ada.Dynamic_Priorities; diff --git a/gcc/ada/libgnarl/a-etgrbu.ads b/gcc/ada/libgnarl/a-etgrbu.ads new file mode 100644 index 00000000000..922d07470ce --- /dev/null +++ b/gcc/ada/libgnarl/a-etgrbu.ads @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X E C U T I O N _ T I M E . G R O U P _ B U D G E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2015-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 unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. + +-- If a target environment provides appropriate support for this package, +-- then the Unimplemented_Unit pragma should be removed from this spec and +-- an appropriate body provided. + +with System; +with System.Multiprocessors; + +package Ada.Execution_Time.Group_Budgets is + pragma Unimplemented_Unit; + + type Group_Budget + (CPU : System.Multiprocessors.CPU := System.Multiprocessors.CPU'First) + is tagged limited private; + + type Group_Budget_Handler is access + protected procedure (GB : in out Group_Budget); + + type Task_Array is + array (Positive range <>) of Ada.Task_Identification.Task_Id; + + Min_Handler_Ceiling : constant System.Any_Priority := + System.Any_Priority'First; + -- Initial value is an arbitrary choice ??? + + procedure Add_Task + (GB : in out Group_Budget; + T : Ada.Task_Identification.Task_Id); + + procedure Remove_Task + (GB : in out Group_Budget; + T : Ada.Task_Identification.Task_Id); + + function Is_Member + (GB : Group_Budget; + T : Ada.Task_Identification.Task_Id) return Boolean; + + function Is_A_Group_Member + (T : Ada.Task_Identification.Task_Id) return Boolean; + + function Members (GB : Group_Budget) return Task_Array; + + procedure Replenish + (GB : in out Group_Budget; + To : Ada.Real_Time.Time_Span); + + procedure Add + (GB : in out Group_Budget; + Interval : Ada.Real_Time.Time_Span); + + function Budget_Has_Expired (GB : Group_Budget) return Boolean; + + function Budget_Remaining + (GB : Group_Budget) return Ada.Real_Time.Time_Span; + + procedure Set_Handler + (GB : in out Group_Budget; + Handler : Group_Budget_Handler); + + function Current_Handler (GB : Group_Budget) return Group_Budget_Handler; + + procedure Cancel_Handler + (GB : in out Group_Budget; + Cancelled : out Boolean); + + Group_Budget_Error : exception; + +private + type Group_Budget + (CPU : System.Multiprocessors.CPU := System.Multiprocessors.CPU'First) + is tagged limited null record; +end Ada.Execution_Time.Group_Budgets; 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-exetim.ads b/gcc/ada/libgnarl/a-exetim.ads new file mode 100644 index 00000000000..d75b6befb6f --- /dev/null +++ b/gcc/ada/libgnarl/a-exetim.ads @@ -0,0 +1,119 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X E C U T I O N _ T I M E -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. + +-- If a target environment provides appropriate support for this package +-- then the Unimplemented_Unit pragma should be removed from this spec and +-- an appropriate body provided. + +with Ada.Task_Identification; +with Ada.Real_Time; + +package Ada.Execution_Time with + SPARK_Mode +is + pragma Preelaborate; + + pragma Unimplemented_Unit; + + 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; + +end Ada.Execution_Time; diff --git a/gcc/ada/libgnarl/a-extiin.ads b/gcc/ada/libgnarl/a-extiin.ads new file mode 100644 index 00000000000..a4edb8f28e7 --- /dev/null +++ b/gcc/ada/libgnarl/a-extiin.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X E C U T I O N _ T I M E . I N T E R R U P T S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Interrupts; +with Ada.Real_Time; + +package Ada.Execution_Time.Interrupts with + SPARK_Mode +is + + pragma Unimplemented_Unit; + + function Clock (Interrupt : Ada.Interrupts.Interrupt_ID) return CPU_Time + with + Volatile_Function, + Global => Ada.Real_Time.Clock_Time, + Pre => Separate_Interrupt_Clocks_Supported; + + function Supported (Interrupt : Ada.Interrupts.Interrupt_ID) return Boolean + with + Global => null; + +end Ada.Execution_Time.Interrupts; diff --git a/gcc/ada/libgnarl/a-extiti.ads b/gcc/ada/libgnarl/a-extiti.ads new file mode 100644 index 00000000000..411371dec0e --- /dev/null +++ b/gcc/ada/libgnarl/a-extiti.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X E C U T I O N _ T I M E . T I M E R S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. + +-- If a target environment provides appropriate support for this package, +-- then the Unimplemented_Unit pragma should be removed from this spec and +-- an appropriate body provided. + +with System; + +package Ada.Execution_Time.Timers is + pragma Preelaborate; + + pragma Unimplemented_Unit; + + type Timer (T : not null access constant Ada.Task_Identification.Task_Id) is + tagged limited private; + + type Timer_Handler is access protected procedure (TM : in out Timer); + + Min_Handler_Ceiling : constant System.Any_Priority := System.Priority'Last; + + procedure Set_Handler + (TM : in out Timer; + In_Time : Ada.Real_Time.Time_Span; + Handler : Timer_Handler); + + procedure Set_Handler + (TM : in out Timer; + At_Time : CPU_Time; + Handler : Timer_Handler); + + function Current_Handler (TM : Timer) return Timer_Handler; + + procedure Cancel_Handler + (TM : in out Timer; + Cancelled : out Boolean); + + function Time_Remaining (TM : Timer) return Ada.Real_Time.Time_Span; + + Timer_Resource_Error : exception; + +private + type Timer (T : access Ada.Task_Identification.Task_Id) is + tagged limited null record; +end Ada.Execution_Time.Timers; diff --git a/gcc/ada/libgnarl/a-interr.adb b/gcc/ada/libgnarl/a-interr.adb new file mode 100644 index 00000000000..31c8aeae61c --- /dev/null +++ b/gcc/ada/libgnarl/a-interr.adb @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body Ada.Interrupts is + + package SI renames System.Interrupts; + + function To_System is new Ada.Unchecked_Conversion + (Parameterless_Handler, SI.Parameterless_Handler); + + function To_Ada is new Ada.Unchecked_Conversion + (SI.Parameterless_Handler, Parameterless_Handler); + + -------------------- + -- Attach_Handler -- + -------------------- + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID) + is + begin + SI.Attach_Handler + (To_System (New_Handler), SI.Interrupt_ID (Interrupt), False); + end Attach_Handler; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler + is + begin + return To_Ada (SI.Current_Handler (SI.Interrupt_ID (Interrupt))); + end Current_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + procedure Detach_Handler (Interrupt : Interrupt_ID) is + begin + SI.Detach_Handler (SI.Interrupt_ID (Interrupt), False); + end Detach_Handler; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID) + is + H : SI.Parameterless_Handler; + + begin + SI.Exchange_Handler + (H, To_System (New_Handler), + SI.Interrupt_ID (Interrupt), False); + Old_Handler := To_Ada (H); + end Exchange_Handler; + + ------------- + -- Get_CPU -- + ------------- + + function Get_CPU + (Interrupt : Interrupt_ID) return System.Multiprocessors.CPU_Range + is + pragma Unreferenced (Interrupt); + + begin + -- The underlying operating system does not indicate the processor on + -- which the handler for Interrupt is executed. + + return System.Multiprocessors.Not_A_Specific_CPU; + end Get_CPU; + + ----------------- + -- Is_Attached -- + ----------------- + + function Is_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + return SI.Is_Handler_Attached (SI.Interrupt_ID (Interrupt)); + end Is_Attached; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + begin + return SI.Is_Reserved (SI.Interrupt_ID (Interrupt)); + end Is_Reserved; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + begin + return SI.Reference (SI.Interrupt_ID (Interrupt)); + end Reference; + +end Ada.Interrupts; diff --git a/gcc/ada/libgnarl/a-interr.ads b/gcc/ada/libgnarl/a-interr.ads new file mode 100644 index 00000000000..b435f7c3e21 --- /dev/null +++ b/gcc/ada/libgnarl/a-interr.ads @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Interrupts; +with System.Multiprocessors; +with Ada.Task_Identification; + +package Ada.Interrupts is + + type Interrupt_ID is new System.Interrupts.Ada_Interrupt_ID; + + type Parameterless_Handler is access protected procedure; + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean with + SPARK_Mode, + Volatile_Function, + Global => Ada.Task_Identification.Tasking_State; + + function Is_Attached (Interrupt : Interrupt_ID) return Boolean with + SPARK_Mode, + Volatile_Function, + Global => Ada.Task_Identification.Tasking_State; + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler + with + SPARK_Mode => Off, + Global => null; + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID) + with + SPARK_Mode => Off, + Global => null; + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID) + with + SPARK_Mode => Off, + Global => null; + + procedure Detach_Handler (Interrupt : Interrupt_ID) with + SPARK_Mode, + Global => (In_Out => Ada.Task_Identification.Tasking_State); + + function Reference (Interrupt : Interrupt_ID) return System.Address with + SPARK_Mode => Off, + Global => null; + + function Get_CPU + (Interrupt : Interrupt_ID) return System.Multiprocessors.CPU_Range + with + SPARK_Mode, + Volatile_Function, + Global => Ada.Task_Identification.Tasking_State; + +private + pragma Inline (Is_Reserved); + pragma Inline (Is_Attached); + pragma Inline (Current_Handler); + pragma Inline (Attach_Handler); + pragma Inline (Detach_Handler); + pragma Inline (Exchange_Handler); + pragma Inline (Get_CPU); +end Ada.Interrupts; 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-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-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-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-intnam.ads b/gcc/ada/libgnarl/a-intnam.ads new file mode 100644 index 00000000000..399f43b697f --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME 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) 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- 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-reatim.adb b/gcc/ada/libgnarl/a-reatim.adb new file mode 100644 index 00000000000..a304fec93f3 --- /dev/null +++ b/gcc/ada/libgnarl/a-reatim.adb @@ -0,0 +1,390 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Tasking; +with Unchecked_Conversion; + +package body Ada.Real_Time with + SPARK_Mode => Off +is + + --------- + -- "*" -- + --------- + + -- Note that Constraint_Error may be propagated + + function "*" (Left : Time_Span; Right : Integer) return Time_Span is + pragma Unsuppress (Overflow_Check); + begin + return Time_Span (Duration (Left) * Right); + end "*"; + + function "*" (Left : Integer; Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); + begin + return Time_Span (Left * Duration (Right)); + end "*"; + + --------- + -- "+" -- + --------- + + -- Note that Constraint_Error may be propagated + + function "+" (Left : Time; Right : Time_Span) return Time is + pragma Unsuppress (Overflow_Check); + begin + return Time (Duration (Left) + Duration (Right)); + end "+"; + + function "+" (Left : Time_Span; Right : Time) return Time is + pragma Unsuppress (Overflow_Check); + begin + return Time (Duration (Left) + Duration (Right)); + end "+"; + + function "+" (Left, Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); + begin + return Time_Span (Duration (Left) + Duration (Right)); + end "+"; + + --------- + -- "-" -- + --------- + + -- Note that Constraint_Error may be propagated + + function "-" (Left : Time; Right : Time_Span) return Time is + pragma Unsuppress (Overflow_Check); + begin + return Time (Duration (Left) - Duration (Right)); + end "-"; + + function "-" (Left, Right : Time) return Time_Span is + pragma Unsuppress (Overflow_Check); + begin + return Time_Span (Duration (Left) - Duration (Right)); + end "-"; + + function "-" (Left, Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); + begin + return Time_Span (Duration (Left) - Duration (Right)); + end "-"; + + function "-" (Right : Time_Span) return Time_Span is + pragma Unsuppress (Overflow_Check); + begin + return Time_Span_Zero - Right; + end "-"; + + --------- + -- "/" -- + --------- + + -- Note that Constraint_Error may be propagated + + function "/" (Left, Right : Time_Span) return Integer is + pragma Unsuppress (Overflow_Check); + pragma Unsuppress (Division_Check); + + -- RM D.8 (27) specifies the effects of operators on Time_Span, and + -- rounding of the division operator in particular, to be the same as + -- effects on integer types. To get the correct rounding we first + -- convert Time_Span to its root type Duration, which is represented as + -- a 64-bit signed integer, and then use integer division. + + type Duration_Rep is range -(2 ** 63) .. +((2 ** 63 - 1)); + + function To_Integer is + new Unchecked_Conversion (Duration, Duration_Rep); + begin + return Integer + (To_Integer (Duration (Left)) / To_Integer (Duration (Right))); + end "/"; + + function "/" (Left : Time_Span; Right : Integer) return Time_Span is + pragma Unsuppress (Overflow_Check); + pragma Unsuppress (Division_Check); + begin + -- Even though checks are unsuppressed, we need an explicit check for + -- the case of largest negative integer divided by minus one, since + -- some library routines we use fail to catch this case. This will be + -- fixed at the compiler level in the future, at which point this test + -- can be removed. + + if Left = Time_Span_First and then Right = -1 then + raise Constraint_Error with "overflow"; + end if; + + return Time_Span (Duration (Left) / Right); + end "/"; + + ----------- + -- Clock -- + ----------- + + function Clock return Time is + begin + return Time (System.Task_Primitives.Operations.Monotonic_Clock); + end Clock; + + ------------------ + -- Microseconds -- + ------------------ + + function Microseconds (US : Integer) return Time_Span is + begin + return Time_Span_Unit * US * 1_000; + end Microseconds; + + ------------------ + -- Milliseconds -- + ------------------ + + function Milliseconds (MS : Integer) return Time_Span is + begin + return Time_Span_Unit * MS * 1_000_000; + end Milliseconds; + + ------------- + -- Minutes -- + ------------- + + function Minutes (M : Integer) return Time_Span is + begin + return Milliseconds (M) * Integer'(60_000); + end Minutes; + + ----------------- + -- Nanoseconds -- + ----------------- + + function Nanoseconds (NS : Integer) return Time_Span is + begin + return Time_Span_Unit * NS; + end Nanoseconds; + + ------------- + -- Seconds -- + ------------- + + function Seconds (S : Integer) return Time_Span is + begin + return Milliseconds (S) * Integer'(1000); + end Seconds; + + ----------- + -- Split -- + ----------- + + procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is + T_Val : Time; + + begin + -- Special-case for Time_First, whose absolute value is anomalous, + -- courtesy of two's complement. + + T_Val := (if T = Time_First then abs (Time_Last) else abs (T)); + + -- Extract the integer part of T, truncating towards zero + + SC := + (if T_Val < 0.5 then 0 else Seconds_Count (Time_Span'(T_Val - 0.5))); + + if T < 0.0 then + SC := -SC; + end if; + + -- If original time is negative, need to truncate towards negative + -- infinity, to make TS non-negative, as per ARM. + + if Time (SC) > T then + SC := SC - 1; + end if; + + TS := Time_Span (Duration (T) - Duration (SC)); + end Split; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + -- We do all our own checks for this function + + -- This is not such a simple case, since TS is already 64 bits, and + -- so we can't just promote everything to a wider type to ensure proper + -- testing for overflow. The situation is that Seconds_Count is a MUCH + -- wider type than Time_Span and Time (both of which have the underlying + -- type Duration). + + -- <------------------- Seconds_Count --------------------> + -- <-- Duration --> + + -- Now it is possible for an SC value outside the Duration range to + -- be "brought back into range" by an appropriate TS value, but there + -- are also clearly SC values that are completely out of range. Note + -- that the above diagram is wildly out of scale, the difference in + -- ranges is much greater than shown. + + -- We can't just go generating out of range Duration values to test for + -- overflow, since Duration is a full range type, so we follow the steps + -- shown below. + + SC_Lo : constant Seconds_Count := + Seconds_Count (Duration (Time_Span_First) + Duration'(0.5)); + SC_Hi : constant Seconds_Count := + Seconds_Count (Duration (Time_Span_Last) - Duration'(0.5)); + -- These are the maximum values of the seconds (integer) part of the + -- Duration range. Used to compute and check the seconds in the result. + + TS_SC : Seconds_Count; + -- Seconds part of input value + + TS_Fraction : Duration; + -- Fractional part of input value, may be negative + + Result_SC : Seconds_Count; + -- Seconds value for result + + Fudge : constant Seconds_Count := 10; + -- Fudge value used to do end point checks far from end point + + FudgeD : constant Duration := Duration (Fudge); + -- Fudge value as Duration + + Fudged_Result : Duration; + -- Result fudged up or down by FudgeD + + procedure Out_Of_Range; + pragma No_Return (Out_Of_Range); + -- Raise exception for result out of range + + ------------------ + -- Out_Of_Range -- + ------------------ + + procedure Out_Of_Range is + begin + raise Constraint_Error with + "result for Ada.Real_Time.Time_Of is out of range"; + end Out_Of_Range; + + -- Start of processing for Time_Of + + begin + -- If SC is so far out of range that there is no possibility of the + -- addition of TS getting it back in range, raise an exception right + -- away. That way we don't have to worry about SC values overflowing. + + if SC < 3 * SC_Lo or else SC > 3 * SC_Hi then + Out_Of_Range; + end if; + + -- Decompose input TS value + + TS_SC := Seconds_Count (Duration (TS)); + TS_Fraction := Duration (TS) - Duration (TS_SC); + + -- Compute result seconds. If clearly out of range, raise error now + + Result_SC := SC + TS_SC; + + if Result_SC < (SC_Lo - 1) or else Result_SC > (SC_Hi + 1) then + Out_Of_Range; + end if; + + -- Now the result is simply Result_SC + TS_Fraction, but we can't just + -- go computing that since it might be out of range. So what we do is + -- to compute a value fudged down or up by 10.0 (arbitrary value, but + -- that will do fine), and check that fudged value, and if in range + -- unfudge it and return the result. + + -- Fudge positive result down, and check high bound + + if Result_SC > 0 then + Fudged_Result := Duration (Result_SC - Fudge) + TS_Fraction; + + if Fudged_Result <= Duration'Last - FudgeD then + return Time (Fudged_Result + FudgeD); + else + Out_Of_Range; + end if; + + -- Same for negative values of seconds, fudge up and check low bound + + else + Fudged_Result := Duration (Result_SC + Fudge) + TS_Fraction; + + if Fudged_Result >= Duration'First + FudgeD then + return Time (Fudged_Result - FudgeD); + else + Out_Of_Range; + end if; + end if; + end Time_Of; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : Time_Span) return Duration is + begin + return Duration (TS); + end To_Duration; + + ------------------ + -- To_Time_Span -- + ------------------ + + function To_Time_Span (D : Duration) return Time_Span is + begin + -- Note regarding AI-00432 requiring range checking on this conversion. + -- In almost all versions of GNAT (and all to which this version of the + -- Ada.Real_Time package apply), the range of Time_Span and Duration are + -- the same, so there is no issue of overflow. + + return Time_Span (D); + end To_Time_Span; + +begin + -- Ensure that the tasking run time is initialized when using clock and/or + -- delay operations. The initialization routine has the required machinery + -- to prevent multiple calls to Initialize. + + System.Tasking.Initialize; +end Ada.Real_Time; diff --git a/gcc/ada/libgnarl/a-reatim.ads b/gcc/ada/libgnarl/a-reatim.ads new file mode 100644 index 00000000000..2fa79631564 --- /dev/null +++ b/gcc/ada/libgnarl/a-reatim.ads @@ -0,0 +1,187 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Primitives.Operations; +pragma Elaborate_All (System.Task_Primitives.Operations); + +package Ada.Real_Time with + SPARK_Mode, + Abstract_State => (Clock_Time with Synchronous, + External => (Async_Readers, + Async_Writers)), + Initializes => Clock_Time +is + + pragma Compile_Time_Error + (Duration'Size /= 64, + "this version of Ada.Real_Time requires 64-bit Duration"); + + type Time is private; + Time_First : constant Time; + Time_Last : constant Time; + Time_Unit : constant := 10#1.0#E-9; + + type Time_Span is private; + Time_Span_First : constant Time_Span; + Time_Span_Last : constant Time_Span; + Time_Span_Zero : constant Time_Span; + Time_Span_Unit : constant Time_Span; + + Tick : constant Time_Span; + function Clock return Time with + Volatile_Function, + Global => Clock_Time; + + function "+" (Left : Time; Right : Time_Span) return Time with + Global => null; + function "+" (Left : Time_Span; Right : Time) return Time with + Global => null; + function "-" (Left : Time; Right : Time_Span) return Time with + Global => null; + function "-" (Left : Time; Right : Time) return Time_Span with + Global => null; + + function "<" (Left, Right : Time) return Boolean with + Global => null; + function "<=" (Left, Right : Time) return Boolean with + Global => null; + function ">" (Left, Right : Time) return Boolean with + Global => null; + function ">=" (Left, Right : Time) return Boolean with + Global => null; + + function "+" (Left, Right : Time_Span) return Time_Span with + Global => null; + function "-" (Left, Right : Time_Span) return Time_Span with + Global => null; + function "-" (Right : Time_Span) return Time_Span with + Global => null; + function "*" (Left : Time_Span; Right : Integer) return Time_Span with + Global => null; + function "*" (Left : Integer; Right : Time_Span) return Time_Span with + Global => null; + function "/" (Left, Right : Time_Span) return Integer with + Global => null; + function "/" (Left : Time_Span; Right : Integer) return Time_Span with + Global => null; + + function "abs" (Right : Time_Span) return Time_Span with + Global => null; + + function "<" (Left, Right : Time_Span) return Boolean with + Global => null; + function "<=" (Left, Right : Time_Span) return Boolean with + Global => null; + function ">" (Left, Right : Time_Span) return Boolean with + Global => null; + function ">=" (Left, Right : Time_Span) return Boolean with + Global => null; + + function To_Duration (TS : Time_Span) return Duration with + Global => null; + function To_Time_Span (D : Duration) return Time_Span with + Global => null; + + function Nanoseconds (NS : Integer) return Time_Span with + Global => null; + function Microseconds (US : Integer) return Time_Span with + Global => null; + function Milliseconds (MS : Integer) return Time_Span with + Global => null; + + function Seconds (S : Integer) return Time_Span with + Global => null; + pragma Ada_05 (Seconds); + + function Minutes (M : Integer) return Time_Span with + Global => null; + pragma Ada_05 (Minutes); + + type Seconds_Count is new Long_Long_Integer; + -- Seconds_Count needs 64 bits, since the type Time has the full range of + -- Duration. The delta of Duration is 10 ** (-9), so the maximum number of + -- seconds is 2**63/10**9 = 8*10**9 which does not quite fit in 32 bits. + -- However, rather than make this explicitly 64-bits we derive from + -- Long_Long_Integer. In normal usage this will have the same effect. But + -- in the case of CodePeer with a target configuration file with a maximum + -- integer size of 32, it allows analysis of this unit. + + procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) + with + Global => null; + function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time + with + Global => null; + +private + pragma SPARK_Mode (Off); + + -- Time and Time_Span are represented in 64-bit Duration value in + -- nanoseconds. For example, 1 second and 1 nanosecond is represented + -- as the stored integer 1_000_000_001. This is for the 64-bit Duration + -- case, not clear if this also is used for 32-bit Duration values. + + type Time is new Duration; + + Time_First : constant Time := Time'First; + + Time_Last : constant Time := Time'Last; + + type Time_Span is new Duration; + + Time_Span_First : constant Time_Span := Time_Span'First; + + Time_Span_Last : constant Time_Span := Time_Span'Last; + + Time_Span_Zero : constant Time_Span := 0.0; + + Time_Span_Unit : constant Time_Span := 10#1.0#E-9; + + Tick : constant Time_Span := + Time_Span (System.Task_Primitives.Operations.RT_Resolution); + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "abs"); + + pragma Inline (Microseconds); + pragma Inline (Milliseconds); + pragma Inline (Nanoseconds); + pragma Inline (Seconds); + pragma Inline (Minutes); + +end Ada.Real_Time; diff --git a/gcc/ada/libgnarl/a-retide.adb b/gcc/ada/libgnarl/a-retide.adb new file mode 100644 index 00000000000..22443fba281 --- /dev/null +++ b/gcc/ada/libgnarl/a-retide.adb @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E . D E L A Y 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; + +with System.Tasking; +with System.Task_Primitives.Operations; + +package body Ada.Real_Time.Delays is + + package STPO renames System.Task_Primitives.Operations; + + ---------------- + -- Local Data -- + ---------------- + + Absolute_RT : constant := 2; + + ----------------- + -- Delay_Until -- + ----------------- + + procedure Delay_Until (T : Time) is + Self_Id : constant System.Tasking.Task_Id := STPO.Self; + + begin + -- If pragma Detect_Blocking is active, Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + else + STPO.Timed_Delay (Self_Id, To_Duration (T), Absolute_RT); + end if; + end Delay_Until; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (T : Time) return Duration is + begin + return To_Duration (Time_Span (T)); + end To_Duration; + +end Ada.Real_Time.Delays; diff --git a/gcc/ada/libgnarl/a-retide.ads b/gcc/ada/libgnarl/a-retide.ads new file mode 100644 index 00000000000..31dc892bacd --- /dev/null +++ b/gcc/ada/libgnarl/a-retide.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E . D E L A Y 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Implements Real_Time.Time absolute delays + +-- Note: the compiler generates direct calls to this interface, in the +-- processing of time types. + +package Ada.Real_Time.Delays is + + function To_Duration (T : Real_Time.Time) return Duration; + -- Convert Time to Duration + + procedure Delay_Until (T : Time); + -- Delay until Clock has reached (at least) time T, + -- or the task is aborted to at least the current ATC nesting level. + -- The body of this procedure must perform all the processing + -- required for an abort point. + +end Ada.Real_Time.Delays; diff --git a/gcc/ada/libgnarl/a-rttiev.adb b/gcc/ada/libgnarl/a-rttiev.adb new file mode 100644 index 00000000000..64d59f041cb --- /dev/null +++ b/gcc/ada/libgnarl/a-rttiev.adb @@ -0,0 +1,367 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E . T I M I N G _ E V E N T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2005-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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Primitives.Operations; +with System.Tasking.Utilities; +with System.Soft_Links; +with System.Interrupt_Management.Operations; + +with Ada.Containers.Doubly_Linked_Lists; +pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists); + +--------------------------------- +-- Ada.Real_Time.Timing_Events -- +--------------------------------- + +package body Ada.Real_Time.Timing_Events is + + use System.Task_Primitives.Operations; + + package SSL renames System.Soft_Links; + + type Any_Timing_Event is access all Timing_Event'Class; + -- We must also handle user-defined types derived from Timing_Event + + ------------ + -- Events -- + ------------ + + package Events is new Ada.Containers.Doubly_Linked_Lists (Any_Timing_Event); + -- Provides the type for the container holding pointers to events + + All_Events : Events.List; + -- The queue of pending events, ordered by increasing timeout value, that + -- have been "set" by the user via Set_Handler. + + Event_Queue_Lock : aliased System.Task_Primitives.RTS_Lock; + -- Used for mutually exclusive access to All_Events + + -- We need to Initialize_Lock before Timer is activated. The purpose of the + -- Dummy package is to get around Ada's syntax rules. + + package Dummy is end Dummy; + package body Dummy is + begin + Initialize_Lock (Event_Queue_Lock'Access, Level => PO_Level); + end Dummy; + + procedure Process_Queued_Events; + -- Examine the queue of pending events for any that have timed out. For + -- those that have timed out, remove them from the queue and invoke their + -- handler (unless the user has cancelled the event by setting the handler + -- pointer to null). Mutually exclusive access is held via Event_Queue_Lock + -- during part of the processing. + + procedure Insert_Into_Queue (This : Any_Timing_Event); + -- Insert the specified event pointer into the queue of pending events + -- with mutually exclusive access via Event_Queue_Lock. + + procedure Remove_From_Queue (This : Any_Timing_Event); + -- Remove the specified event pointer from the queue of pending events with + -- mutually exclusive access via Event_Queue_Lock. This procedure is used + -- by the client-side routines (Set_Handler, etc.). + + ----------- + -- Timer -- + ----------- + + task Timer is + pragma Priority (System.Priority'Last); + end Timer; + + task body Timer is + Period : constant Time_Span := Milliseconds (100); + -- This is a "chiming" clock timer that fires periodically. The period + -- selected is arbitrary and could be changed to suit the application + -- requirements. Obviously a shorter period would give better resolution + -- at the cost of more overhead. + + Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; + pragma Unreferenced (Ignore); + + begin + -- Since this package may be elaborated before System.Interrupt, + -- we need to call Setup_Interrupt_Mask explicitly to ensure that + -- this task has the proper signal mask. + + System.Interrupt_Management.Operations.Setup_Interrupt_Mask; + + loop + Process_Queued_Events; + delay until Clock + Period; + end loop; + end Timer; + + --------------------------- + -- Process_Queued_Events -- + --------------------------- + + procedure Process_Queued_Events is + Next_Event : Any_Timing_Event; + + begin + loop + SSL.Abort_Defer.all; + + Write_Lock (Event_Queue_Lock'Access); + + if All_Events.Is_Empty then + Unlock (Event_Queue_Lock'Access); + SSL.Abort_Undefer.all; + return; + else + Next_Event := All_Events.First_Element; + end if; + + if Next_Event.Timeout > Clock then + + -- We found one that has not yet timed out. The queue is in + -- ascending order by Timeout so there is no need to continue + -- processing (and indeed we must not continue since we always + -- delete the first element). + + Unlock (Event_Queue_Lock'Access); + SSL.Abort_Undefer.all; + return; + end if; + + -- We have an event that has timed out so we will process it. It must + -- be the first in the queue so no search is needed. + + All_Events.Delete_First; + + -- A fundamental issue is that the invocation of the event's handler + -- might call Set_Handler on itself to re-insert itself back into the + -- queue of future events. Thus we cannot hold the lock on the queue + -- while invoking the event's handler. + + Unlock (Event_Queue_Lock'Access); + + SSL.Abort_Undefer.all; + + -- There is no race condition with the user changing the handler + -- pointer while we are processing because we are executing at the + -- highest possible application task priority and are not doing + -- anything to block prior to invoking their handler. + + declare + Handler : constant Timing_Event_Handler := Next_Event.Handler; + + begin + -- The first act is to clear the event, per D.15(13/2). Besides, + -- we cannot clear the handler pointer *after* invoking the + -- handler because the handler may have re-inserted the event via + -- Set_Event. Thus we take a copy and then clear the component. + + Next_Event.Handler := null; + + if Handler /= null then + Handler.all (Timing_Event (Next_Event.all)); + end if; + + -- Ignore exceptions propagated by Handler.all, as required by + -- RM D.15(21/2). + + exception + when others => + null; + end; + end loop; + end Process_Queued_Events; + + ----------------------- + -- Insert_Into_Queue -- + ----------------------- + + procedure Insert_Into_Queue (This : Any_Timing_Event) is + + function Sooner (Left, Right : Any_Timing_Event) return Boolean; + -- Compares events in terms of timeout values + + package By_Timeout is new Events.Generic_Sorting (Sooner); + -- Used to keep the events in ascending order by timeout value + + ------------ + -- Sooner -- + ------------ + + function Sooner (Left, Right : Any_Timing_Event) return Boolean is + begin + return Left.Timeout < Right.Timeout; + end Sooner; + + -- Start of processing for Insert_Into_Queue + + begin + SSL.Abort_Defer.all; + + Write_Lock (Event_Queue_Lock'Access); + + All_Events.Append (This); + + -- A critical property of the implementation of this package is that + -- all occurrences are in ascending order by Timeout. Thus the first + -- event in the queue always has the "next" value for the Timer task + -- to use in its delay statement. + + By_Timeout.Sort (All_Events); + + Unlock (Event_Queue_Lock'Access); + + SSL.Abort_Undefer.all; + end Insert_Into_Queue; + + ----------------------- + -- Remove_From_Queue -- + ----------------------- + + procedure Remove_From_Queue (This : Any_Timing_Event) is + use Events; + Location : Cursor; + + begin + SSL.Abort_Defer.all; + + Write_Lock (Event_Queue_Lock'Access); + + Location := All_Events.Find (This); + + if Location /= No_Element then + All_Events.Delete (Location); + end if; + + Unlock (Event_Queue_Lock'Access); + + SSL.Abort_Undefer.all; + end Remove_From_Queue; + + ----------------- + -- Set_Handler -- + ----------------- + + procedure Set_Handler + (Event : in out Timing_Event; + At_Time : Time; + Handler : Timing_Event_Handler) + is + begin + Remove_From_Queue (Event'Unchecked_Access); + Event.Handler := null; + + -- RM D.15(15/2) required that at this point, we check whether the time + -- has already passed, and if so, call Handler.all directly from here + -- instead of doing the enqueuing below. However, this caused a nasty + -- race condition and potential deadlock. If the current task has + -- already locked the protected object of Handler.all, and the time has + -- passed, deadlock would occur. It has been fixed by AI05-0094-1, which + -- says that the handler should be executed as soon as possible, meaning + -- that the timing event will be executed after the protected action + -- finishes (Handler.all should not be called directly from here). + -- The same comment applies to the other Set_Handler below. + + if Handler /= null then + Event.Timeout := At_Time; + Event.Handler := Handler; + Insert_Into_Queue (Event'Unchecked_Access); + end if; + end Set_Handler; + + ----------------- + -- Set_Handler -- + ----------------- + + procedure Set_Handler + (Event : in out Timing_Event; + In_Time : Time_Span; + Handler : Timing_Event_Handler) + is + begin + Remove_From_Queue (Event'Unchecked_Access); + Event.Handler := null; + + -- See comment in the other Set_Handler above + + if Handler /= null then + Event.Timeout := Clock + In_Time; + Event.Handler := Handler; + Insert_Into_Queue (Event'Unchecked_Access); + end if; + end Set_Handler; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Event : Timing_Event) return Timing_Event_Handler + is + begin + return Event.Handler; + end Current_Handler; + + -------------------- + -- Cancel_Handler -- + -------------------- + + procedure Cancel_Handler + (Event : in out Timing_Event; + Cancelled : out Boolean) + is + begin + Remove_From_Queue (Event'Unchecked_Access); + Cancelled := Event.Handler /= null; + Event.Handler := null; + end Cancel_Handler; + + ------------------- + -- Time_Of_Event -- + ------------------- + + function Time_Of_Event (Event : Timing_Event) return Time is + begin + -- RM D.15(18/2): Time_First must be returned in the event is not set + + return (if Event.Handler = null then Time_First else Event.Timeout); + end Time_Of_Event; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (This : in out Timing_Event) is + begin + -- D.15 (19/2) says finalization clears the event + + This.Handler := null; + Remove_From_Queue (This'Unchecked_Access); + end Finalize; + +end Ada.Real_Time.Timing_Events; diff --git a/gcc/ada/libgnarl/a-rttiev.ads b/gcc/ada/libgnarl/a-rttiev.ads new file mode 100644 index 00000000000..c44f88e3249 --- /dev/null +++ b/gcc/ada/libgnarl/a-rttiev.ads @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . R E A L _ T I M E . T I M I N G _ E V E N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005-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.Finalization; + +package Ada.Real_Time.Timing_Events is + + type Timing_Event is tagged limited private; + + type Timing_Event_Handler + is access protected procedure (Event : in out Timing_Event); + + procedure Set_Handler + (Event : in out Timing_Event; + At_Time : Time; + Handler : Timing_Event_Handler); + + procedure Set_Handler + (Event : in out Timing_Event; + In_Time : Time_Span; + Handler : Timing_Event_Handler); + + function Current_Handler + (Event : Timing_Event) return Timing_Event_Handler; + + procedure Cancel_Handler + (Event : in out Timing_Event; + Cancelled : out Boolean); + + function Time_Of_Event (Event : Timing_Event) return Time; + +private + + type Timing_Event is new Ada.Finalization.Limited_Controlled with record + Timeout : Time := Time_First; + -- The time at which the user's handler should be invoked when the + -- event is "set" (i.e., when Handler is not null). + + Handler : Timing_Event_Handler; + -- An access value designating the protected procedure to be invoked + -- at the Timeout time in the future. When this value is null the event + -- is said to be "cleared" and no timeout is processed. + end record; + + overriding procedure Finalize (This : in out Timing_Event); + -- Finalization procedure is required to satisfy (RM D.15 (19/2)), which + -- says that the object must be cleared on finalization. + +end Ada.Real_Time.Timing_Events; diff --git a/gcc/ada/libgnarl/a-stcoed.ads b/gcc/ada/libgnarl/a-stcoed.ads new file mode 100644 index 00000000000..0d39cc3d762 --- /dev/null +++ b/gcc/ada/libgnarl/a-stcoed.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L . E D F -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. + +-- If a target environment provides appropriate support for this package, +-- then the Unimplemented_Unit pragma should be removed from this spec and +-- an appropriate body provided. + +package Ada.Synchronous_Task_Control.EDF is + + pragma Unimplemented_Unit; + + procedure Suspend_Until_True_And_Set_Deadline + (S : in out Suspension_Object; + TS : Ada.Real_Time.Time_Span); +end Ada.Synchronous_Task_Control.EDF; 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/a-synbar.adb b/gcc/ada/libgnarl/a-synbar.adb new file mode 100644 index 00000000000..dd79626b362 --- /dev/null +++ b/gcc/ada/libgnarl/a-synbar.adb @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Synchronous_Barriers is + + protected body Synchronous_Barrier is + + -- The condition "Wait'Count = Release_Threshold" opens the barrier when + -- the required number of tasks is reached. The condition "Keep_Open" + -- leaves the barrier open while there are queued tasks. While there are + -- tasks in the queue no new task will be queued (no new protected + -- action can be started on a protected object while another protected + -- action on the same protected object is underway, RM 9.5.1 (4)), + -- guaranteeing that the barrier will remain open only for those tasks + -- already inside the queue when the barrier was open. + + entry Wait (Notified : out Boolean) + when Keep_Open or else Wait'Count = Release_Threshold + is + begin + -- If we are executing the entry it means that the required number of + -- tasks have been queued in the entry. Keep_Open barrier will remain + -- true until all queued tasks are out. + + Keep_Open := Wait'Count > 0; + + -- The last released task will close the barrier and get the Notified + -- token. + + Notified := Wait'Count = 0; + end Wait; + end Synchronous_Barrier; + + ---------------------- + -- Wait_For_Release -- + ---------------------- + + procedure Wait_For_Release + (The_Barrier : in out Synchronous_Barrier; + Notified : out Boolean) + is + begin + The_Barrier.Wait (Notified); + end Wait_For_Release; + +end Ada.Synchronous_Barriers; diff --git a/gcc/ada/libgnarl/a-synbar.ads b/gcc/ada/libgnarl/a-synbar.ads new file mode 100644 index 00000000000..07f3c5673d8 --- /dev/null +++ b/gcc/ada/libgnarl/a-synbar.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +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 + protected type Synchronous_Barrier (Release_Threshold : Barrier_Limit) is + entry Wait (Notified : out Boolean); + private + Keep_Open : Boolean := False; + end Synchronous_Barrier; +end Ada.Synchronous_Barriers; diff --git a/gcc/ada/libgnarl/a-sytaco.adb b/gcc/ada/libgnarl/a-sytaco.adb new file mode 100644 index 00000000000..bb372b79fa5 --- /dev/null +++ b/gcc/ada/libgnarl/a-sytaco.adb @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; + +with System.Tasking; +with System.Task_Primitives.Operations; + +package body Ada.Synchronous_Task_Control with + SPARK_Mode => Off +is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + begin + System.Task_Primitives.Operations.Initialize (S.SO); + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + begin + System.Task_Primitives.Operations.Finalize (S.SO); + end Finalize; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + return System.Task_Primitives.Operations.Current_State (S.SO); + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + begin + System.Task_Primitives.Operations.Set_False (S.SO); + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + begin + System.Task_Primitives.Operations.Set_True (S.SO); + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + begin + -- This is a potentially blocking (see ARM D.10, par. 10), so that + -- if pragma Detect_Blocking is active then Program_Error must be + -- raised if this operation is called from a protected action. + + if System.Tasking.Detect_Blocking + and then System.Tasking.Self.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + end if; + + System.Task_Primitives.Operations.Suspend_Until_True (S.SO); + end Suspend_Until_True; + +end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/libgnarl/a-sytaco.ads b/gcc/ada/libgnarl/a-sytaco.ads new file mode 100644 index 00000000000..f1d09b34263 --- /dev/null +++ b/gcc/ada/libgnarl/a-sytaco.ads @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Primitives; + +with Ada.Finalization; +with Ada.Task_Identification; + +package Ada.Synchronous_Task_Control with + SPARK_Mode +is + pragma Preelaborate; + -- In accordance with Ada 2005 AI-362 + + type Suspension_Object is limited private with + Default_Initial_Condition; + + procedure Set_True (S : in out Suspension_Object) with + Global => null, + Depends => (S => null, + null => S); + + procedure Set_False (S : in out Suspension_Object) with + Global => null, + Depends => (S => null, + null => S); + + function Current_State (S : Suspension_Object) return Boolean with + Volatile_Function, + Global => Ada.Task_Identification.Tasking_State; + + procedure Suspend_Until_True (S : in out Suspension_Object) with + Global => null, + Depends => (S => null, + null => S); + +private + pragma SPARK_Mode (Off); + + procedure Initialize (S : in out Suspension_Object); + -- Initialization for Suspension_Object + + procedure Finalize (S : in out Suspension_Object); + -- Finalization for Suspension_Object + + type Suspension_Object is + new Ada.Finalization.Limited_Controlled with + record + SO : System.Task_Primitives.Suspension_Object; + -- Use low-level suspension objects so that the synchronization + -- functionality provided by this object can be achieved using + -- efficient operating system primitives. + end record; + + pragma Inline (Set_True); + pragma Inline (Set_False); + pragma Inline (Current_State); + pragma Inline (Suspend_Until_True); + pragma Inline (Initialize); + pragma Inline (Finalize); + +end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/libgnarl/a-tasatt.adb b/gcc/ada/libgnarl/a-tasatt.adb new file mode 100644 index 00000000000..5d798b30b0d --- /dev/null +++ b/gcc/ada/libgnarl/a-tasatt.adb @@ -0,0 +1,380 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A S K _ A T T R I B U T E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2014-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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Tasking; +with System.Tasking.Initialization; +with System.Tasking.Task_Attributes; +pragma Elaborate_All (System.Tasking.Task_Attributes); + +with System.Task_Primitives.Operations; + +with Ada.Finalization; use Ada.Finalization; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +package body Ada.Task_Attributes is + + use System, + System.Tasking.Initialization, + System.Tasking, + System.Tasking.Task_Attributes; + + package STPO renames System.Task_Primitives.Operations; + + type Attribute_Cleanup is new Limited_Controlled with null record; + procedure Finalize (Cleanup : in out Attribute_Cleanup); + -- Finalize all tasks' attributes for this package + + Cleanup : Attribute_Cleanup; + pragma Unreferenced (Cleanup); + -- Will call Finalize when this instantiation gets out of scope + + --------------------------- + -- Unchecked Conversions -- + --------------------------- + + type Real_Attribute is record + Free : Deallocator; + Value : Attribute; + end record; + type Real_Attribute_Access is access all Real_Attribute; + pragma No_Strict_Aliasing (Real_Attribute_Access); + -- Each value in the task control block's Attributes array is either + -- mapped to the attribute value directly if Fast_Path is True, or + -- is in effect a Real_Attribute_Access. + -- + -- Note: the Deallocator field must be first, for compatibility with + -- System.Tasking.Task_Attributes.Attribute_Record and to allow unchecked + -- conversions between Attribute_Access and Real_Attribute_Access. + + function New_Attribute (Val : Attribute) return Atomic_Address; + -- Create a new Real_Attribute using Val, and return its address. The + -- returned value can be converted via To_Real_Attribute. + + procedure Deallocate (Ptr : Atomic_Address); + -- Free memory associated with Ptr, a Real_Attribute_Access in reality + + function To_Real_Attribute is new + Ada.Unchecked_Conversion (Atomic_Address, Real_Attribute_Access); + + pragma Warnings (Off); + -- Kill warning about possible size mismatch + + function To_Address is new + Ada.Unchecked_Conversion (Attribute, Atomic_Address); + function To_Attribute is new + Ada.Unchecked_Conversion (Atomic_Address, Attribute); + + type Unsigned is mod 2 ** Integer'Size; + function To_Address is new + Ada.Unchecked_Conversion (Attribute, System.Address); + function To_Unsigned is new + Ada.Unchecked_Conversion (Attribute, Unsigned); + + pragma Warnings (On); + + function To_Address is new + Ada.Unchecked_Conversion (Real_Attribute_Access, Atomic_Address); + + pragma Warnings (Off); + -- Kill warning about possible aliasing + + function To_Handle is new + Ada.Unchecked_Conversion (System.Address, Attribute_Handle); + + pragma Warnings (On); + + function To_Task_Id is new + Ada.Unchecked_Conversion (Task_Identification.Task_Id, Task_Id); + -- To access TCB of identified task + + procedure Free is new + Ada.Unchecked_Deallocation (Real_Attribute, Real_Attribute_Access); + + Fast_Path : constant Boolean := + (Attribute'Size = Integer'Size + and then Attribute'Alignment <= Atomic_Address'Alignment + and then To_Unsigned (Initial_Value) = 0) + or else (Attribute'Size = System.Address'Size + and then Attribute'Alignment <= Atomic_Address'Alignment + and then To_Address (Initial_Value) = System.Null_Address); + -- If the attribute fits in an Atomic_Address (both size and alignment) + -- and Initial_Value is 0 (or null), then we will map the attribute + -- directly into ATCB.Attributes (Index), otherwise we will create + -- a level of indirection and instead use Attributes (Index) as a + -- Real_Attribute_Access. + + Index : constant Integer := + Next_Index (Require_Finalization => not Fast_Path); + -- Index in the task control block's Attributes array + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Cleanup : in out Attribute_Cleanup) is + pragma Unreferenced (Cleanup); + + begin + STPO.Lock_RTS; + + declare + C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List; + + begin + while C /= null loop + STPO.Write_Lock (C); + + if C.Attributes (Index) /= 0 + and then Require_Finalization (Index) + then + Deallocate (C.Attributes (Index)); + C.Attributes (Index) := 0; + end if; + + STPO.Unlock (C); + C := C.Common.All_Tasks_Link; + end loop; + end; + + Finalize (Index); + STPO.Unlock_RTS; + end Finalize; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate (Ptr : Atomic_Address) is + Obj : Real_Attribute_Access := To_Real_Attribute (Ptr); + begin + Free (Obj); + end Deallocate; + + ------------------- + -- New_Attribute -- + ------------------- + + function New_Attribute (Val : Attribute) return Atomic_Address is + Tmp : Real_Attribute_Access; + begin + Tmp := new Real_Attribute'(Free => Deallocate'Unrestricted_Access, + Value => Val); + return To_Address (Tmp); + end New_Attribute; + + --------------- + -- Reference -- + --------------- + + function Reference + (T : Task_Identification.Task_Id := Task_Identification.Current_Task) + return Attribute_Handle + is + Self_Id : Task_Id; + TT : constant Task_Id := To_Task_Id (T); + Error_Message : constant String := "trying to get the reference of a "; + Result : Attribute_Handle; + + begin + if TT = null then + raise Program_Error with Error_Message & "null task"; + end if; + + if TT.Common.State = Terminated then + raise Tasking_Error with Error_Message & "terminated task"; + end if; + + if Fast_Path then + -- Kill warning about possible alignment mismatch. If this happens, + -- Fast_Path will be False anyway + pragma Warnings (Off); + return To_Handle (TT.Attributes (Index)'Address); + pragma Warnings (On); + else + Self_Id := STPO.Self; + Task_Lock (Self_Id); + + if TT.Attributes (Index) = 0 then + TT.Attributes (Index) := New_Attribute (Initial_Value); + end if; + + Result := To_Handle + (To_Real_Attribute (TT.Attributes (Index)).Value'Address); + Task_Unlock (Self_Id); + + return Result; + end if; + end Reference; + + ------------------ + -- Reinitialize -- + ------------------ + + procedure Reinitialize + (T : Task_Identification.Task_Id := Task_Identification.Current_Task) + is + Self_Id : Task_Id; + TT : constant Task_Id := To_Task_Id (T); + Error_Message : constant String := "Trying to Reinitialize a "; + + begin + if TT = null then + raise Program_Error with Error_Message & "null task"; + end if; + + if TT.Common.State = Terminated then + raise Tasking_Error with Error_Message & "terminated task"; + end if; + + if Fast_Path then + + -- No finalization needed, simply reset to Initial_Value + + TT.Attributes (Index) := To_Address (Initial_Value); + + else + Self_Id := STPO.Self; + Task_Lock (Self_Id); + + declare + Attr : Atomic_Address renames TT.Attributes (Index); + begin + if Attr /= 0 then + Deallocate (Attr); + Attr := 0; + end if; + end; + + Task_Unlock (Self_Id); + end if; + end Reinitialize; + + --------------- + -- Set_Value -- + --------------- + + procedure Set_Value + (Val : Attribute; + T : Task_Identification.Task_Id := Task_Identification.Current_Task) + is + Self_Id : Task_Id; + TT : constant Task_Id := To_Task_Id (T); + Error_Message : constant String := "trying to set the value of a "; + + begin + if TT = null then + raise Program_Error with Error_Message & "null task"; + end if; + + if TT.Common.State = Terminated then + raise Tasking_Error with Error_Message & "terminated task"; + end if; + + if Fast_Path then + + -- No finalization needed, simply set to Val + + if Attribute'Size = Integer'Size then + TT.Attributes (Index) := Atomic_Address (To_Unsigned (Val)); + else + TT.Attributes (Index) := To_Address (Val); + end if; + + else + Self_Id := STPO.Self; + Task_Lock (Self_Id); + + declare + Attr : Atomic_Address renames TT.Attributes (Index); + + begin + if Attr /= 0 then + Deallocate (Attr); + end if; + + Attr := New_Attribute (Val); + end; + + Task_Unlock (Self_Id); + end if; + end Set_Value; + + ----------- + -- Value -- + ----------- + + function Value + (T : Task_Identification.Task_Id := Task_Identification.Current_Task) + return Attribute + is + Self_Id : Task_Id; + TT : constant Task_Id := To_Task_Id (T); + Error_Message : constant String := "trying to get the value of a "; + + begin + if TT = null then + raise Program_Error with Error_Message & "null task"; + end if; + + if TT.Common.State = Terminated then + raise Tasking_Error with Error_Message & "terminated task"; + end if; + + if Fast_Path then + return To_Attribute (TT.Attributes (Index)); + + else + Self_Id := STPO.Self; + Task_Lock (Self_Id); + + declare + Attr : Atomic_Address renames TT.Attributes (Index); + + begin + if Attr = 0 then + Task_Unlock (Self_Id); + return Initial_Value; + + else + declare + Result : constant Attribute := + To_Real_Attribute (Attr).Value; + begin + Task_Unlock (Self_Id); + return Result; + end; + end if; + end; + end if; + end Value; + +end Ada.Task_Attributes; diff --git a/gcc/ada/libgnarl/a-tasatt.ads b/gcc/ada/libgnarl/a-tasatt.ads new file mode 100644 index 00000000000..b6ba3e825ab --- /dev/null +++ b/gcc/ada/libgnarl/a-tasatt.ads @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A S K _ A T T R I B U T E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2014-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; + +generic + type Attribute is private; + Initial_Value : Attribute; + +package Ada.Task_Attributes is + + -- Note that this package will use an efficient implementation with no + -- locks and no extra dynamic memory allocation if Attribute is the size + -- of either Integer or System.Address, and Initial_Value is 0 (null for + -- an access type). + + -- Other types and initial values are supported, but will require + -- the use of locking and a level of indirection (meaning extra dynamic + -- memory allocation). + + -- The maximum number of task attributes supported by this implementation + -- is determined by the constant System.Parameters.Max_Attribute_Count. + -- If you exceed this number, Storage_Error will be raised during the + -- elaboration of the instantiation of this package. + + type Attribute_Handle is access all Attribute; + + function Value + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return Attribute; + -- Return the value of the corresponding attribute of T. Tasking_Error + -- is raised if T is terminated and Program_Error will be raised if T + -- is Null_Task_Id. + + function Reference + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return Attribute_Handle; + -- Return an access value that designates the corresponding attribute of + -- T. Tasking_Error is raised if T is terminated and Program_Error will be + -- raised if T is Null_Task_Id. + + procedure Set_Value + (Val : Attribute; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + -- Finalize the old value of the attribute of T and assign Val to that + -- attribute. Tasking_Error is raised if T is terminated and Program_Error + -- will be raised if T is Null_Task_Id. + + procedure Reinitialize + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + -- Same as Set_Value (Initial_Value, T). Tasking_Error is raised if T is + -- terminated and Program_Error will be raised if T is Null_Task_Id. + +private + pragma Inline (Value); + pragma Inline (Reference); + pragma Inline (Set_Value); + pragma Inline (Reinitialize); +end Ada.Task_Attributes; diff --git a/gcc/ada/libgnarl/a-taside.adb b/gcc/ada/libgnarl/a-taside.adb new file mode 100644 index 00000000000..9433669a6eb --- /dev/null +++ b/gcc/ada/libgnarl/a-taside.adb @@ -0,0 +1,219 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A S K _ I D E N T I F I C A T I O N -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Address_Image; +with System.Parameters; +with System.Soft_Links; +with System.Task_Primitives; +with System.Task_Primitives.Operations; +with Ada.Unchecked_Conversion; + +pragma Warnings (Off); +-- Allow withing of non-Preelaborated units in Ada 2005 mode where this +-- package will be categorized as Preelaborate. See AI-362 for details. +-- It is safe in the context of the run-time to violate the rules. + +with System.Tasking.Utilities; + +pragma Warnings (On); + +package body Ada.Task_Identification with + SPARK_Mode => Off +is + + use System.Parameters; + + package STPO renames System.Task_Primitives.Operations; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Convert_Ids (T : Task_Id) return System.Tasking.Task_Id; + function Convert_Ids (T : System.Tasking.Task_Id) return Task_Id; + pragma Inline (Convert_Ids); + -- Conversion functions between different forms of Task_Id + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Task_Id) return Boolean is + begin + return System.Tasking."=" (Convert_Ids (Left), Convert_Ids (Right)); + end "="; + + ----------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_Id) is + begin + if T = Null_Task_Id then + raise Program_Error; + else + System.Tasking.Utilities.Abort_Tasks + (System.Tasking.Task_List'(1 => Convert_Ids (T))); + end if; + end Abort_Task; + + ---------------------------- + -- Activation_Is_Complete -- + ---------------------------- + + function Activation_Is_Complete (T : Task_Id) return Boolean is + use type System.Tasking.Task_Id; + begin + if T = Null_Task_Id then + raise Program_Error; + else + return Convert_Ids (T).Common.Activator = null; + end if; + end Activation_Is_Complete; + + ----------------- + -- Convert_Ids -- + ----------------- + + function Convert_Ids (T : Task_Id) return System.Tasking.Task_Id is + begin + return System.Tasking.Task_Id (T); + end Convert_Ids; + + function Convert_Ids (T : System.Tasking.Task_Id) return Task_Id is + begin + return Task_Id (T); + end Convert_Ids; + + ------------------ + -- Current_Task -- + ------------------ + + function Current_Task return Task_Id is + begin + return Convert_Ids (System.Task_Primitives.Operations.Self); + end Current_Task; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_Id is + begin + return Convert_Ids (System.Task_Primitives.Operations.Environment_Task); + end Environment_Task; + + ----------- + -- Image -- + ----------- + + function Image (T : Task_Id) return String is + function To_Address is new + Ada.Unchecked_Conversion + (Task_Id, System.Task_Primitives.Task_Address); + + begin + if T = Null_Task_Id then + return ""; + + elsif T.Common.Task_Image_Len = 0 then + return System.Address_Image (To_Address (T)); + + else + return T.Common.Task_Image (1 .. T.Common.Task_Image_Len) + & "_" & System.Address_Image (To_Address (T)); + end if; + end Image; + + ----------------- + -- Is_Callable -- + ----------------- + + function Is_Callable (T : Task_Id) return Boolean is + Result : Boolean; + Id : constant System.Tasking.Task_Id := Convert_Ids (T); + begin + if T = Null_Task_Id then + raise Program_Error; + else + System.Soft_Links.Abort_Defer.all; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Id); + Result := Id.Callable; + STPO.Unlock (Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + System.Soft_Links.Abort_Undefer.all; + return Result; + end if; + end Is_Callable; + + ------------------- + -- Is_Terminated -- + ------------------- + + function Is_Terminated (T : Task_Id) return Boolean is + Result : Boolean; + Id : constant System.Tasking.Task_Id := Convert_Ids (T); + + use System.Tasking; + + begin + if T = Null_Task_Id then + raise Program_Error; + else + System.Soft_Links.Abort_Defer.all; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Id); + Result := Id.Common.State = Terminated; + STPO.Unlock (Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + System.Soft_Links.Abort_Undefer.all; + return Result; + end if; + end Is_Terminated; + +end Ada.Task_Identification; diff --git a/gcc/ada/libgnarl/a-taside.ads b/gcc/ada/libgnarl/a-taside.ads new file mode 100644 index 00000000000..1c63fb369f3 --- /dev/null +++ b/gcc/ada/libgnarl/a-taside.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A S K _ I D E N T I F I C A T I O N -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with System; +with System.Tasking; + +package Ada.Task_Identification with + SPARK_Mode, + Abstract_State => (Tasking_State with Synchronous, + External => (Async_Readers, + Async_Writers)), + Initializes => Tasking_State +is + pragma Preelaborate; + -- In accordance with Ada 2005 AI-362 + + type Task_Id is private; + pragma Preelaborable_Initialization (Task_Id); + + Null_Task_Id : constant Task_Id; + + function "=" (Left, Right : Task_Id) return Boolean with + Global => null; + pragma Inline ("="); + + function Image (T : Task_Id) return String with + Global => null; + + function Current_Task return Task_Id with + Volatile_Function, + Global => Tasking_State; + pragma Inline (Current_Task); + + function Environment_Task return Task_Id with + SPARK_Mode => Off, + Global => null; + pragma Inline (Environment_Task); + + procedure Abort_Task (T : Task_Id) with + Global => null; + pragma Inline (Abort_Task); + -- Note: parameter is mode IN, not IN OUT, per AI-00101 + + function Is_Terminated (T : Task_Id) return Boolean with + Volatile_Function, + Global => Tasking_State; + pragma Inline (Is_Terminated); + + function Is_Callable (T : Task_Id) return Boolean with + Volatile_Function, + Global => Tasking_State; + pragma Inline (Is_Callable); + + function Activation_Is_Complete (T : Task_Id) return Boolean with + Volatile_Function, + Global => Tasking_State; + +private + pragma SPARK_Mode (Off); + + type Task_Id is new System.Tasking.Task_Id; + + Null_Task_Id : constant Task_Id := null; + +end Ada.Task_Identification; diff --git a/gcc/ada/libgnarl/g-boubuf.adb b/gcc/ada/libgnarl/g-boubuf.adb new file mode 100644 index 00000000000..9365b107ea7 --- /dev/null +++ b/gcc/ada/libgnarl/g-boubuf.adb @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . B O U N D E D _ B U F F E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-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 -- +-- . -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Bounded_Buffers is + + -------------------- + -- Bounded_Buffer -- + -------------------- + + protected body Bounded_Buffer is + + ------------ + -- Insert -- + ------------ + + entry Insert (Item : Element) when Count /= Capacity is + begin + Values (Next_In) := Item; + Next_In := (Next_In mod Capacity) + 1; + Count := Count + 1; + end Insert; + + ------------ + -- Remove -- + ------------ + + entry Remove (Item : out Element) when Count > 0 is + begin + Item := Values (Next_Out); + Next_Out := (Next_Out mod Capacity) + 1; + Count := Count - 1; + end Remove; + + ----------- + -- Empty -- + ----------- + + function Empty return Boolean is + begin + return Count = 0; + end Empty; + + ---------- + -- Full -- + ---------- + + function Full return Boolean is + begin + return Count = Capacity; + end Full; + + ------------ + -- Extent -- + ------------ + + function Extent return Natural is + begin + return Count; + end Extent; + + end Bounded_Buffer; + +end GNAT.Bounded_Buffers; diff --git a/gcc/ada/libgnarl/g-boubuf.ads b/gcc/ada/libgnarl/g-boubuf.ads new file mode 100644 index 00000000000..2d0566416f2 --- /dev/null +++ b/gcc/ada/libgnarl/g-boubuf.ads @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . B O U N D E D _ B U F F E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a thread-safe generic bounded buffer abstraction. +-- Instances are useful directly or as parts of the implementations of other +-- abstractions, such as mailboxes. + +-- Bounded_Buffer is declared explicitly as a protected type, rather than as +-- a simple limited private type completed as a protected type, so that +-- clients may make calls accordingly (i.e., conditional/timed entry calls). + +with System; + +generic + type Element is private; + -- The type of the values contained within buffer objects + +package GNAT.Bounded_Buffers is + pragma Pure; + + type Content is array (Positive range <>) of Element; + -- Content is an internal artefact that cannot be hidden because protected + -- types cannot contain type declarations. + + Default_Ceiling : constant System.Priority := System.Default_Priority; + -- A convenience value for the Ceiling discriminant + + protected type Bounded_Buffer + (Capacity : Positive; + -- Objects of type Bounded_Buffer specify the maximum number of Element + -- values they can hold via the discriminant Capacity. + + Ceiling : System.Priority) + -- Users must specify the ceiling priority for the object. If the + -- Real-Time Systems Annex is not in use this value is not important. + is + pragma Priority (Ceiling); + + entry Insert (Item : Element); + -- Insert Item into the buffer, blocks caller until space is available + + entry Remove (Item : out Element); + -- Remove next available Element from buffer. Blocks caller until an + -- Element is available. + + function Empty return Boolean; + -- Returns whether the instance contains any Elements. + -- Note: State may change immediately after call returns. + + function Full return Boolean; + -- Returns whether any space remains within the instance. + -- Note: State may change immediately after call returns. + + function Extent return Natural; + -- Returns the number of Element values currently held + -- within the instance. + -- Note: State may change immediately after call returns. + + private + Values : Content (1 .. Capacity); + -- The container for the values held by the buffer instance + + Next_In : Positive := 1; + -- The index of the next Element inserted. Wraps around + + Next_Out : Positive := 1; + -- The index of the next Element removed. Wraps around + + Count : Natural := 0; + -- The number of Elements currently held + end Bounded_Buffer; + +end GNAT.Bounded_Buffers; diff --git a/gcc/ada/libgnarl/g-boumai.ads b/gcc/ada/libgnarl/g-boumai.ads new file mode 100644 index 00000000000..4f627aa6679 --- /dev/null +++ b/gcc/ada/libgnarl/g-boumai.ads @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . B O U N D E D _ M A I L B O X E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a thread-safe asynchronous communication facility +-- in the form of mailboxes. Individual mailbox objects are bounded in size +-- to a value specified by their Capacity discriminants. + +-- Mailboxes actually hold references to messages, not the message values +-- themselves. + +-- Type Mailbox is defined explicitly as a protected type (via derivation +-- from a protected type) so that clients may treat them accordingly (for +-- example, by making conditional/timed entry calls). + +with System; +with GNAT.Bounded_Buffers; + +generic + type Message (<>) is limited private; + type Message_Reference is access all Message; + -- Mailboxes hold references to Message values, of this type + +package GNAT.Bounded_Mailboxes is + pragma Preelaborate; + + package Message_Refs is + new GNAT.Bounded_Buffers (Message_Reference); + + type Mailbox is new Message_Refs.Bounded_Buffer; + + -- Type Mailbox has two inherited discriminants: + + -- Capacity : Positive; + -- Capacity is the maximum number of Message references + -- possibly contained at any given instant. + + -- Ceiling : System.Priority; + -- Users must specify the ceiling priority for the object. + -- If the Real-Time Systems Annex is not in use this value + -- is not important. + + -- Protected type Mailbox has the following inherited interface: + + -- entry Insert (Item : Message_Reference); + -- Insert Item into the Mailbox. Blocks caller + -- until space is available. + + -- entry Remove (Item : out Message_Reference); + -- Remove next available Message_Reference from Mailbox. + -- Blocks caller until a Message_Reference is available. + + -- function Empty return Boolean; + -- Returns whether the Mailbox contains any Message_References. + -- Note: State may change immediately after call returns. + + -- function Full return Boolean; + -- Returns whether any space remains within the Mailbox. + -- Note: State may change immediately after call returns. + + -- function Extent return Natural; + -- Returns the number of Message_Reference values currently held + -- within the Mailbox. + -- Note: State may change immediately after call returns. + + Default_Ceiling : constant System.Priority := Message_Refs.Default_Ceiling; + -- A convenience value for the Ceiling discriminant + +end GNAT.Bounded_Mailboxes; diff --git a/gcc/ada/libgnarl/g-semaph.adb b/gcc/ada/libgnarl/g-semaph.adb new file mode 100644 index 00000000000..7400c881ccf --- /dev/null +++ b/gcc/ada/libgnarl/g-semaph.adb @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E M A P H O R E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Semaphores is + + ------------------------ + -- Counting_Semaphore -- + ------------------------ + + protected body Counting_Semaphore is + + ----------- + -- Seize -- + ----------- + + entry Seize when Count > 0 is + begin + Count := Count - 1; + end Seize; + + ------------- + -- Release -- + ------------- + + procedure Release is + begin + Count := Count + 1; + end Release; + end Counting_Semaphore; + + ---------------------- + -- Binary_Semaphore -- + ---------------------- + + protected body Binary_Semaphore is + + ----------- + -- Seize -- + ----------- + + entry Seize when Available is + begin + Available := False; + end Seize; + + ------------- + -- Release -- + ------------- + + procedure Release is + begin + Available := True; + end Release; + end Binary_Semaphore; + +end GNAT.Semaphores; diff --git a/gcc/ada/libgnarl/g-semaph.ads b/gcc/ada/libgnarl/g-semaph.ads new file mode 100644 index 00000000000..49a49eb7c5b --- /dev/null +++ b/gcc/ada/libgnarl/g-semaph.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E M A P H O R E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides classic counting semaphores and binary semaphores. +-- Both types are visibly defined as protected types so that users can make +-- conditional and timed calls when appropriate. + +with System; + +package GNAT.Semaphores is + + Default_Ceiling : constant System.Priority := System.Default_Priority; + -- A convenient value for the priority discriminants that follow + + ------------------------ + -- Counting_Semaphore -- + ------------------------ + + protected type Counting_Semaphore + (Initial_Value : Natural; + -- A counting semaphore contains an internal counter. The initial + -- value of this counter is set by clients via the discriminant. + + Ceiling : System.Priority) + -- Users must specify the ceiling priority for the object. If the + -- Real-Time Systems Annex is not in use this value is not important. + is + pragma Priority (Ceiling); + + entry Seize; + -- Blocks caller until/unless the semaphore's internal counter is + -- greater than zero. Decrements the semaphore's internal counter when + -- executed. + + procedure Release; + -- Increments the semaphore's internal counter + + private + Count : Natural := Initial_Value; + end Counting_Semaphore; + + ---------------------- + -- Binary_Semaphore -- + ---------------------- + + protected type Binary_Semaphore + (Initially_Available : Boolean; + -- Binary semaphores are either available or not; there is no internal + -- count involved. The discriminant value determines whether the + -- individual object is initially available. + + Ceiling : System.Priority) + -- Users must specify the ceiling priority for the object. If the + -- Real-Time Systems Annex is not in use this value is not important. + is + pragma Priority (Ceiling); + + entry Seize; + -- Blocks the caller unless/until semaphore is available. After + -- execution the semaphore is no longer available. + + procedure Release; + -- Makes the semaphore available + + private + Available : Boolean := Initially_Available; + end Binary_Semaphore; + +end GNAT.Semaphores; diff --git a/gcc/ada/libgnarl/g-signal.adb b/gcc/ada/libgnarl/g-signal.adb new file mode 100644 index 00000000000..a275f1c609f --- /dev/null +++ b/gcc/ada/libgnarl/g-signal.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . S I G N A L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Interrupts; + +package body GNAT.Signals is + + package SI renames System.Interrupts; + + ------------------ + -- Block_Signal -- + ------------------ + + procedure Block_Signal (Signal : Ada.Interrupts.Interrupt_ID) is + begin + SI.Block_Interrupt (SI.Interrupt_ID (Signal)); + end Block_Signal; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (Signal : Ada.Interrupts.Interrupt_ID) return Boolean is + begin + return SI.Is_Blocked (SI.Interrupt_ID (Signal)); + end Is_Blocked; + + -------------------- + -- Unblock_Signal -- + -------------------- + + procedure Unblock_Signal (Signal : Ada.Interrupts.Interrupt_ID) is + begin + SI.Unblock_Interrupt (SI.Interrupt_ID (Signal)); + end Unblock_Signal; + +end GNAT.Signals; diff --git a/gcc/ada/libgnarl/g-signal.ads b/gcc/ada/libgnarl/g-signal.ads new file mode 100644 index 00000000000..cdeda28c0b9 --- /dev/null +++ b/gcc/ada/libgnarl/g-signal.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . S I G N A L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-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 provides operations for querying and setting the blocked +-- status of signals. + +-- This package is supported only on targets where Ada.Interrupts.Interrupt_ID +-- corresponds to software signals on the target, and where System.Interrupts +-- provides the ability to block and unblock signals. + +with Ada.Interrupts; + +package GNAT.Signals is + + procedure Block_Signal (Signal : Ada.Interrupts.Interrupt_ID); + -- Block "Signal" at the process level + + procedure Unblock_Signal (Signal : Ada.Interrupts.Interrupt_ID); + -- Unblock "Signal" at the process level + + function Is_Blocked (Signal : Ada.Interrupts.Interrupt_ID) return Boolean; + -- "Signal" blocked at the process level? + +end GNAT.Signals; diff --git a/gcc/ada/libgnarl/g-tastus.ads b/gcc/ada/libgnarl/g-tastus.ads new file mode 100644 index 00000000000..3c016f0cf84 --- /dev/null +++ b/gcc/ada/libgnarl/g-tastus.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . T A S K _ S T A C K _ U S A G E -- +-- -- +-- S p e c -- +-- -- +-- 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an API to query for tasks stack usage at runtime +-- and during debug. + +-- See file s-stusta.ads for full documentation of the interface + +with System.Stack_Usage.Tasking; + +package GNAT.Task_Stack_Usage renames System.Stack_Usage.Tasking; diff --git a/gcc/ada/libgnarl/g-thread.adb b/gcc/ada/libgnarl/g-thread.adb new file mode 100644 index 00000000000..90d51afb8c9 --- /dev/null +++ b/gcc/ada/libgnarl/g-thread.adb @@ -0,0 +1,186 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T H R E A D S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-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 -- +-- . -- +-- -- +-- 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; use Ada.Task_Identification; +with System.Task_Primitives.Operations; +with System.Tasking; +with System.Tasking.Stages; use System.Tasking.Stages; +with System.OS_Interface; use System.OS_Interface; +with System.Soft_Links; use System.Soft_Links; +with Ada.Unchecked_Conversion; + +package body GNAT.Threads is + + use System; + + package STPO renames System.Task_Primitives.Operations; + + type Thread_Id_Ptr is access all Thread_Id; + + pragma Warnings (Off); + -- The following unchecked conversions are aliasing safe, since they + -- are never used to create pointers to improperly aliased data. + + function To_Addr is new Ada.Unchecked_Conversion (Task_Id, Address); + function To_Id is new Ada.Unchecked_Conversion (Address, Task_Id); + function To_Id is new Ada.Unchecked_Conversion (Address, Tasking.Task_Id); + function To_Tid is new Ada.Unchecked_Conversion + (Address, Ada.Task_Identification.Task_Id); + function To_Thread is new Ada.Unchecked_Conversion (Address, Thread_Id_Ptr); + + pragma Warnings (On); + + type Code_Proc is access procedure (Id : Address; Parm : Void_Ptr); + + task type Thread + (Stsz : Natural; + Prio : Any_Priority; + Parm : Void_Ptr; + Code : Code_Proc) + is + pragma Priority (Prio); + pragma Storage_Size (Stsz); + end Thread; + + task body Thread is + begin + Code.all (To_Addr (Current_Task), Parm); + end Thread; + + type Tptr is access Thread; + + ------------------- + -- Create_Thread -- + ------------------- + + function Create_Thread + (Code : Address; + Parm : Void_Ptr; + Size : Natural; + Prio : Integer) return System.Address + is + TP : Tptr; + + function To_CP is new Ada.Unchecked_Conversion (Address, Code_Proc); + + begin + TP := new Thread (Size, Prio, Parm, To_CP (Code)); + return To_Addr (TP'Identity); + end Create_Thread; + + --------------------- + -- Register_Thread -- + --------------------- + + function Register_Thread return System.Address is + begin + return Task_Primitives.Operations.Register_Foreign_Thread.all'Address; + end Register_Thread; + + ----------------------- + -- Unregister_Thread -- + ----------------------- + + procedure Unregister_Thread is + Self_Id : constant Tasking.Task_Id := Task_Primitives.Operations.Self; + begin + Self_Id.Common.State := Tasking.Terminated; + Destroy_TSD (Self_Id.Common.Compiler_Data); + Free_Task (Self_Id); + end Unregister_Thread; + + -------------------------- + -- Unregister_Thread_Id -- + -------------------------- + + procedure Unregister_Thread_Id (Thread : System.Address) is + Thr : constant Thread_Id := To_Thread (Thread).all; + T : Tasking.Task_Id; + + use type Tasking.Task_Id; + -- This use clause should be removed once a visibility problem + -- with the MaRTE run time has been fixed. ??? + + pragma Warnings (Off); + use type System.OS_Interface.Thread_Id; + pragma Warnings (On); + + begin + STPO.Lock_RTS; + + T := Tasking.All_Tasks_List; + loop + exit when T = null or else STPO.Get_Thread_Id (T) = Thr; + + T := T.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + + if T /= null then + T.Common.State := Tasking.Terminated; + Destroy_TSD (T.Common.Compiler_Data); + Free_Task (T); + end if; + end Unregister_Thread_Id; + + -------------------- + -- Destroy_Thread -- + -------------------- + + procedure Destroy_Thread (Id : Address) is + Tid : constant Task_Id := To_Id (Id); + begin + Abort_Task (Tid); + end Destroy_Thread; + + ---------------- + -- Get_Thread -- + ---------------- + + procedure Get_Thread (Id : Address; Thread : Address) is + Thr : constant Thread_Id_Ptr := To_Thread (Thread); + begin + Thr.all := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id)); + end Get_Thread; + + ---------------- + -- To_Task_Id -- + ---------------- + + function To_Task_Id + (Id : System.Address) return Ada.Task_Identification.Task_Id + is + begin + return To_Tid (Id); + end To_Task_Id; + +end GNAT.Threads; diff --git a/gcc/ada/libgnarl/g-thread.ads b/gcc/ada/libgnarl/g-thread.ads new file mode 100644 index 00000000000..e2fd748dc1d --- /dev/null +++ b/gcc/ada/libgnarl/g-thread.ads @@ -0,0 +1,149 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T H R E A D S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides facilities for creation or registration of foreign +-- threads for use as Ada tasks. In order to execute general Ada code, the +-- run-time system must know about all tasks. This package allows foreign +-- code, e.g. a C program, to create a thread that the Ada run-time knows +-- about, or to register the current thread. + +-- For some implementations of GNAT Pro, the registration of foreign threads +-- is automatic. However, in such implementations, if the Ada program has no +-- tasks at all and no tasking constructs other than delay, then by default +-- the non-tasking version of the Ada run-time will be loaded. If foreign +-- threads are present, it is important to ensure that the tasking version +-- of the Ada run time is loaded. This may be achieved by adding "with +-- GNAT.Threads" to any unit in the partition. + +with System; +with Ada.Task_Identification; + +package GNAT.Threads is + + type Void_Ptr is access all Integer; + + function Create_Thread + (Code : System.Address; -- pointer + Parm : Void_Ptr; -- pointer + Size : Natural; -- int + Prio : Integer) -- int + return System.Address; + pragma Export (C, Create_Thread, "__gnat_create_thread"); + -- Creates a thread with the given (Size) stack size in bytes, and + -- the given (Prio) priority. The task will execute a call to the + -- procedure whose address is given by Code. This procedure has + -- the prototype + -- + -- void thread_code (void *id, void *parm); + -- + -- where id is the id of the created task, and parm is the parameter + -- passed to Create_Thread. The called procedure is the body of the + -- code for the task, the task will be automatically terminated when + -- the procedure returns. + -- + -- This function returns the Ada Id of the created task that can then be + -- used as a parameter to the procedures below. + -- + -- C declaration: + -- + -- extern void *__gnat_create_thread + -- (void (*code)(void *, void *), void *parm, int size, int prio); + + function Register_Thread return System.Address; + pragma Export (C, Register_Thread, "__gnat_register_thread"); + -- Create an Ada task Id for the current thread if needed. + -- If the thread could not be registered, System.Null_Address is returned. + -- + -- This function returns the Ada Id of the current task that can then be + -- used as a parameter to the procedures below. + -- + -- C declaration: + -- + -- extern void *__gnat_register_thread (); + -- + -- Here is a typical usage of the Register/Unregister_Thread procedures: + -- + -- void thread_body () + -- { + -- void *task_id = __gnat_register_thread (); + -- ... thread body ... + -- __gnat_unregister_thread (); + -- } + + procedure Unregister_Thread; + pragma Export (C, Unregister_Thread, "__gnat_unregister_thread"); + -- Unregister the current task from the GNAT run time and destroy the + -- memory allocated for its task id. + -- + -- C declaration: + -- + -- extern void __gnat_unregister_thread (); + + procedure Unregister_Thread_Id (Thread : System.Address); + pragma Export (C, Unregister_Thread_Id, "__gnat_unregister_thread_id"); + -- Unregister the task associated with Thread from the GNAT run time and + -- destroy the memory allocated for its task id. + -- If no task id is associated with Thread, do nothing. + -- + -- C declaration: + -- + -- extern void __gnat_unregister_thread_id (pthread_t *thread); + + procedure Destroy_Thread (Id : System.Address); + pragma Export (C, Destroy_Thread, "__gnat_destroy_thread"); + -- This procedure may be used to prematurely abort the created thread. + -- The value Id is the value that was passed to the thread code procedure + -- at activation time. + -- + -- C declaration: + -- + -- extern void __gnat_destroy_thread (void *id); + + procedure Get_Thread (Id : System.Address; Thread : System.Address); + pragma Export (C, Get_Thread, "__gnat_get_thread"); + -- This procedure is used to retrieve the thread id of a given task. + -- The value Id is the value that was passed to the thread code procedure + -- at activation time. + -- Thread is a pointer to a thread id that will be updated by this + -- procedure. + -- + -- C declaration: + -- + -- extern void __gnat_get_thread (void *id, pthread_t *thread); + + function To_Task_Id + (Id : System.Address) + return Ada.Task_Identification.Task_Id; + -- Ada interface only. + -- Given a low level Id, as returned by Create_Thread, return a Task_Id, + -- so that operations in Ada.Task_Identification can be used. + +end GNAT.Threads; diff --git a/gcc/ada/libgnarl/i-vxinco.adb b/gcc/ada/libgnarl/i-vxinco.adb new file mode 100644 index 00000000000..db57c9522c9 --- /dev/null +++ b/gcc/ada/libgnarl/i-vxinco.adb @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- I N T E R F A C E S . V X W O R K S . I N T _ C O N N E C T I O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2016-2017, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License 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. -- +-- -- +------------------------------------------------------------------------------ + +package body Interfaces.VxWorks.Int_Connection is + + Connection_Routine : Interrupt_Connector; + pragma Import (C, Connection_Routine, "__gnat_user_int_connect"); + -- Declared in System.Interrupts. Defaults to the standard OS connector in + -- System.OS_Interface (or Interfaces.VxWorks for restricted runtimes). + + ------------- + -- Connect -- + ------------- + + procedure Connect (Connector : Interrupt_Connector) is + begin + Connection_Routine := Connector; + end Connect; + +end Interfaces.VxWorks.Int_Connection; diff --git a/gcc/ada/libgnarl/i-vxinco.ads b/gcc/ada/libgnarl/i-vxinco.ads new file mode 100644 index 00000000000..0a4471efc0e --- /dev/null +++ b/gcc/ada/libgnarl/i-vxinco.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- I N T E R F A C E S . V X W O R K S . I N T _ C O N N E C T I O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2016-2017, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License 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 package provides users with the ability to use a custom routine for +-- connecting hardware interrupts for VxWorks environments that support the +-- capability to handle them. The custom routine must have the same profile +-- as the VxWorks intConnect() routine. + +with System; + +package Interfaces.VxWorks.Int_Connection is + + type Interrupt_Connector is access function + (Vector : Interrupt_Vector; + Handler : VOIDFUNCPTR; + Parameter : System.Address := System.Null_Address) return STATUS; + pragma Convention (C, Interrupt_Connector); + -- Convention C for compatibility with intConnect(). User alternatives are + -- likely to be imports of C routines anyway. + + procedure Connect (Connector : Interrupt_Connector); + -- Set user-defined interrupt connection routine. Must precede calls to + -- Ada.Interrupts.Attach_Handler, or the default connector from + -- System.OS_Interface (or Interfaces.VxWorks for Ravenscar Cert) will be + -- used. Can be called multiple times to change the connection routine for + -- subsequent calls to Attach_Handler. + +end Interfaces.VxWorks.Int_Connection; 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-inmaop.ads b/gcc/ada/libgnarl/s-inmaop.ads new file mode 100644 index 00000000000..69db999534d --- /dev/null +++ b/gcc/ada/libgnarl/s-inmaop.ads @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +package System.Interrupt_Management.Operations is + + procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID); + pragma Inline (Thread_Block_Interrupt); + -- Mask the calling thread for the interrupt + + procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID); + pragma Inline (Thread_Unblock_Interrupt); + -- Unmask the calling thread for the interrupt + + procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask); + -- Set the interrupt mask of the calling thread + + procedure Set_Interrupt_Mask + (Mask : access Interrupt_Mask; + OMask : access Interrupt_Mask); + pragma Inline (Set_Interrupt_Mask); + -- Set the interrupt mask of the calling thread while returning the + -- previous Mask. + + procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask); + pragma Inline (Get_Interrupt_Mask); + -- Get the interrupt mask of the calling thread + + function Interrupt_Wait (Mask : access Interrupt_Mask) return Interrupt_ID; + pragma Inline (Interrupt_Wait); + -- Wait for the interrupts specified in Mask and return + -- the interrupt received. Return 0 upon error. + + procedure Install_Default_Action (Interrupt : Interrupt_ID); + pragma Inline (Install_Default_Action); + -- Set the sigaction of the Interrupt to default (SIG_DFL) + + procedure Install_Ignore_Action (Interrupt : Interrupt_ID); + pragma Inline (Install_Ignore_Action); + -- Set the sigaction of the Interrupt to ignore (SIG_IGN) + + procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask); + pragma Inline (Fill_Interrupt_Mask); + -- Get a Interrupt_Mask with all the interrupt masked + + procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask); + pragma Inline (Empty_Interrupt_Mask); + -- Get a Interrupt_Mask with all the interrupt unmasked + + procedure Add_To_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID); + pragma Inline (Add_To_Interrupt_Mask); + -- Mask the given interrupt in the Interrupt_Mask + + procedure Delete_From_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID); + pragma Inline (Delete_From_Interrupt_Mask); + -- Unmask the given interrupt in the Interrupt_Mask + + function Is_Member + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) return Boolean; + pragma Inline (Is_Member); + -- See if a given interrupt is masked in the Interrupt_Mask + + procedure Copy_Interrupt_Mask (X : out Interrupt_Mask; Y : Interrupt_Mask); + pragma Inline (Copy_Interrupt_Mask); + -- Assignment needed for limited private type Interrupt_Mask + + procedure Interrupt_Self_Process (Interrupt : Interrupt_ID); + pragma Inline (Interrupt_Self_Process); + -- Raise an Interrupt process-level + + procedure Setup_Interrupt_Mask; + -- Mask Environment task for all signals + -- This function should be called by the elaboration of System.Interrupt + -- to set up proper signal masking in all tasks. + + -- The following objects serve as constants, but are initialized in the + -- body to aid portability. These should be in System.Interrupt_Management + -- but since Interrupt_Mask is private type we cannot have them declared + -- there. + + -- Why not make these deferred constants that are initialized using + -- function calls in the private part??? + + Environment_Mask : aliased Interrupt_Mask; + -- This mask represents the mask of Environment task when this package is + -- being elaborated, except the signals being forced to be unmasked by RTS + -- (items in Keep_Unmasked) + + All_Tasks_Mask : aliased Interrupt_Mask; + -- This is the mask of all tasks created in RTS. Only one task in RTS + -- is responsible for masking/unmasking signals (see s-interr.adb). + +end System.Interrupt_Management.Operations; 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-interr.adb b/gcc/ada/libgnarl/s-interr.adb new file mode 100644 index 00000000000..efd598bd7f0 --- /dev/null +++ b/gcc/ada/libgnarl/s-interr.adb @@ -0,0 +1,1472 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-handleable interrupts are masked at all times in all tasks/threads +-- except possibly for the Interrupt_Manager task. + +-- When a user task wants to achieve masking/unmasking an interrupt, it must +-- call Block_Interrupt/Unblock_Interrupt, which will have the effect of +-- unmasking/masking the interrupt in the Interrupt_Manager task. + +-- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any +-- other low-level interface that changes the interrupt action or +-- interrupt mask needs a careful thought. + +-- One may achieve the effect of system calls first masking RTS blocked +-- (by calling Block_Interrupt) for the interrupt under consideration. +-- This will make all the tasks in RTS blocked for the Interrupt. + +-- Once we associate a Server_Task with an interrupt, the task never goes +-- away, and we never remove the association. + +-- There is no more than one interrupt per Server_Task and no more than one +-- Server_Task per interrupt. + +with Ada.Exceptions; +with Ada.Task_Identification; + +with System.Task_Primitives; +with System.Interrupt_Management; + +with System.Interrupt_Management.Operations; +pragma Elaborate_All (System.Interrupt_Management.Operations); + +with System.IO; + +with System.Task_Primitives.Operations; +with System.Task_Primitives.Interrupt_Operations; +with System.Storage_Elements; +with System.Tasking.Utilities; + +with System.Tasking.Rendezvous; +pragma Elaborate_All (System.Tasking.Rendezvous); + +with System.Tasking.Initialization; +with System.Parameters; + +with Ada.Unchecked_Conversion; + +package body System.Interrupts is + + use Parameters; + use Tasking; + + package POP renames System.Task_Primitives.Operations; + package PIO renames System.Task_Primitives.Interrupt_Operations; + package IMNG renames System.Interrupt_Management; + package IMOP renames System.Interrupt_Management.Operations; + + 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 Initialize (Mask : IMNG.Interrupt_Mask); + + 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); + + entry Block_Interrupt (Interrupt : Interrupt_ID); + + entry Unblock_Interrupt (Interrupt : Interrupt_ID); + + entry Ignore_Interrupt (Interrupt : Interrupt_ID); + + entry Unignore_Interrupt (Interrupt : Interrupt_ID); + + pragma Interrupt_Priority (System.Interrupt_Priority'Last); + end Interrupt_Manager; + + task type Server_Task (Interrupt : Interrupt_ID) is + pragma Priority (System.Interrupt_Priority'Last); + -- Note: the above pragma Priority is strictly speaking improper since + -- it is outside the range of allowed priorities, but the compiler + -- treats system units specially and does not apply this range checking + -- rule to system units. + + end Server_Task; + + type Server_Task_Access is access 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'Range) 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. A handler is a Static one if it is + -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise, + -- not static) + + User_Entry : array (Interrupt_ID'Range) 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 + + Blocked : array (Interrupt_ID'Range) of Boolean := (others => False); + pragma Atomic_Components (Blocked); + -- True iff the corresponding interrupt is blocked in the process level + + Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); + pragma Atomic_Components (Ignored); + -- True iff the corresponding interrupt is blocked in the process level + + Last_Unblocker : + array (Interrupt_ID'Range) of Task_Id := (others => Null_Task); + pragma Atomic_Components (Last_Unblocker); + -- Holds the ID of the last Task which Unblocked this Interrupt. It + -- contains Null_Task if no tasks have ever requested the Unblocking + -- operation or the Interrupt is currently Blocked. + + Server_ID : array (Interrupt_ID'Range) of Task_Id := + (others => Null_Task); + pragma Atomic_Components (Server_ID); + -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is + -- needed to accomplish locking per Interrupt base. Also is needed to + -- decide whether to create a new Server_Task. + + -- 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; + + Access_Hold : Server_Task_Access; + -- Variable used to allocate Server_Task using "new" + + ----------------------- + -- Local Subprograms -- + ----------------------- + + 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. + + -------------------- + -- 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 + if Is_Reserved (Interrupt) then + raise Program_Error with + "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + 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 + if Is_Reserved (Interrupt) then + raise Program_Error with + "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); + end Bind_Interrupt_To_Entry; + + --------------------- + -- Block_Interrupt -- + --------------------- + + procedure Block_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Block_Interrupt (Interrupt); + end Block_Interrupt; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + -- ??? 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 + if Is_Reserved (Interrupt) then + raise Program_Error with + "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + 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. 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 + if Is_Reserved (Interrupt) then + raise Program_Error with + "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + end Exchange_Handler; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Static_Interrupt_Protection) is + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state for interrupt number Int. Defined in init.c + + Default : constant Character := 's'; + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + begin + -- ??? loop to be executed only when we're not doing library level + -- finalization, since in this case all interrupt tasks are gone. + + -- If the Abort_Task signal is set to system, it means that we cannot + -- reset interrupt handlers since this would require sending the abort + -- signal to the Server_Task + + if not Interrupt_Manager'Terminated + and then + State (System.Interrupt_Management.Abort_Task_Interrupt) /= Default + 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; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + -- Need comments as to why these always return True ??? + + 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 + if Is_Reserved (Interrupt) then + raise Program_Error with + "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Ignore_Interrupt (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; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (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 Blocked (Interrupt); + end Is_Blocked; + + ----------------------- + -- 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 User_Entry (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"; + end if; + + return User_Handler (Interrupt).H /= null; + end Is_Handler_Attached; + + ---------------- + -- Is_Ignored -- + ---------------- + + function Is_Ignored (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 Ignored (Interrupt); + 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 + begin + return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); + end Is_Reserved; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + 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 the Handler as usable for Dynamic Interrupt + -- Handler. Routines attaching and detaching Handler dynamically should + -- first consult if the Handler is registered. A Program Error should + -- be raised if it is not registered. + + -- The pragma Interrupt_Handler can only appear in the library level PO + -- definition and instantiation. Therefore, we do not need to implement + -- Unregistering operation. Neither we need to protect the queue + -- structure using 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 + if Is_Reserved (Interrupt) then + raise Program_Error with + "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Unblock_Interrupt (Interrupt); + end Unblock_Interrupt; + + ------------------ + -- Unblocked_By -- + ------------------ + + function Unblocked_By + (Interrupt : Interrupt_ID) return System.Tasking.Task_Id + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + return Last_Unblocker (Interrupt); + end Unblocked_By; + + ------------------------ + -- Unignore_Interrupt -- + ------------------------ + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error with + "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; + end if; + + Interrupt_Manager.Unignore_Interrupt (Interrupt); + end Unignore_Interrupt; + + ----------------------- + -- Interrupt_Manager -- + ----------------------- + + task body Interrupt_Manager is + -- By making this task independent of master, when the process + -- goes away, the Interrupt_Manager will terminate gracefully. + + Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; + + --------------------- + -- Local Variables -- + --------------------- + + Intwait_Mask : aliased IMNG.Interrupt_Mask; + Ret_Interrupt : Interrupt_ID; + Old_Mask : aliased IMNG.Interrupt_Mask; + Old_Handler : Parameterless_Handler; + + -------------------- + -- Local Routines -- + -------------------- + + procedure Bind_Handler (Interrupt : Interrupt_ID); + -- This procedure does not do anything if the Interrupt is blocked. + -- Otherwise, we have to interrupt Server_Task for status change through + -- Wakeup interrupt. + + procedure Unbind_Handler (Interrupt : Interrupt_ID); + -- This procedure does not do anything if the Interrupt is blocked. + -- Otherwise, we have to interrupt Server_Task for status change + -- through abort interrupt. + + 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 + if not Blocked (Interrupt) then + + -- Mask this task for the given Interrupt so that all tasks + -- are masked for the Interrupt and the actual delivery of the + -- Interrupt will be caught using "sigwait" by the + -- corresponding Server_Task. + + IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt)); + + -- We have installed a Handler or an Entry before we called + -- this procedure. If the Handler Task is waiting to be awakened, + -- do it here. Otherwise, the interrupt will be discarded. + + POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep); + end if; + end Bind_Handler; + + -------------------- + -- Unbind_Handler -- + -------------------- + + procedure Unbind_Handler (Interrupt : Interrupt_ID) is + Server : System.Tasking.Task_Id; + + begin + if not Blocked (Interrupt) then + + -- Currently, there is a Handler or an Entry attached and + -- corresponding Server_Task is waiting on "sigwait." We have to + -- wake up the Server_Task and make it wait on condition variable + -- by sending an Abort_Task_Interrupt + + Server := Server_ID (Interrupt); + + case Server.Common.State is + when Interrupt_Server_Blocked_Interrupt_Sleep + | Interrupt_Server_Idle_Sleep + => + POP.Wakeup (Server, Server.Common.State); + + when Interrupt_Server_Blocked_On_Event_Flag => + POP.Abort_Task (Server); + + -- Make sure corresponding Server_Task is out of its + -- own sigwait state. + + Ret_Interrupt := + Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); + pragma Assert + (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt)); + + when Runnable => + null; + + when others => + pragma Assert (False); + null; + end case; + + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + + -- Unmake the Interrupt for this task in order to allow default + -- action again. + + IMOP.Thread_Unblock_Interrupt (IMNG.Interrupt_ID (Interrupt)); + + else + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + end if; + 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 + + -- In case we have an Interrupt Entry installed, raise a 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. That 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 + + -- Tries to detach a static Interrupt Handler. + -- raise a program error. + + raise Program_Error with + "trying to detach a static interrupt handler"; + end if; + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + + 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 + + -- 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"; + end if; + + -- Note : A null handler with Static = True will pass the following + -- check. That is the case when we want to Detach a handler + -- regardless of the Static status of the 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 + + -- Tries to overwrite a static Interrupt Handler with a dynamic + -- Handler + + and then (User_Handler (Interrupt).Static + + -- 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; + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + + -- 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 Server_ID (Interrupt) = Null_Task then + + -- When a new Server_Task is created, it should have its + -- signal mask set to the All_Tasks_Mask. + + IMOP.Set_Interrupt_Mask + (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); + Access_Hold := new Server_Task (Interrupt); + IMOP.Set_Interrupt_Mask (Old_Mask'Access); + + Server_ID (Interrupt) := To_System (Access_Hold.all'Identity); + end if; + + if New_Handler = null then + if Old_Handler /= null then + Unbind_Handler (Interrupt); + end if; + + return; + end if; + + if Old_Handler = null then + Bind_Handler (Interrupt); + end if; + end Unprotected_Exchange_Handler; + + -- Start of processing for Interrupt_Manager + + begin + -- Environment task gets its own interrupt mask, saves it, and then + -- masks all interrupts except the Keep_Unmasked set. + + -- During rendezvous, the Interrupt_Manager receives the old interrupt + -- mask of the environment task, and sets its own interrupt mask to that + -- value. + + -- The environment task will call the entry of Interrupt_Manager some + -- during elaboration of the body of this package. + + accept Initialize (Mask : IMNG.Interrupt_Mask) do + declare + The_Mask : aliased IMNG.Interrupt_Mask; + begin + IMOP.Copy_Interrupt_Mask (The_Mask, Mask); + IMOP.Set_Interrupt_Mask (The_Mask'Access); + end; + end Initialize; + + -- Note: All tasks in RTS will have all the Reserve Interrupts being + -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked + -- when created. + + -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks. + -- We mask the Interrupt in this particular task so that "sigwait" is + -- possible to catch an explicitly sent Abort_Task_Interrupt from the + -- Server_Tasks. + + -- This sigwaiting is needed so that we make sure a Server_Task is out + -- of its own sigwait state. This extra synchronization is necessary to + -- prevent following scenarios. + + -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the + -- Server_Task then changes its own interrupt mask (OS level). + -- If an interrupt (corresponding to the Server_Task) arrives + -- in the mean time we have the Interrupt_Manager unmasked and + -- the Server_Task waiting on sigwait. + + -- 2) For unbinding handler, we install a default action in the + -- Interrupt_Manager. POSIX.1c states that the result of using + -- "sigwait" and "sigaction" simultaneously on the same interrupt + -- is undefined. Therefore, we need to be informed from the + -- Server_Task of the fact that the Server_Task is out of its + -- sigwait stage. + + IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); + IMOP.Add_To_Interrupt_Mask + (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt); + IMOP.Thread_Block_Interrupt + (IMNG.Abort_Task_Interrupt); + + loop + -- A block is needed to absorb Program_Error exception + + 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; + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); + + -- Indicate the attachment of Interrupt Entry in ATCB. + -- This is need so that when an Interrupt Entry task + -- terminates the binding can be cleaned. The call to + -- unbinding must be made 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 then + + -- When a new Server_Task is created, it should have its + -- signal mask set to the All_Tasks_Mask. + + IMOP.Set_Interrupt_Mask + (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); + Access_Hold := new Server_Task (Interrupt); + IMOP.Set_Interrupt_Mask (Old_Mask'Access); + Server_ID (Interrupt) := + To_System (Access_Hold.all'Identity); + end if; + + Bind_Handler (Interrupt); + end Bind_Interrupt_To_Entry; + + or + accept Detach_Interrupt_Entries (T : Task_Id) do + for J in Interrupt_ID'Range loop + if not Is_Reserved (J) then + if User_Entry (J).T = T then + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (J) := False; + User_Entry (J) := Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (J); + end if; + end if; + end loop; + + -- Indicate in ATCB that no Interrupt Entries are attached + + T.Interrupt_Entry := False; + end Detach_Interrupt_Entries; + + or + accept Block_Interrupt (Interrupt : Interrupt_ID) do + if Blocked (Interrupt) then + return; + end if; + + Blocked (Interrupt) := True; + Last_Unblocker (Interrupt) := Null_Task; + + -- Mask this task for the given Interrupt so that all tasks + -- are masked for the Interrupt. + + IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt)); + + if User_Handler (Interrupt).H /= null + or else User_Entry (Interrupt).T /= Null_Task + then + -- This is the case where the Server_Task + -- is waiting on"sigwait." Wake it up by sending an + -- Abort_Task_Interrupt so that the Server_Task waits + -- on Cond. + + POP.Abort_Task (Server_ID (Interrupt)); + + -- Make sure corresponding Server_Task is out of its own + -- sigwait state. + + Ret_Interrupt := Interrupt_ID + (IMOP.Interrupt_Wait (Intwait_Mask'Access)); + pragma Assert + (Ret_Interrupt = + Interrupt_ID (IMNG.Abort_Task_Interrupt)); + end if; + end Block_Interrupt; + + or + accept Unblock_Interrupt (Interrupt : Interrupt_ID) do + if not Blocked (Interrupt) then + return; + end if; + + Blocked (Interrupt) := False; + Last_Unblocker (Interrupt) := + To_System (Unblock_Interrupt'Caller); + + if User_Handler (Interrupt).H = null + and then User_Entry (Interrupt).T = Null_Task + then + -- No handler is attached. Unmask the Interrupt so that + -- the default action can be carried out. + + IMOP.Thread_Unblock_Interrupt + (IMNG.Interrupt_ID (Interrupt)); + + else + -- The Server_Task must be waiting on the Cond variable + -- since it was being blocked and an Interrupt Hander or + -- an Entry was there. Wake it up and let it change it + -- place of waiting according to its new state. + + POP.Wakeup (Server_ID (Interrupt), + Interrupt_Server_Blocked_Interrupt_Sleep); + end if; + end Unblock_Interrupt; + + or + accept Ignore_Interrupt (Interrupt : Interrupt_ID) do + if Ignored (Interrupt) then + return; + end if; + + Ignored (Interrupt) := True; + + -- If there is a handler associated with the Interrupt, + -- detach it first. In this way we make sure that the + -- Server_Task is not on sigwait. This is legal since + -- Unignore_Interrupt is to install the default action. + + if User_Handler (Interrupt).H /= null then + Unprotected_Detach_Handler + (Interrupt => Interrupt, Static => True); + + elsif User_Entry (Interrupt).T /= Null_Task then + User_Entry (Interrupt) := Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (Interrupt); + end if; + + IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt)); + end Ignore_Interrupt; + + or + accept Unignore_Interrupt (Interrupt : Interrupt_ID) do + Ignored (Interrupt) := False; + + -- If there is a handler associated with the Interrupt, + -- detach it first. In this way we make sure that the + -- Server_Task is not on sigwait. This is legal since + -- Unignore_Interrupt is to install the default action. + + if User_Handler (Interrupt).H /= null then + Unprotected_Detach_Handler + (Interrupt => Interrupt, Static => True); + + elsif User_Entry (Interrupt).T /= Null_Task then + User_Entry (Interrupt) := Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (Interrupt); + end if; + + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + end Unignore_Interrupt; + 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 X : others => + System.IO.Put_Line ("Exception in Interrupt_Manager"); + System.IO.Put_Line (Ada.Exceptions.Exception_Information (X)); + pragma Assert (False); + end; + end loop; + end Interrupt_Manager; + + ----------------- + -- Server_Task -- + ----------------- + + task body Server_Task is + -- By making this task independent of master, when the process goes + -- away, the Server_Task will terminate gracefully. + + Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; + + Intwait_Mask : aliased IMNG.Interrupt_Mask; + Ret_Interrupt : Interrupt_ID; + Self_ID : constant Task_Id := Self; + Tmp_Handler : Parameterless_Handler; + Tmp_ID : Task_Id; + Tmp_Entry_Index : Task_Entry_Index; + + begin + -- Install default action in system level + + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + + -- Note: All tasks in RTS will have all the Reserve Interrupts being + -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked when + -- created. + + -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks. + -- We mask the Interrupt in this particular task so that "sigwait" is + -- possible to catch an explicitly sent Abort_Task_Interrupt from the + -- Interrupt_Manager. + + -- There are two Interrupt interrupts that this task catch through + -- "sigwait." One is the Interrupt this task is designated to catch + -- in order to execute user handler or entry. The other one is + -- the Abort_Task_Interrupt. This interrupt is being sent from the + -- Interrupt_Manager to inform status changes (e.g: become Blocked, + -- Handler or Entry is to be detached). + + -- Prepare a mask to used for sigwait + + IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); + + IMOP.Add_To_Interrupt_Mask + (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt)); + + IMOP.Add_To_Interrupt_Mask + (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt); + + IMOP.Thread_Block_Interrupt + (IMNG.Abort_Task_Interrupt); + + PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID); + + loop + System.Tasking.Initialization.Defer_Abort (Self_ID); + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + + if User_Handler (Interrupt).H = null + and then User_Entry (Interrupt).T = Null_Task + then + -- No Interrupt binding. If there is an interrupt, + -- Interrupt_Manager will take default action. + + Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep; + POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep); + Self_ID.Common.State := Runnable; + + elsif Blocked (Interrupt) then + + -- Interrupt is blocked, stay here, so we won't catch it + + Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep; + POP.Sleep (Self_ID, Interrupt_Server_Blocked_Interrupt_Sleep); + Self_ID.Common.State := Runnable; + + else + -- A Handler or an Entry is installed. At this point all tasks + -- mask for the Interrupt is masked. Catch the Interrupt using + -- sigwait. + + -- This task may wake up from sigwait by receiving an interrupt + -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding + -- a Procedure Handler or an Entry. Or it could be a wake up + -- from status change (Unblocked -> Blocked). If that is not + -- the case, we should execute the attached Procedure or Entry. + + Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + -- Avoid race condition when terminating application and + -- System.Parameters.No_Abort is True. + + if Parameters.No_Abort and then Self_ID.Pending_Action then + Initialization.Do_Pending_Action (Self_ID); + end if; + + Ret_Interrupt := + Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); + Self_ID.Common.State := Runnable; + + if Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt) then + + -- Inform the Interrupt_Manager of wakeup from above sigwait + + POP.Abort_Task (Interrupt_Manager_ID); + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + + else + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + + if Ret_Interrupt /= Interrupt then + + -- On some systems (e.g. recent linux kernels), sigwait + -- may return unexpectedly (with errno set to EINTR). + + null; + + else + -- Even though we have received an Interrupt the status may + -- have changed already before we got the Self_ID lock above + -- Therefore we make sure a Handler or an Entry is still + -- there and make appropriate call. + + -- If there is no calls to make we need to regenerate the + -- Interrupt in order not to lose it. + + if User_Handler (Interrupt).H /= null then + Tmp_Handler := User_Handler (Interrupt).H; + + -- RTS calls should not be made with self being locked + + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + Tmp_Handler.all; + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + + elsif User_Entry (Interrupt).T /= Null_Task then + Tmp_ID := User_Entry (Interrupt).T; + Tmp_Entry_Index := User_Entry (Interrupt).E; + + -- RTS calls should not be made with self being locked + + if Single_Lock then + POP.Unlock_RTS; + end if; + + POP.Unlock (Self_ID); + + System.Tasking.Rendezvous.Call_Simple + (Tmp_ID, Tmp_Entry_Index, System.Null_Address); + + POP.Write_Lock (Self_ID); + + if Single_Lock then + POP.Lock_RTS; + end if; + + else + -- This is a situation that this task wakes up receiving + -- an Interrupt and before it gets the lock the Interrupt + -- is blocked. We do not want to lose the interrupt in + -- this case so we regenerate the Interrupt to process + -- level. + + IMOP.Interrupt_Self_Process + (IMNG.Interrupt_ID (Interrupt)); + end if; + end if; + end if; + end if; + + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + System.Tasking.Initialization.Undefer_Abort (Self_ID); + + if Self_ID.Pending_Action then + Initialization.Do_Pending_Action (Self_ID); + end if; + + -- Undefer abort here to allow a window for this task to be aborted + -- at the time of system shutdown. We also explicitly test for + -- Pending_Action in case System.Parameters.No_Abort is True. + + end loop; + end Server_Task; + +-- Elaboration code for package System.Interrupts + +begin + -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent + + Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); + + -- During the elaboration of this package body we want the RTS + -- to inherit the interrupt mask from the Environment Task. + + IMOP.Setup_Interrupt_Mask; + + -- The environment task should have gotten its mask from the enclosing + -- process during the RTS start up. (See processing in s-inmaop.adb). Pass + -- the Interrupt_Mask of the environment task to the Interrupt_Manager. + + -- Note: At this point we know that all tasks are masked for non-reserved + -- signals. Only the Interrupt_Manager will have masks set up differently + -- inheriting the original environment task's mask. + + Interrupt_Manager.Initialize (IMOP.Environment_Mask); +end System.Interrupts; diff --git a/gcc/ada/libgnarl/s-interr.ads b/gcc/ada/libgnarl/s-interr.ads new file mode 100644 index 00000000000..a95d9c4ed6f --- /dev/null +++ b/gcc/ada/libgnarl/s-interr.ads @@ -0,0 +1,278 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This package encapsulates the implementation of interrupt or signal +-- handlers. It is logically an extension of the body of Ada.Interrupts. It +-- is made a child of System to allow visibility of various runtime system +-- internal data and operations. + +-- See System.Interrupt_Management for core interrupt/signal interfaces + +-- These two packages are separated to allow System.Interrupt_Management to be +-- used without requiring the whole tasking implementation to be linked and +-- elaborated. + +with System.Tasking; +with System.Tasking.Protected_Objects.Entries; +with System.OS_Interface; + +package System.Interrupts is + + pragma Elaborate_Body; + -- Comment needed on why this is here ??? + + ------------------------- + -- Constants and types -- + ------------------------- + + Default_Interrupt_Priority : constant System.Interrupt_Priority := + System.Interrupt_Priority'Last; + -- Default value used when a pragma Interrupt_Handler or Attach_Handler is + -- specified without an Interrupt_Priority pragma, see D.3(10). + + type Ada_Interrupt_ID is range 0 .. System.OS_Interface.Max_Interrupt; + -- Avoid inheritance by Ada.Interrupts.Interrupt_ID of unwanted operations + + type Interrupt_ID is range 0 .. System.OS_Interface.Max_Interrupt; + + subtype System_Interrupt_Id is Interrupt_ID; + -- This synonym is introduced so that the type is accessible through + -- rtsfind, otherwise the name clashes with its homonym in Ada.Interrupts. + + type Parameterless_Handler is access protected procedure; + + ---------------------- + -- General services -- + ---------------------- + + -- Attempt to attach a Handler to an Interrupt to which an Entry is + -- already bound will raise a Program_Error. + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean; + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean; + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean; + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler; + + -- Calling the following procedures with New_Handler = null and Static = + -- true means that we want to modify the current handler regardless of the + -- previous handler's binding status. (i.e. we do not care whether it is a + -- dynamic or static handler) + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False); + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False); + + procedure Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean := False); + + function Reference + (Interrupt : Interrupt_ID) return System.Address; + + -------------------------------- + -- Interrupt Entries Services -- + -------------------------------- + + -- Routines needed for Interrupt Entries + + procedure Bind_Interrupt_To_Entry + (T : System.Tasking.Task_Id; + E : System.Tasking.Task_Entry_Index; + Int_Ref : System.Address); + -- Bind the given interrupt to the given entry. If the interrupt is + -- already bound to another entry, Program_Error will be raised. + + procedure Detach_Interrupt_Entries (T : System.Tasking.Task_Id); + -- This procedure detaches all the Interrupt Entries bound to a task + + ------------------------------ + -- POSIX.5 Signals Services -- + ------------------------------ + + -- Routines needed for POSIX dot5 POSIX_Signals + + procedure Block_Interrupt (Interrupt : Interrupt_ID); + -- Block the Interrupt on the process level + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID); + + function Unblocked_By + (Interrupt : Interrupt_ID) return System.Tasking.Task_Id; + -- It returns the ID of the last Task which Unblocked this Interrupt. + -- It returns Null_Task if no tasks have ever requested the Unblocking + -- operation or the Interrupt is currently Blocked. + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean; + -- Comment needed ??? + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID); + -- Set the sigaction for the interrupt to SIG_IGN + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID); + -- Comment needed ??? + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean; + -- Comment needed ??? + + -- Note : Direct calls to sigaction, sigprocmask, thr_sigsetmask, or any + -- other low-level interface that changes the signal action or signal mask + -- needs careful thought. + + -- One may achieve the effect of system calls first making RTS blocked (by + -- calling Block_Interrupt) for the signal under consideration. This will + -- make all the tasks in RTS blocked for the Interrupt. + + ---------------------- + -- Protection Types -- + ---------------------- + + -- Routines and types needed to implement Interrupt_Handler and + -- Attach_Handler. + + -- There are two kinds of protected objects that deal with interrupts: + + -- (1) Only Interrupt_Handler pragmas are used. We need to be able to tell + -- if an Interrupt_Handler applies to a given procedure, so + -- Register_Interrupt_Handler has to be called for all the potential + -- handlers, it should be done by calling Register_Interrupt_Handler with + -- the handler code address. On finalization, which can happen only has + -- part of library level finalization since PO with Interrupt_Handler + -- pragmas can only be declared at library level, nothing special needs to + -- be done since the default handlers have been restored as part of task + -- completion which is done just before global finalization. + -- Dynamic_Interrupt_Protection should be used in this case. + + -- (2) Attach_Handler pragmas are used, and possibly Interrupt_Handler + -- pragma. We need to attach the handlers to the given interrupts when the + -- object is elaborated. This should be done by constructing an array of + -- pairs (interrupt, handler) from the pragmas and calling Install_Handlers + -- with it (types to be used are New_Handler_Item and New_Handler_Array). + -- On finalization, we need to restore the handlers that were installed + -- before the elaboration of the PO, so we need to store these previous + -- handlers. This is also done by Install_Handlers, the room for this + -- information is provided by adding a discriminant which is the number + -- of Attach_Handler pragmas and an array of this size in the protection + -- type, Static_Interrupt_Protection. + + procedure Register_Interrupt_Handler + (Handler_Addr : System.Address); + -- This routine should be called by the compiler to allow the handler be + -- used as an Interrupt Handler. That means call this procedure for each + -- pragma Interrupt_Handler providing the address of the handler (not + -- including the pointer to the actual PO, this way this routine is called + -- only once for each type definition of PO). + + type Static_Handler_Index is range 0 .. Integer'Last; + subtype Positive_Static_Handler_Index is + Static_Handler_Index range 1 .. Static_Handler_Index'Last; + -- Comment needed ??? + + type Previous_Handler_Item is record + Interrupt : Interrupt_ID; + Handler : Parameterless_Handler; + Static : Boolean; + end record; + -- Contains all the information needed to restore a previous handler + + type Previous_Handler_Array is array + (Positive_Static_Handler_Index range <>) of Previous_Handler_Item; + + type New_Handler_Item is record + Interrupt : Interrupt_ID; + Handler : Parameterless_Handler; + end record; + -- Contains all the information from an Attach_Handler pragma + + type New_Handler_Array is + array (Positive_Static_Handler_Index range <>) of New_Handler_Item; + -- Comment needed ??? + + -- Case (1) + + type Dynamic_Interrupt_Protection is new + Tasking.Protected_Objects.Entries.Protection_Entries with null record; + + -- ??? Finalize is not overloaded since we currently have no + -- way to detach the handlers during library level finalization. + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) return Boolean; + -- Returns True + + -- Case (2) + + type Static_Interrupt_Protection + (Num_Entries : Tasking.Protected_Objects.Protected_Entry_Index; + Num_Attach_Handler : Static_Handler_Index) + is new + Tasking.Protected_Objects.Entries.Protection_Entries (Num_Entries) with + record + Previous_Handlers : Previous_Handler_Array (1 .. Num_Attach_Handler); + end record; + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) return Boolean; + -- Returns True + + overriding procedure Finalize (Object : in out Static_Interrupt_Protection); + -- Restore previous handlers as required by C.3.1(12) then call + -- Finalize (Protection). + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : New_Handler_Array); + -- Store the old handlers in Object.Previous_Handlers and install + -- the new static handlers. + + procedure Install_Restricted_Handlers + (Prio : Any_Priority; + Handlers : New_Handler_Array); + -- Install the static Handlers for the given interrupts and do not + -- store previously installed handlers. This procedure is used when + -- the Ravenscar restrictions are in place since in that case there + -- are only library-level protected handlers that will be installed + -- at initialization and never be replaced. + +end System.Interrupts; 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-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-intman.ads b/gcc/ada/libgnarl/s-intman.ads new file mode 100644 index 00000000000..979dbfe2169 --- /dev/null +++ b/gcc/ada/libgnarl/s-intman.ads @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 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; + + -- 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 : Interrupt_ID; + -- The interrupt that is used to implement task abort if an interrupt is + -- used for that purpose. This is one of the reserved interrupts. + + Keep_Unmasked : Interrupt_Set := (others => False); + -- Keep_Unmasked (I) is true iff the interrupt I is one that must be kept + -- unmasked at all times, except (perhaps) for short critical sections. + -- This includes interrupts that are mapped to exceptions (see + -- System.Interrupt_Exceptions.Is_Exception), but may also include + -- interrupts (e.g. timer) that need to be kept unmasked for other + -- reasons. Where interrupts are implemented as OS signals, and signal + -- masking is per-task, the interrupt should be unmasked in ALL TASKS. + + Reserve : Interrupt_Set := (others => False); + -- Reserve (I) is true iff the interrupt I is one that cannot be permitted + -- to be attached to a user handler. The possible reasons are many. For + -- example, it may be mapped to an exception used to implement task abort, + -- or used to implement time delays. + + procedure Initialize; + -- Initialize the various variables defined in this package. This procedure + -- must be called before accessing any object from this package, and can be + -- called multiple times. + +private + type Interrupt_Mask is new System.OS_Interface.sigset_t; + -- In some implementations Interrupt_Mask is represented as a linked list + + procedure Adjust_Context_For_Raise + (Signo : System.OS_Interface.Signal; + Ucontext : System.Address); + pragma Import + (C, Adjust_Context_For_Raise, "__gnat_adjust_context_for_raise"); + -- Target specific hook performing adjustments to the signal's machine + -- context, to be called before an exception may be raised from a signal + -- handler. This service is provided by init.c, together with the + -- non-tasking signal handler. + +end System.Interrupt_Management; 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-linux.ads b/gcc/ada/libgnarl/s-linux.ads new file mode 100644 index 00000000000..09227c6acc7 --- /dev/null +++ b/gcc/ada/libgnarl/s-linux.ads @@ -0,0 +1,127 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 default version of this package + +-- This package encapsulates cpu specific differences between implementations +-- of GNU/Linux, in order to share s-osinte-linux.ads. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package + +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 := 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 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-mudido.adb b/gcc/ada/libgnarl/s-mudido.adb new file mode 100644 index 00000000000..0bcfcafc889 --- /dev/null +++ b/gcc/ada/libgnarl/s-mudido.adb @@ -0,0 +1,175 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 unimplemented targets, where the operating system does not +-- support setting task affinities. + +package body System.Multiprocessors.Dispatching_Domains is + + ----------------------- + -- Local subprograms -- + ----------------------- + + 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 + pragma Unreferenced (Domain, CPU, T); + begin + raise Dispatching_Domain_Error with "dispatching domains not supported"; + end Assign_Task; + + ------------ + -- Create -- + ------------ + + function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain is + pragma Unreferenced (First, Last); + begin + return raise Dispatching_Domain_Error with + "dispatching domains not supported"; + end Create; + + function Create (Set : CPU_Set) return Dispatching_Domain is + pragma Unreferenced (Set); + begin + return raise Dispatching_Domain_Error with + "dispatching domains not supported"; + end Create; + + ----------------------------- + -- Delay_Until_And_Set_CPU -- + ----------------------------- + + procedure Delay_Until_And_Set_CPU + (Delay_Until_Time : Ada.Real_Time.Time; + CPU : CPU_Range) + is + pragma Unreferenced (Delay_Until_Time, CPU); + begin + raise Dispatching_Domain_Error with "dispatching domains not supported"; + end Delay_Until_And_Set_CPU; + + -------------------------------- + -- Freeze_Dispatching_Domains -- + -------------------------------- + + procedure Freeze_Dispatching_Domains is + begin + null; + end Freeze_Dispatching_Domains; + + ------------- + -- Get_CPU -- + ------------- + + function Get_CPU + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return CPU_Range + is + pragma Unreferenced (T); + begin + return Not_A_Specific_CPU; + end Get_CPU; + + ----------------- + -- Get_CPU_Set -- + ----------------- + + function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is + pragma Unreferenced (Domain); + begin + return raise Dispatching_Domain_Error + with "dispatching domains not supported"; + 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 + pragma Unreferenced (T); + begin + return System_Dispatching_Domain; + end Get_Dispatching_Domain; + + ------------------- + -- Get_First_CPU -- + ------------------- + + function Get_First_CPU (Domain : Dispatching_Domain) return CPU is + pragma Unreferenced (Domain); + begin + return CPU'First; + end Get_First_CPU; + + ------------------ + -- Get_Last_CPU -- + ------------------ + + function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is + pragma Unreferenced (Domain); + begin + return Number_Of_CPUs; + end Get_Last_CPU; + + ------------- + -- Set_CPU -- + ------------- + + procedure Set_CPU + (CPU : CPU_Range; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) + is + pragma Unreferenced (CPU, T); + begin + raise Dispatching_Domain_Error with "dispatching domains not supported"; + end Set_CPU; + +end System.Multiprocessors.Dispatching_Domains; diff --git a/gcc/ada/libgnarl/s-mudido.ads b/gcc/ada/libgnarl/s-mudido.ads new file mode 100644 index 00000000000..06e48bd1b9c --- /dev/null +++ b/gcc/ada/libgnarl/s-mudido.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Real_Time; + +with Ada.Task_Identification; + +private with System.Tasking; + +package System.Multiprocessors.Dispatching_Domains is + -- pragma Preelaborate (Dispatching_Domains); + -- ??? According to AI 167 this unit should be preelaborate, but it cannot + -- be preelaborate because it depends on Ada.Real_Time which is not + -- preelaborate. + + Dispatching_Domain_Error : exception; + + type Dispatching_Domain (<>) is limited private; + + System_Dispatching_Domain : constant Dispatching_Domain; + + function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain; + + function Get_First_CPU (Domain : Dispatching_Domain) return CPU; + + function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range; + + type CPU_Set is array (CPU range <>) of Boolean; + + function Create (Set : CPU_Set) return Dispatching_Domain; + + function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set; + + function Get_Dispatching_Domain + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return Dispatching_Domain; + + 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); + + procedure Set_CPU + (CPU : CPU_Range; + T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + + function Get_CPU + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return CPU_Range; + + procedure Delay_Until_And_Set_CPU + (Delay_Until_Time : Ada.Real_Time.Time; + CPU : CPU_Range); + +private + type Dispatching_Domain is new System.Tasking.Dispatching_Domain_Access; + + System_Dispatching_Domain : constant Dispatching_Domain := + Dispatching_Domain + (System.Tasking.System_Domain); +end System.Multiprocessors.Dispatching_Domains; 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-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-proinf.adb b/gcc/ada/libgnarl/s-proinf.adb new file mode 100644 index 00000000000..67a24b9b6b8 --- /dev/null +++ b/gcc/ada/libgnarl/s-proinf.adb @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P R O G R A M _ I N F O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-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. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Program_Info is + + Default_Stack_Size : constant := 10000; + + function Default_Task_Stack return Integer is + begin + return Default_Stack_Size; + end Default_Task_Stack; + +end System.Program_Info; diff --git a/gcc/ada/libgnarl/s-proinf.ads b/gcc/ada/libgnarl/s-proinf.ads new file mode 100644 index 00000000000..75c8cf44334 --- /dev/null +++ b/gcc/ada/libgnarl/s-proinf.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P R O G R A M _ I N F O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-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 used as parameters +-- to the run-time system at program startup. + +package System.Program_Info is + pragma Preelaborate; + + function Default_Task_Stack return Integer; + -- The default stack size for each created thread. This default value + -- can be overridden on a per-task basis by the language-defined + -- Storage_Size pragma. + +end System.Program_Info; diff --git a/gcc/ada/libgnarl/s-solita.adb b/gcc/ada/libgnarl/s-solita.adb new file mode 100644 index 00000000000..bb38578b06f --- /dev/null +++ b/gcc/ada/libgnarl/s-solita.adb @@ -0,0 +1,232 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S O F T _ L I N K S . T A S K I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram alpha ordering check, since we group soft link bodies +-- and dummy soft link bodies together separately in this unit. + +pragma Polling (Off); +-- Turn polling off for this package. We don't need polling during any of the +-- routines in this package, and more to the point, if we try to poll it can +-- cause infinite loops. + +with Ada.Exceptions; +with Ada.Exceptions.Is_Null_Occurrence; + +with System.Task_Primitives.Operations; +with System.Tasking; +with System.Stack_Checking; + +package body System.Soft_Links.Tasking is + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + + use Ada.Exceptions; + + use type System.Tasking.Task_Id; + use type System.Tasking.Termination_Handler; + + ---------------- + -- Local Data -- + ---------------- + + Initialized : Boolean := False; + -- Boolean flag that indicates whether the tasking soft links have + -- already been set. + + ----------------------------------------------------------------- + -- Tasking Versions of Services Needed by Non-Tasking Programs -- + ----------------------------------------------------------------- + + function Get_Jmpbuf_Address return Address; + procedure Set_Jmpbuf_Address (Addr : Address); + -- Get/Set Jmpbuf_Address for current task + + function Get_Sec_Stack_Addr return Address; + procedure Set_Sec_Stack_Addr (Addr : Address); + -- Get/Set location of current task's secondary stack + + procedure Timed_Delay_T (Time : Duration; Mode : Integer); + -- Task-safe version of SSL.Timed_Delay + + procedure Task_Termination_Handler_T (Excep : SSL.EO); + -- Task-safe version of the task termination procedure + + function Get_Stack_Info return Stack_Checking.Stack_Access; + -- Get access to the current task's Stack_Info + + -------------------------- + -- Soft-Link Get Bodies -- + -------------------------- + + function Get_Jmpbuf_Address return Address is + begin + return STPO.Self.Common.Compiler_Data.Jmpbuf_Address; + end Get_Jmpbuf_Address; + + function Get_Sec_Stack_Addr return Address is + begin + return Result : constant Address := + STPO.Self.Common.Compiler_Data.Sec_Stack_Addr + do + pragma Assert (Result /= Null_Address); + end return; + end Get_Sec_Stack_Addr; + + function Get_Stack_Info return Stack_Checking.Stack_Access is + begin + return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access; + end Get_Stack_Info; + + -------------------------- + -- Soft-Link Set Bodies -- + -------------------------- + + procedure Set_Jmpbuf_Address (Addr : Address) is + begin + STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr; + end Set_Jmpbuf_Address; + + procedure Set_Sec_Stack_Addr (Addr : Address) is + begin + STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr; + end Set_Sec_Stack_Addr; + + ------------------- + -- Timed_Delay_T -- + ------------------- + + procedure Timed_Delay_T (Time : Duration; Mode : Integer) is + Self_Id : constant System.Tasking.Task_Id := STPO.Self; + + begin + -- In case pragma Detect_Blocking is active then Program_Error + -- must be raised if this potentially blocking operation + -- is called from a protected operation. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + else + Abort_Defer.all; + STPO.Timed_Delay (Self_Id, Time, Mode); + Abort_Undefer.all; + end if; + end Timed_Delay_T; + + -------------------------------- + -- Task_Termination_Handler_T -- + -------------------------------- + + procedure Task_Termination_Handler_T (Excep : SSL.EO) is + Self_Id : constant System.Tasking.Task_Id := STPO.Self; + Cause : System.Tasking.Cause_Of_Termination; + EO : Ada.Exceptions.Exception_Occurrence; + + begin + -- We can only be here because we are terminating the environment task. + -- Task termination for all other tasks is handled in the Task_Wrapper. + + -- We do not want to enable this check and e.g. call System.OS_Lib.Abort + -- here because some restricted run-times may not have System.OS_Lib + -- and calling abort may do more harm than good to the main application. + + pragma Assert (Self_Id = STPO.Environment_Task); + + -- Normal task termination + + if Is_Null_Occurrence (Excep) then + Cause := System.Tasking.Normal; + Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); + + -- Abnormal task termination + + elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then + Cause := System.Tasking.Abnormal; + Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); + + -- Termination because of an unhandled exception + + else + Cause := System.Tasking.Unhandled_Exception; + Ada.Exceptions.Save_Occurrence (EO, Excep); + end if; + + -- There is no need for explicit protection against race conditions for + -- this part because it can only be executed by the environment task + -- after all the other tasks have been finalized. Note that there is no + -- fall-back handler which could apply to this environment task because + -- it has no parents, and, as specified in ARM C.7.3 par. 9/2, "the + -- fall-back handler applies only to the dependent tasks of the task". + + if Self_Id.Common.Specific_Handler /= null then + Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO); + end if; + end Task_Termination_Handler_T; + + ----------------------------- + -- Init_Tasking_Soft_Links -- + ----------------------------- + + procedure Init_Tasking_Soft_Links is + begin + -- Set links only if not set already + + if not Initialized then + + -- Mark tasking soft links as initialized + + Initialized := True; + + -- The application being executed uses tasking so that the tasking + -- version of the following soft links need to be used. + + SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access; + SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access; + SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access; + SSL.Get_Stack_Info := Get_Stack_Info'Access; + SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access; + SSL.Timed_Delay := Timed_Delay_T'Access; + SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access; + + -- No need to create a new secondary stack, since we will use the + -- default one created in s-secsta.adb. + + SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT); + SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT); + end if; + + pragma Assert (Get_Sec_Stack_Addr /= Null_Address); + end Init_Tasking_Soft_Links; + +end System.Soft_Links.Tasking; diff --git a/gcc/ada/libgnarl/s-solita.ads b/gcc/ada/libgnarl/s-solita.ads new file mode 100644 index 00000000000..f0f1e4fa4b7 --- /dev/null +++ b/gcc/ada/libgnarl/s-solita.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S O F T _ L I N K S . T A S K I N G -- +-- -- +-- S p e c -- +-- -- +-- 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 package contains the tasking versions soft links that are common +-- to the full and the restricted run times. The rest of the required soft +-- links are set by System.Tasking.Initialization and System.Tasking.Stages +-- (full run time) or System.Tasking.Restricted.Stages (restricted run time). + +package System.Soft_Links.Tasking is + + procedure Init_Tasking_Soft_Links; + -- Set the tasking soft links that are common to the full and the + -- restricted run times. Clients need to make sure the body of + -- System.Secondary_Stack is elaborated before calling this. + +end System.Soft_Links.Tasking; diff --git a/gcc/ada/libgnarl/s-stusta.adb b/gcc/ada/libgnarl/s-stusta.adb new file mode 100644 index 00000000000..ebe307bd533 --- /dev/null +++ b/gcc/ada/libgnarl/s-stusta.adb @@ -0,0 +1,258 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ U S A G E . T A S K I N G -- +-- -- +-- 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Stack_Usage; + +-- This is why this package is part of GNARL: + +with System.Tasking.Debug; +with System.Task_Primitives.Operations; + +with System.IO; + +package body System.Stack_Usage.Tasking is + use System.IO; + + procedure Report_For_Task (Id : System.Tasking.Task_Id); + -- A generic procedure calculating stack usage for a given task + + procedure Compute_All_Tasks; + -- Compute the stack usage for all tasks and saves it in + -- System.Stack_Usage.Result_Array + + procedure Compute_Current_Task; + -- Compute the stack usage for a given task and saves it in the precise + -- slot in System.Stack_Usage.Result_Array; + + procedure Report_Impl (All_Tasks : Boolean; Do_Print : Boolean); + -- Report the stack usage of either all tasks (All_Tasks = True) or of the + -- current task (All_Task = False). If Print is True, then results are + -- printed on stderr + + procedure Convert + (TS : System.Stack_Usage.Task_Result; + Res : out Stack_Usage_Result); + -- Convert an object of type System.Stack_Usage in a Stack_Usage_Result + + ------------- + -- Convert -- + ------------- + + procedure Convert + (TS : System.Stack_Usage.Task_Result; + Res : out Stack_Usage_Result) is + begin + Res := TS; + end Convert; + + --------------------- + -- Report_For_Task -- + --------------------- + + procedure Report_For_Task (Id : System.Tasking.Task_Id) is + begin + System.Stack_Usage.Compute_Result (Id.Common.Analyzer); + System.Stack_Usage.Report_Result (Id.Common.Analyzer); + end Report_For_Task; + + ----------------------- + -- Compute_All_Tasks -- + ----------------------- + + procedure Compute_All_Tasks is + Id : System.Tasking.Task_Id; + use type System.Tasking.Task_Id; + begin + if not System.Stack_Usage.Is_Enabled then + Put_Line ("Stack Usage not enabled: bind with -uNNN switch"); + else + + -- Loop over all tasks + + for J in System.Tasking.Debug.Known_Tasks'First + 1 + .. System.Tasking.Debug.Known_Tasks'Last + loop + Id := System.Tasking.Debug.Known_Tasks (J); + exit when Id = null; + + -- Calculate the task usage for a given task + + Report_For_Task (Id); + end loop; + + end if; + end Compute_All_Tasks; + + -------------------------- + -- Compute_Current_Task -- + -------------------------- + + procedure Compute_Current_Task is + begin + if not System.Stack_Usage.Is_Enabled then + Put_Line ("Stack Usage not enabled: bind with -uNNN switch"); + else + + -- The current task + + Report_For_Task (System.Tasking.Self); + + end if; + end Compute_Current_Task; + + ----------------- + -- Report_Impl -- + ----------------- + + procedure Report_Impl (All_Tasks : Boolean; Do_Print : Boolean) is + begin + + -- Lock the runtime + + System.Task_Primitives.Operations.Lock_RTS; + + -- Calculate results + + if All_Tasks then + Compute_All_Tasks; + else + Compute_Current_Task; + end if; + + -- Output results + if Do_Print then + System.Stack_Usage.Output_Results; + end if; + + -- Unlock the runtime + + System.Task_Primitives.Operations.Unlock_RTS; + + end Report_Impl; + + --------------------- + -- Report_All_Task -- + --------------------- + + procedure Report_All_Tasks is + begin + Report_Impl (True, True); + end Report_All_Tasks; + + ------------------------- + -- Report_Current_Task -- + ------------------------- + + procedure Report_Current_Task is + Res : Stack_Usage_Result; + begin + Res := Get_Current_Task_Usage; + Print (Res); + end Report_Current_Task; + + ------------------------- + -- Get_All_Tasks_Usage -- + ------------------------- + + function Get_All_Tasks_Usage return Stack_Usage_Result_Array is + Res : Stack_Usage_Result_Array + (1 .. System.Stack_Usage.Result_Array'Length); + begin + Report_Impl (True, False); + + for J in Res'Range loop + Convert (System.Stack_Usage.Result_Array (J), Res (J)); + end loop; + + return Res; + end Get_All_Tasks_Usage; + + ---------------------------- + -- Get_Current_Task_Usage -- + ---------------------------- + + function Get_Current_Task_Usage return Stack_Usage_Result is + Res : Stack_Usage_Result; + Original : System.Stack_Usage.Task_Result; + Found : Boolean := False; + begin + + Report_Impl (False, False); + + -- Look for the task info in System.Stack_Usage.Result_Array; + -- the search is based on task name + + for T in System.Stack_Usage.Result_Array'Range loop + if System.Stack_Usage.Result_Array (T).Task_Name = + System.Tasking.Self.Common.Analyzer.Task_Name + then + Original := System.Stack_Usage.Result_Array (T); + Found := True; + exit; + end if; + end loop; + + -- Be sure a task has been found + + pragma Assert (Found); + + Convert (Original, Res); + return Res; + end Get_Current_Task_Usage; + + ----------- + -- Print -- + ----------- + + procedure Print (Obj : Stack_Usage_Result) is + Pos : Positive := Obj.Task_Name'Last; + + begin + -- Simply trim the string containing the task name + + for S in Obj.Task_Name'Range loop + if Obj.Task_Name (S) = ' ' then + Pos := S; + exit; + end if; + end loop; + + declare + T_Name : constant String := + Obj.Task_Name (Obj.Task_Name'First .. Pos); + begin + Put_Line + ("| " & T_Name & " | " & Natural'Image (Obj.Stack_Size) & + Natural'Image (Obj.Value)); + end; + end Print; + +end System.Stack_Usage.Tasking; diff --git a/gcc/ada/libgnarl/s-stusta.ads b/gcc/ada/libgnarl/s-stusta.ads new file mode 100644 index 00000000000..0d9a62e37ab --- /dev/null +++ b/gcc/ada/libgnarl/s-stusta.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ U S A G E . T A S K I N G -- +-- -- +-- S p e c -- +-- -- +-- 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides exported subprograms to be called at debug time to +-- measure stack usage at run-time. + +-- Note: this package must be a child package of System.Stack_Usage to have +-- visibility over its private part; it is however part of GNARL because it +-- needs to access tasking features via System.Tasking.Debug and +-- System.Task_Primitives.Operations; + +package System.Stack_Usage.Tasking is + + procedure Report_All_Tasks; + -- Print the current stack usage of all tasks on stderr. Exported to be + -- called also in debug mode. + + pragma Export + (C, + Report_All_Tasks, + "__gnat_tasks_stack_usage_report_all_tasks"); + + procedure Report_Current_Task; + -- Print the stack usage of current task on stderr. Exported to be called + -- also in debug mode. + + pragma Export + (C, + Report_Current_Task, + "__gnat_tasks_stack_usage_report_current_task"); + + subtype Stack_Usage_Result is System.Stack_Usage.Task_Result; + -- This type is a descriptor for task stack usage result + + type Stack_Usage_Result_Array is + array (Positive range <>) of Stack_Usage_Result; + + function Get_Current_Task_Usage return Stack_Usage_Result; + -- Return the current stack usage for the invoking task + + function Get_All_Tasks_Usage return Stack_Usage_Result_Array; + -- Return an array containing the stack usage results for all tasks + + procedure Print (Obj : Stack_Usage_Result); + -- Print Obj on stderr + +end System.Stack_Usage.Tasking; diff --git a/gcc/ada/libgnarl/s-taasde.adb b/gcc/ada/libgnarl/s-taasde.adb new file mode 100644 index 00000000000..cab0be7b13e --- /dev/null +++ b/gcc/ada/libgnarl/s-taasde.adb @@ -0,0 +1,395 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y 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. -- +-- -- +------------------------------------------------------------------------------ + +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 Ada.Task_Identification; + +with System.Task_Primitives.Operations; +with System.Tasking.Utilities; +with System.Tasking.Initialization; +with System.Tasking.Debug; +with System.OS_Primitives; +with System.Interrupt_Management.Operations; + +package body System.Tasking.Async_Delays is + + package STPO renames System.Task_Primitives.Operations; + package ST renames System.Tasking; + package STU renames System.Tasking.Utilities; + package STI renames System.Tasking.Initialization; + package OSP renames System.OS_Primitives; + + use Parameters; + + function To_System is new Ada.Unchecked_Conversion + (Ada.Task_Identification.Task_Id, Task_Id); + + Timer_Attention : Boolean := False; + pragma Atomic (Timer_Attention); + + task Timer_Server is + pragma Interrupt_Priority (System.Any_Priority'Last); + end Timer_Server; + + Timer_Server_ID : constant ST.Task_Id := To_System (Timer_Server'Identity); + + -- The timer queue is a circular doubly linked list, ordered by absolute + -- wakeup time. The first item in the queue is Timer_Queue.Succ. + -- It is given a Resume_Time that is larger than any legitimate wakeup + -- time, so that the ordered insertion will always stop searching when it + -- gets back to the queue header block. + + Timer_Queue : aliased Delay_Block; + + package Init_Timer_Queue is end Init_Timer_Queue; + pragma Unreferenced (Init_Timer_Queue); + -- Initialize the Timer_Queue. This is a package to work around the + -- fact that statements are syntactically illegal here. We want this + -- initialization to happen before the Timer_Server is activated. A + -- build-in-place function would also work, but that's not supported + -- on all platforms (e.g. cil). + + package body Init_Timer_Queue is + begin + Timer_Queue.Succ := Timer_Queue'Unchecked_Access; + Timer_Queue.Pred := Timer_Queue'Unchecked_Access; + Timer_Queue.Resume_Time := Duration'Last; + end Init_Timer_Queue; + + ------------------------ + -- Cancel_Async_Delay -- + ------------------------ + + -- This should (only) be called from the compiler-generated cleanup routine + -- for an async. select statement with delay statement as trigger. The + -- effect should be to remove the delay from the timer queue, and exit one + -- ATC nesting level. + -- The usage and logic are similar to Cancel_Protected_Entry_Call, but + -- simplified because this is not a true entry call. + + procedure Cancel_Async_Delay (D : Delay_Block_Access) is + Dpred : Delay_Block_Access; + Dsucc : Delay_Block_Access; + + begin + -- Note that we mark the delay as being cancelled + -- using a level value that is reserved. + + -- make this operation idempotent + + if D.Level = ATC_Level_Infinity then + return; + end if; + + D.Level := ATC_Level_Infinity; + + -- remove self from timer queue + + STI.Defer_Abort_Nestable (D.Self_Id); + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Timer_Server_ID); + Dpred := D.Pred; + Dsucc := D.Succ; + Dpred.Succ := Dsucc; + Dsucc.Pred := Dpred; + D.Succ := D; + D.Pred := D; + STPO.Unlock (Timer_Server_ID); + + -- Note that the above deletion code is required to be + -- idempotent, since the block may have been dequeued + -- previously by the Timer_Server. + + -- leave the asynchronous select + + STPO.Write_Lock (D.Self_Id); + STU.Exit_One_ATC_Level (D.Self_Id); + STPO.Unlock (D.Self_Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + STI.Undefer_Abort_Nestable (D.Self_Id); + end Cancel_Async_Delay; + + ---------------------- + -- Enqueue_Duration -- + ---------------------- + + function Enqueue_Duration + (T : Duration; + D : Delay_Block_Access) return Boolean + is + begin + if T <= 0.0 then + D.Timed_Out := True; + STPO.Yield; + return False; + + else + -- The corresponding call to Undefer_Abort is performed by the + -- expanded code (see exp_ch9). + + STI.Defer_Abort (STPO.Self); + Time_Enqueue + (STPO.Monotonic_Clock + + Duration'Min (T, OSP.Max_Sensible_Delay), D); + return True; + end if; + end Enqueue_Duration; + + ------------------ + -- Time_Enqueue -- + ------------------ + + -- Allocate a queue element for the wakeup time T and put it in the + -- queue in wakeup time order. Assume we are on an asynchronous + -- select statement with delay trigger. Put the calling task to + -- sleep until either the delay expires or is cancelled. + + -- We use one entry call record for this delay, since we have + -- to increment the ATC nesting level, but since it is not a + -- real entry call we do not need to use any of the fields of + -- the call record. The following code implements a subset of + -- the actions for the asynchronous case of Protected_Entry_Call, + -- much simplified since we know this never blocks, and does not + -- have the full semantics of a protected entry call. + + procedure Time_Enqueue + (T : Duration; + D : Delay_Block_Access) + is + Self_Id : constant Task_Id := STPO.Self; + Q : Delay_Block_Access; + + begin + pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P')); + pragma Assert (Self_Id.Deferral_Level = 1, + "async delay from within abort-deferred region"); + + if Self_Id.ATC_Nesting_Level = ATC_Level'Last then + raise Storage_Error with "not enough ATC nesting levels"; + end if; + + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + + pragma Debug + (Debug.Trace (Self_Id, "ASD: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + + D.Level := Self_Id.ATC_Nesting_Level; + D.Self_Id := Self_Id; + D.Resume_Time := T; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Timer_Server_ID); + + -- Previously, there was code here to dynamically create + -- the Timer_Server task, if one did not already exist. + -- That code had a timing window that could allow multiple + -- timer servers to be created. Luckily, the need for + -- postponing creation of the timer server should now be + -- gone, since this package will only be linked in if + -- there are calls to enqueue calls on the timer server. + + -- Insert D in the timer queue, at the position determined + -- by the wakeup time T. + + Q := Timer_Queue.Succ; + + while Q.Resume_Time < T loop + Q := Q.Succ; + end loop; + + -- Q is the block that has Resume_Time equal to or greater than + -- T. After the insertion we want Q to be the successor of D. + + D.Succ := Q; + D.Pred := Q.Pred; + D.Pred.Succ := D; + Q.Pred := D; + + -- If the new element became the head of the queue, + -- signal the Timer_Server to wake up. + + if Timer_Queue.Succ = D then + Timer_Attention := True; + STPO.Wakeup (Timer_Server_ID, ST.Timer_Server_Sleep); + end if; + + STPO.Unlock (Timer_Server_ID); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end Time_Enqueue; + + --------------- + -- Timed_Out -- + --------------- + + function Timed_Out (D : Delay_Block_Access) return Boolean is + begin + return D.Timed_Out; + end Timed_Out; + + ------------------ + -- Timer_Server -- + ------------------ + + task body Timer_Server is + Ignore : constant Boolean := STU.Make_Independent; + + -- Local Declarations + + Next_Wakeup_Time : Duration := Duration'Last; + Timedout : Boolean; + Yielded : Boolean; + Now : Duration; + Dequeued : Delay_Block_Access; + Dequeued_Task : Task_Id; + + pragma Unreferenced (Timedout, Yielded); + + begin + pragma Assert (Timer_Server_ID = STPO.Self); + + -- Since this package may be elaborated before System.Interrupt, + -- we need to call Setup_Interrupt_Mask explicitly to ensure that + -- this task has the proper signal mask. + + Interrupt_Management.Operations.Setup_Interrupt_Mask; + + -- Initialize the timer queue to empty, and make the wakeup time of the + -- header node be larger than any real wakeup time we will ever use. + + loop + STI.Defer_Abort (Timer_Server_ID); + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Timer_Server_ID); + + -- The timer server needs to catch pending aborts after finalization + -- of library packages. If it doesn't poll for it, the server will + -- sometimes hang. + + if not Timer_Attention then + Timer_Server_ID.Common.State := ST.Timer_Server_Sleep; + + if Next_Wakeup_Time = Duration'Last then + Timer_Server_ID.User_State := 1; + Next_Wakeup_Time := + STPO.Monotonic_Clock + OSP.Max_Sensible_Delay; + + else + Timer_Server_ID.User_State := 2; + end if; + + STPO.Timed_Sleep + (Timer_Server_ID, Next_Wakeup_Time, + OSP.Absolute_RT, ST.Timer_Server_Sleep, + Timedout, Yielded); + Timer_Server_ID.Common.State := ST.Runnable; + end if; + + -- Service all of the wakeup requests on the queue whose times have + -- been reached, and update Next_Wakeup_Time to next wakeup time + -- after that (the wakeup time of the head of the queue if any, else + -- a time far in the future). + + Timer_Server_ID.User_State := 3; + Timer_Attention := False; + + Now := STPO.Monotonic_Clock; + while Timer_Queue.Succ.Resume_Time <= Now loop + + -- Dequeue the waiting task from the front of the queue + + pragma Debug (System.Tasking.Debug.Trace + (Timer_Server_ID, "Timer service: waking up waiting task", 'E')); + + Dequeued := Timer_Queue.Succ; + Timer_Queue.Succ := Dequeued.Succ; + Dequeued.Succ.Pred := Dequeued.Pred; + Dequeued.Succ := Dequeued; + Dequeued.Pred := Dequeued; + + -- We want to abort the queued task to the level of the async. + -- select statement with the delay. To do that, we need to lock + -- the ATCB of that task, but to avoid deadlock we need to release + -- the lock of the Timer_Server. This leaves a window in which + -- another task might perform an enqueue or dequeue operation on + -- the timer queue, but that is OK because we always restart the + -- next iteration at the head of the queue. + + STPO.Unlock (Timer_Server_ID); + STPO.Write_Lock (Dequeued.Self_Id); + Dequeued_Task := Dequeued.Self_Id; + Dequeued.Timed_Out := True; + STI.Locked_Abort_To_Level + (Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1); + STPO.Unlock (Dequeued_Task); + STPO.Write_Lock (Timer_Server_ID); + end loop; + + Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time; + + -- Service returns the Next_Wakeup_Time. + -- The Next_Wakeup_Time is either an infinity (no delay request) + -- or the wakeup time of the queue head. This value is used for + -- an actual delay in this server. + + STPO.Unlock (Timer_Server_ID); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + STI.Undefer_Abort (Timer_Server_ID); + end loop; + end Timer_Server; + +end System.Tasking.Async_Delays; diff --git a/gcc/ada/libgnarl/s-taasde.ads b/gcc/ada/libgnarl/s-taasde.ads new file mode 100644 index 00000000000..db5b6255f8b --- /dev/null +++ b/gcc/ada/libgnarl/s-taasde.ads @@ -0,0 +1,147 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y 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 package contains the procedures to implements timeouts (delays) for +-- asynchronous select statements. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +package System.Tasking.Async_Delays is + + -- Suppose the following source code is given: + + -- select delay When; + -- ...continuation for timeout case... + -- then abort + -- ...abortable part... + -- end select; + + -- The compiler should expand this to the following: + + -- declare + -- DB : aliased Delay_Block; + -- begin + -- if System.Tasking.Async_Delays.Enqueue_Duration + -- (When, DB'Unchecked_Access) + -- then + -- begin + -- A101b : declare + -- procedure _clean is + -- begin + -- System.Tasking.Async_Delays.Cancel_Async_Delay + -- (DB'Unchecked_Access); + -- return; + -- end _clean; + -- begin + -- abort_undefer.all; + -- ...abortable part... + -- exception + -- when all others => + -- declare + -- E105b : exception_occurrence; + -- begin + -- save_occurrence (E105b, get_current_excep.all.all); + -- _clean; + -- reraise_occurrence_no_defer (E105b); + -- end; + -- at end + -- _clean; + -- end A101b; + -- exception + -- when _abort_signal => + -- abort_undefer.all; + -- end; + -- end if; + + -- if Timed_Out (DB'Unchecked_Access) then + -- ...continuation for timeout case... + -- end if; + -- end; + + ----------------- + -- Delay_Block -- + ----------------- + + type Delay_Block is limited private; + type Delay_Block_Access is access all Delay_Block; + + function Enqueue_Duration + (T : Duration; + D : Delay_Block_Access) return Boolean; + -- Enqueue the specified relative delay. Returns True if the delay has + -- been enqueued, False if it has already expired. If the delay has been + -- enqueued, abort is deferred. + + procedure Cancel_Async_Delay (D : Delay_Block_Access); + -- Cancel the specified asynchronous delay + + function Timed_Out (D : Delay_Block_Access) return Boolean; + pragma Inline (Timed_Out); + -- Return True if the delay specified in D has timed out + + -- There are child units for delays on Ada.Calendar.Time/Ada.Real_Time.Time + -- so that an application need not link in features that it is not using. + +private + + type Delay_Block is limited record + Self_Id : Task_Id; + -- ID of the calling task + + Level : ATC_Level_Base; + -- Normally Level is the ATC nesting level of the asynchronous select + -- statement to which this delay belongs, but after a call has been + -- dequeued we set it to ATC_Level_Infinity so that the Cancel operation + -- can detect repeated calls, and act idempotently. + + Resume_Time : Duration; + -- The absolute wake up time, represented as Duration + + Timed_Out : Boolean := False; + -- Set to true if the delay has timed out + + Succ, Pred : Delay_Block_Access; + -- A double linked list + end record; + + -- The above "overlaying" of Self_Id and Level to hold other data that has + -- a non-overlapping lifetime is an unabashed hack to save memory. + + procedure Time_Enqueue + (T : Duration; + D : Delay_Block_Access); + pragma Inline (Time_Enqueue); + -- Used by the child units to enqueue delays on the timer queue implemented + -- in the body of this package. T denotes a point in time as the duration + -- elapsed since the epoch of the Ada real-time clock. + +end System.Tasking.Async_Delays; diff --git a/gcc/ada/libgnarl/s-tadeca.adb b/gcc/ada/libgnarl/s-tadeca.adb new file mode 100644 index 00000000000..f0d81cba9ec --- /dev/null +++ b/gcc/ada/libgnarl/s-tadeca.adb @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_CALENDAR -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar.Delays; + +with System.OS_Constants; +with System.OS_Primitives; +with System.Task_Primitives.Operations; +with System.Tasking.Initialization; + +function System.Tasking.Async_Delays.Enqueue_Calendar + (T : Ada.Calendar.Time; + D : Delay_Block_Access) return Boolean +is + use type Ada.Calendar.Time; + + package SOSC renames System.OS_Constants; + package STPO renames System.Task_Primitives.Operations; + + RT_T : Duration := Ada.Calendar.Delays.To_Duration (T); + +begin + if T <= Ada.Calendar.Clock then + D.Timed_Out := True; + System.Task_Primitives.Operations.Yield; + return False; + end if; + + -- T is expressed as a duration elapsed since the UNIX epoch, whereas + -- Time_Enqueue expects duration elapsed since the epoch of the Ada real- + -- time clock: compensate if necessary. + + -- Comparison "SOSC.CLOCK_RT_Ada = SOSC.CLOCK_REALTIME" is compile + -- time known, so turn warnings off. + + pragma Warnings (Off); + + if SOSC.CLOCK_RT_Ada /= SOSC.CLOCK_REALTIME then + pragma Warnings (On); + + RT_T := RT_T - OS_Primitives.Clock + STPO.Monotonic_Clock; + end if; + + System.Tasking.Initialization.Defer_Abort + (System.Task_Primitives.Operations.Self); + Time_Enqueue (RT_T, D); + return True; +end System.Tasking.Async_Delays.Enqueue_Calendar; diff --git a/gcc/ada/libgnarl/s-tadeca.ads b/gcc/ada/libgnarl/s-tadeca.ads new file mode 100644 index 00000000000..5b7e3d22c0a --- /dev/null +++ b/gcc/ada/libgnarl/s-tadeca.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_CALENDAR -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- See comments in package System.Tasking.Async_Delays + +with Ada.Calendar; +function System.Tasking.Async_Delays.Enqueue_Calendar + (T : Ada.Calendar.Time; + D : Delay_Block_Access) return Boolean; diff --git a/gcc/ada/libgnarl/s-tadert.adb b/gcc/ada/libgnarl/s-tadert.adb new file mode 100644 index 00000000000..ede868ea966 --- /dev/null +++ b/gcc/ada/libgnarl/s-tadert.adb @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_RT -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Real_Time; +with Ada.Real_Time.Delays; +with System.Task_Primitives.Operations; +with System.Tasking.Initialization; + +function System.Tasking.Async_Delays.Enqueue_RT + (T : Ada.Real_Time.Time; + D : Delay_Block_Access) return Boolean +is + use type Ada.Real_Time.Time; -- for "=" operator +begin + if T <= Ada.Real_Time.Clock then + D.Timed_Out := True; + System.Task_Primitives.Operations.Yield; + return False; + end if; + + System.Tasking.Initialization.Defer_Abort + (System.Task_Primitives.Operations.Self); + Time_Enqueue (Ada.Real_Time.Delays.To_Duration (T), D); + return True; +end System.Tasking.Async_Delays.Enqueue_RT; diff --git a/gcc/ada/libgnarl/s-tadert.ads b/gcc/ada/libgnarl/s-tadert.ads new file mode 100644 index 00000000000..9203820919f --- /dev/null +++ b/gcc/ada/libgnarl/s-tadert.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_RT -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- See comments in package System.Tasking.Async_Delays + +with Ada.Real_Time; +function System.Tasking.Async_Delays.Enqueue_RT + (T : Ada.Real_Time.Time; + D : Delay_Block_Access) + return Boolean; diff --git a/gcc/ada/libgnarl/s-taenca.adb b/gcc/ada/libgnarl/s-taenca.adb new file mode 100644 index 00000000000..1236194441c --- /dev/null +++ b/gcc/ada/libgnarl/s-taenca.adb @@ -0,0 +1,636 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . E N T R Y _ C A L L 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Primitives.Operations; +with System.Tasking.Initialization; +with System.Tasking.Protected_Objects.Entries; +with System.Tasking.Protected_Objects.Operations; +with System.Tasking.Queuing; +with System.Tasking.Utilities; +with System.Parameters; + +package body System.Tasking.Entry_Calls is + + package STPO renames System.Task_Primitives.Operations; + + use Parameters; + use Task_Primitives; + use Protected_Objects.Entries; + use Protected_Objects.Operations; + + -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock + -- internally. Those operations will raise Program_Error, which + -- we are not prepared to handle inside the RTS. Instead, use + -- System.Task_Primitives lock operations directly on Protection.L. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Lock_Server (Entry_Call : Entry_Call_Link); + + -- This locks the server targeted by Entry_Call + -- + -- This may be a task or a protected object, depending on the target of the + -- original call or any subsequent requeues. + -- + -- This routine is needed because the field specifying the server for this + -- call must be protected by the server's mutex. If it were protected by + -- the caller's mutex, accessing the server's queues would require locking + -- the caller to get the server, locking the server, and then accessing the + -- queues. This involves holding two ATCB locks at once, something which we + -- can guarantee that it will always be done in the same order, or locking + -- a protected object while we hold an ATCB lock, something which is not + -- permitted. Since the server cannot be obtained reliably, it must be + -- obtained unreliably and then checked again once it has been locked. + -- + -- If Single_Lock and server is a PO, release RTS_Lock + -- + -- This should only be called by the Entry_Call.Self. + -- It should be holding no other ATCB locks at the time. + + procedure Unlock_Server (Entry_Call : Entry_Call_Link); + -- STPO.Unlock the server targeted by Entry_Call. The server must + -- be locked before calling this. + -- + -- If Single_Lock and server is a PO, take RTS_Lock on exit. + + procedure Unlock_And_Update_Server + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + -- Similar to Unlock_Server, but services entry calls if the + -- server is a protected object. + -- + -- If Single_Lock and server is a PO, take RTS_Lock on exit. + + procedure Check_Pending_Actions_For_Entry_Call + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + -- This procedure performs priority change of a queued call and dequeuing + -- of an entry call when the call is cancelled. If the call is dequeued the + -- state should be set to Cancelled. Call only with abort deferred and + -- holding lock of Self_ID. This is a bit of common code for all entry + -- calls. The effect is to do any deferred base priority change operation, + -- in case some other task called STPO.Set_Priority while the current task + -- had abort deferred, and to dequeue the call if the call has been + -- aborted. + + procedure Poll_Base_Priority_Change_At_Entry_Call + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + pragma Inline (Poll_Base_Priority_Change_At_Entry_Call); + -- A specialized version of Poll_Base_Priority_Change, that does the + -- optional entry queue reordering. Has to be called with the Self_ID's + -- ATCB write-locked. May temporarily release the lock. + + --------------------- + -- Check_Exception -- + --------------------- + + procedure Check_Exception + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + pragma Warnings (Off, Self_ID); + + use type Ada.Exceptions.Exception_Id; + + procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); + pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); + + E : constant Ada.Exceptions.Exception_Id := + Entry_Call.Exception_To_Raise; + begin + -- pragma Assert (Self_ID.Deferral_Level = 0); + + -- The above may be useful for debugging, but the Florist packages + -- contain critical sections that defer abort and then do entry calls, + -- which causes the above Assert to trip. + + if E /= Ada.Exceptions.Null_Id then + Internal_Raise (E); + end if; + end Check_Exception; + + ------------------------------------------ + -- Check_Pending_Actions_For_Entry_Call -- + ------------------------------------------ + + procedure Check_Pending_Actions_For_Entry_Call + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + begin + pragma Assert (Self_ID = Entry_Call.Self); + + Poll_Base_Priority_Change_At_Entry_Call (Self_ID, Entry_Call); + + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + and then Entry_Call.State = Now_Abortable + then + STPO.Unlock (Self_ID); + Lock_Server (Entry_Call); + + if Queuing.Onqueue (Entry_Call) + and then Entry_Call.State = Now_Abortable + then + Queuing.Dequeue_Call (Entry_Call); + Entry_Call.State := + (if Entry_Call.Cancellation_Attempted then Cancelled else Done); + Unlock_And_Update_Server (Self_ID, Entry_Call); + + else + Unlock_Server (Entry_Call); + end if; + + STPO.Write_Lock (Self_ID); + end if; + end Check_Pending_Actions_For_Entry_Call; + + ----------------- + -- Lock_Server -- + ----------------- + + procedure Lock_Server (Entry_Call : Entry_Call_Link) is + Test_Task : Task_Id; + Test_PO : Protection_Entries_Access; + Ceiling_Violation : Boolean; + Failures : Integer := 0; + + begin + Test_Task := Entry_Call.Called_Task; + + loop + if Test_Task = null then + + -- Entry_Call was queued on a protected object, or in transition, + -- when we last fetched Test_Task. + + Test_PO := To_Protection (Entry_Call.Called_PO); + + if Test_PO = null then + + -- We had very bad luck, interleaving with TWO different + -- requeue operations. Go around the loop and try again. + + if Single_Lock then + STPO.Unlock_RTS; + STPO.Yield; + STPO.Lock_RTS; + else + STPO.Yield; + end if; + + else + if Single_Lock then + STPO.Unlock_RTS; + end if; + + Lock_Entries_With_Status (Test_PO, Ceiling_Violation); + + -- ??? + + -- The following code allows Lock_Server to be called when + -- cancelling a call, to allow for the possibility that the + -- priority of the caller has been raised beyond that of the + -- protected entry call by Ada.Dynamic_Priorities.Set_Priority. + + -- If the current task has a higher priority than the ceiling + -- of the protected object, temporarily lower it. It will + -- be reset in Unlock. + + if Ceiling_Violation then + declare + Current_Task : constant Task_Id := STPO.Self; + Old_Base_Priority : System.Any_Priority; + + begin + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Current_Task); + Old_Base_Priority := Current_Task.Common.Base_Priority; + Current_Task.New_Base_Priority := Test_PO.Ceiling; + System.Tasking.Initialization.Change_Base_Priority + (Current_Task); + STPO.Unlock (Current_Task); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + -- Following lock should not fail + + Lock_Entries (Test_PO); + + Test_PO.Old_Base_Priority := Old_Base_Priority; + Test_PO.Pending_Action := True; + end; + end if; + + exit when To_Address (Test_PO) = Entry_Call.Called_PO; + Unlock_Entries (Test_PO); + + if Single_Lock then + STPO.Lock_RTS; + end if; + end if; + + else + STPO.Write_Lock (Test_Task); + exit when Test_Task = Entry_Call.Called_Task; + STPO.Unlock (Test_Task); + end if; + + Test_Task := Entry_Call.Called_Task; + Failures := Failures + 1; + pragma Assert (Failures <= 5); + end loop; + end Lock_Server; + + --------------------------------------------- + -- Poll_Base_Priority_Change_At_Entry_Call -- + --------------------------------------------- + + procedure Poll_Base_Priority_Change_At_Entry_Call + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + begin + if Self_ID.Pending_Priority_Change then + + -- Check for ceiling violations ??? + + Self_ID.Pending_Priority_Change := False; + + -- Requeue the entry call at the new priority. We need to requeue + -- even if the new priority is the same than the previous (see ACATS + -- test cxd4006). + + STPO.Unlock (Self_ID); + Lock_Server (Entry_Call); + Queuing.Requeue_Call_With_New_Prio + (Entry_Call, STPO.Get_Priority (Self_ID)); + Unlock_And_Update_Server (Self_ID, Entry_Call); + STPO.Write_Lock (Self_ID); + end if; + end Poll_Base_Priority_Change_At_Entry_Call; + + -------------------- + -- Reset_Priority -- + -------------------- + + procedure Reset_Priority + (Acceptor : Task_Id; + Acceptor_Prev_Priority : Rendezvous_Priority) + is + begin + pragma Assert (Acceptor = STPO.Self); + + -- Since we limit this kind of "active" priority change to be done + -- by the task for itself, we don't need to lock Acceptor. + + if Acceptor_Prev_Priority /= Priority_Not_Boosted then + STPO.Set_Priority (Acceptor, Acceptor_Prev_Priority, + Loss_Of_Inheritance => True); + end if; + end Reset_Priority; + + ------------------------------ + -- Try_To_Cancel_Entry_Call -- + ------------------------------ + + procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean) is + Entry_Call : Entry_Call_Link; + Self_ID : constant Task_Id := STPO.Self; + + use type Ada.Exceptions.Exception_Id; + + begin + Entry_Call := Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; + + -- Experimentation has shown that abort is sometimes (but not + -- always) already deferred when Cancel_xxx_Entry_Call is called. + -- That may indicate an error. Find out what is going on. ??? + + pragma Assert (Entry_Call.Mode = Asynchronous_Call); + Initialization.Defer_Abort_Nestable (Self_ID); + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Self_ID); + Entry_Call.Cancellation_Attempted := True; + + if Self_ID.Pending_ATC_Level >= Entry_Call.Level then + Self_ID.Pending_ATC_Level := Entry_Call.Level - 1; + end if; + + Entry_Calls.Wait_For_Completion (Entry_Call); + STPO.Unlock (Self_ID); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + Succeeded := Entry_Call.State = Cancelled; + + Initialization.Undefer_Abort_Nestable (Self_ID); + + -- Ideally, abort should no longer be deferred at this point, so we + -- should be able to call Check_Exception. The loop below should be + -- considered temporary, to work around the possibility that abort + -- may be deferred more than one level deep ??? + + if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then + while Self_ID.Deferral_Level > 0 loop + System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID); + end loop; + + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + end if; + end Try_To_Cancel_Entry_Call; + + ------------------------------ + -- Unlock_And_Update_Server -- + ------------------------------ + + procedure Unlock_And_Update_Server + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + Called_PO : Protection_Entries_Access; + Caller : Task_Id; + + begin + if Entry_Call.Called_Task /= null then + STPO.Unlock (Entry_Call.Called_Task); + else + Called_PO := To_Protection (Entry_Call.Called_PO); + PO_Service_Entries (Self_ID, Called_PO, False); + + if Called_PO.Pending_Action then + Called_PO.Pending_Action := False; + Caller := STPO.Self; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Caller.New_Base_Priority := Called_PO.Old_Base_Priority; + Initialization.Change_Base_Priority (Caller); + STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + + Unlock_Entries (Called_PO); + + if Single_Lock then + STPO.Lock_RTS; + end if; + end if; + end Unlock_And_Update_Server; + + ------------------- + -- Unlock_Server -- + ------------------- + + procedure Unlock_Server (Entry_Call : Entry_Call_Link) is + Caller : Task_Id; + Called_PO : Protection_Entries_Access; + + begin + if Entry_Call.Called_Task /= null then + STPO.Unlock (Entry_Call.Called_Task); + else + Called_PO := To_Protection (Entry_Call.Called_PO); + + if Called_PO.Pending_Action then + Called_PO.Pending_Action := False; + Caller := STPO.Self; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Caller.New_Base_Priority := Called_PO.Old_Base_Priority; + Initialization.Change_Base_Priority (Caller); + STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + + Unlock_Entries (Called_PO); + + if Single_Lock then + STPO.Lock_RTS; + end if; + end if; + end Unlock_Server; + + ------------------------- + -- Wait_For_Completion -- + ------------------------- + + procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is + Self_Id : constant Task_Id := Entry_Call.Self; + + begin + -- If this is a conditional call, it should be cancelled when it + -- becomes abortable. This is checked in the loop below. + + Self_Id.Common.State := Entry_Caller_Sleep; + + -- Try to remove calls to Sleep in the loop below by letting the caller + -- a chance of getting ready immediately, using Unlock & Yield. + -- See similar action in Wait_For_Call & Timed_Selective_Wait. + + if Single_Lock then + STPO.Unlock_RTS; + else + STPO.Unlock (Self_Id); + end if; + + if Entry_Call.State < Done then + STPO.Yield; + end if; + + if Single_Lock then + STPO.Lock_RTS; + else + STPO.Write_Lock (Self_Id); + end if; + + loop + Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); + + exit when Entry_Call.State >= Done; + + STPO.Sleep (Self_Id, Entry_Caller_Sleep); + end loop; + + Self_Id.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_Id); + + end Wait_For_Completion; + + -------------------------------------- + -- Wait_For_Completion_With_Timeout -- + -------------------------------------- + + procedure Wait_For_Completion_With_Timeout + (Entry_Call : Entry_Call_Link; + Wakeup_Time : Duration; + Mode : Delay_Modes; + Yielded : out Boolean) + is + Self_Id : constant Task_Id := Entry_Call.Self; + Timedout : Boolean := False; + + begin + -- This procedure waits for the entry call to be served, with a timeout. + -- It tries to cancel the call if the timeout expires before the call is + -- served. + + -- If we wake up from the timed sleep operation here, it may be for + -- several possible reasons: + + -- 1) The entry call is done being served. + -- 2) There is an abort or priority change to be served. + -- 3) The timeout has expired (Timedout = True) + -- 4) There has been a spurious wakeup. + + -- Once the timeout has expired we may need to continue to wait if the + -- call is already being serviced. In that case, we want to go back to + -- sleep, but without any timeout. The variable Timedout is used to + -- control this. If the Timedout flag is set, we do not need to + -- STPO.Sleep with a timeout. We just sleep until we get a wakeup for + -- some status change. + + -- The original call may have become abortable after waking up. We want + -- to check Check_Pending_Actions_For_Entry_Call again in any case. + + pragma Assert (Entry_Call.Mode = Timed_Call); + + Yielded := False; + Self_Id.Common.State := Entry_Caller_Sleep; + + -- Looping is necessary in case the task wakes up early from the timed + -- sleep, due to a "spurious wakeup". Spurious wakeups are a weakness of + -- POSIX condition variables. A thread waiting for a condition variable + -- is allowed to wake up at any time, not just when the condition is + -- signaled. See same loop in the ordinary Wait_For_Completion, above. + + loop + Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); + exit when Entry_Call.State >= Done; + + STPO.Timed_Sleep (Self_Id, Wakeup_Time, Mode, + Entry_Caller_Sleep, Timedout, Yielded); + + if Timedout then + -- Try to cancel the call (see Try_To_Cancel_Entry_Call for + -- corresponding code in the ATC case). + + Entry_Call.Cancellation_Attempted := True; + + -- Reset Entry_Call.State so that the call is marked as cancelled + -- by Check_Pending_Actions_For_Entry_Call below. + + if Entry_Call.State < Was_Abortable then + Entry_Call.State := Now_Abortable; + end if; + + if Self_Id.Pending_ATC_Level >= Entry_Call.Level then + Self_Id.Pending_ATC_Level := Entry_Call.Level - 1; + end if; + + -- The following loop is the same as the loop and exit code + -- from the ordinary Wait_For_Completion. If we get here, we + -- have timed out but we need to keep waiting until the call + -- has actually completed or been cancelled successfully. + + loop + Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); + exit when Entry_Call.State >= Done; + STPO.Sleep (Self_Id, Entry_Caller_Sleep); + end loop; + + Self_Id.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_Id); + + return; + end if; + end loop; + + -- This last part is the same as ordinary Wait_For_Completion, + -- and is only executed if the call completed without timing out. + + Self_Id.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_Id); + end Wait_For_Completion_With_Timeout; + + -------------------------- + -- Wait_Until_Abortable -- + -------------------------- + + procedure Wait_Until_Abortable + (Self_ID : Task_Id; + Call : Entry_Call_Link) + is + begin + pragma Assert (Self_ID.ATC_Nesting_Level > 0); + pragma Assert (Call.Mode = Asynchronous_Call); + + STPO.Write_Lock (Self_ID); + Self_ID.Common.State := Entry_Caller_Sleep; + + loop + Check_Pending_Actions_For_Entry_Call (Self_ID, Call); + exit when Call.State >= Was_Abortable; + STPO.Sleep (Self_ID, Async_Select_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + STPO.Unlock (Self_ID); + + end Wait_Until_Abortable; + +end System.Tasking.Entry_Calls; diff --git a/gcc/ada/libgnarl/s-taenca.ads b/gcc/ada/libgnarl/s-taenca.ads new file mode 100644 index 00000000000..1ec47809a27 --- /dev/null +++ b/gcc/ada/libgnarl/s-taenca.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . E N T R Y _ C A L L 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 package provides internal RTS calls implementing operations +-- that apply to general entry calls, that is, calls to either +-- protected or task entries. + +-- These declarations are not part of the GNARL Interface + +package System.Tasking.Entry_Calls is + + procedure Wait_For_Completion (Entry_Call : Entry_Call_Link); + -- This procedure suspends the calling task until the specified entry + -- call has either been completed or cancelled. It performs other + -- operations required of suspended tasks, such as performing + -- dynamic priority changes. On exit, the call will not be queued. + -- This waits for calls on task or protected entries. + -- Abortion must be deferred when calling this procedure. + -- Call this only when holding Self (= Entry_Call.Self) or global RTS lock. + + procedure Wait_For_Completion_With_Timeout + (Entry_Call : Entry_Call_Link; + Wakeup_Time : Duration; + Mode : Delay_Modes; + Yielded : out Boolean); + -- Same as Wait_For_Completion but wait for a timeout with the value + -- specified in Wakeup_Time as well. + -- On return, Yielded indicates whether the wait has performed a yield. + -- Check_Exception must be called after calling this procedure. + + procedure Wait_Until_Abortable + (Self_ID : Task_Id; + Call : Entry_Call_Link); + -- This procedure suspends the calling task until the specified entry + -- call is queued abortably or completes. + -- Abortion must be deferred when calling this procedure, and the global + -- RTS lock taken when Single_Lock. + + procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean); + pragma Inline (Try_To_Cancel_Entry_Call); + -- Try to cancel async. entry call. + -- Effect includes Abort_To_Level and Wait_For_Completion. + -- Cancelled = True iff the cancellation was successful, i.e., + -- the call was not Done before this call. + -- On return, the call is off-queue and the ATC level is reduced by one. + + procedure Reset_Priority + (Acceptor : Task_Id; + Acceptor_Prev_Priority : Rendezvous_Priority); + pragma Inline (Reset_Priority); + -- Reset the priority of a task completing an accept statement to + -- the value it had before the call. + -- Acceptor should always be equal to Self. + + procedure Check_Exception + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + pragma Inline (Check_Exception); + -- Raise any pending exception from the Entry_Call. + -- This should be called at the end of every compiler interface procedure + -- that implements an entry call. + -- In principle, the caller should not be abort-deferred (unless the + -- application program violates the Ada language rules by doing entry calls + -- from within protected operations -- an erroneous practice apparently + -- followed with success by some adventurous GNAT users). + -- Absolutely, the caller should not be holding any locks, or there + -- will be deadlock. + +end System.Tasking.Entry_Calls; diff --git a/gcc/ada/libgnarl/s-taprob.adb b/gcc/ada/libgnarl/s-taprob.adb new file mode 100644 index 00000000000..517b92d8af2 --- /dev/null +++ b/gcc/ada/libgnarl/s-taprob.adb @@ -0,0 +1,271 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C 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. -- +-- -- +------------------------------------------------------------------------------ + +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.Task_Primitives.Operations; +with System.Soft_Links.Tasking; + +with System.Secondary_Stack; +pragma Elaborate_All (System.Secondary_Stack); +pragma Unreferenced (System.Secondary_Stack); +-- Make sure the body of Secondary_Stack is elaborated before calling +-- Init_Tasking_Soft_Links. See comments for this routine for explanation. + +package body System.Tasking.Protected_Objects is + + use System.Task_Primitives.Operations; + + ---------------- + -- Local Data -- + ---------------- + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + ------------------------- + -- Finalize_Protection -- + ------------------------- + + procedure Finalize_Protection (Object : in out Protection) is + begin + Finalize_Lock (Object.L'Unrestricted_Access); + end Finalize_Protection; + + --------------------------- + -- Initialize_Protection -- + --------------------------- + + procedure Initialize_Protection + (Object : Protection_Access; + Ceiling_Priority : Integer) + is + Init_Priority : Integer := Ceiling_Priority; + + begin + if Init_Priority = Unspecified_Priority then + Init_Priority := System.Priority'Last; + end if; + + Initialize_Lock (Init_Priority, Object.L'Access); + Object.Ceiling := System.Any_Priority (Init_Priority); + Object.New_Ceiling := System.Any_Priority (Init_Priority); + Object.Owner := Null_Task; + end Initialize_Protection; + + ----------------- + -- Get_Ceiling -- + ----------------- + + function Get_Ceiling + (Object : Protection_Access) return System.Any_Priority is + begin + return Object.New_Ceiling; + end Get_Ceiling; + + ---------- + -- Lock -- + ---------- + + procedure Lock (Object : Protection_Access) is + Ceiling_Violation : Boolean; + + begin + -- The lock is made without deferring abort + + -- Therefore the abort has to be deferred before calling this routine. + -- This means that the compiler has to generate a Defer_Abort call + -- before the call to Lock. + + -- The caller is responsible for undeferring abort, and compiler + -- generated calls must be protected with cleanup handlers to ensure + -- that abort is undeferred in all cases. + + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on a + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. + + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; + end if; + + Write_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error; + end if; + + -- We are entering in a protected action, so that we increase the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and update the protected object's owner. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + begin + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end; + end if; + end Lock; + + -------------------- + -- Lock_Read_Only -- + -------------------- + + procedure Lock_Read_Only (Object : Protection_Access) is + Ceiling_Violation : Boolean; + + begin + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. + -- + -- Note that in this case (getting read access), several tasks may have + -- read ownership of the protected object, so that this method of + -- storing the (single) protected object's owner does not work reliably + -- for read locks. However, this is the approach taken for two major + -- reasons: first, this function is not currently being used (it is + -- provided for possible future use), and second, it largely simplifies + -- the implementation. + + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; + end if; + + Read_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error; + end if; + + -- We are entering in a protected action, so we increase the protected + -- object nesting level (if pragma Detect_Blocking is active). + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + begin + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end; + end if; + end Lock_Read_Only; + + ----------------- + -- Set_Ceiling -- + ----------------- + + procedure Set_Ceiling + (Object : Protection_Access; + Prio : System.Any_Priority) is + begin + Object.New_Ceiling := Prio; + end Set_Ceiling; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (Object : Protection_Access) is + begin + -- We are exiting from a protected action, so that we decrease the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and remove ownership of the protected object. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + + begin + -- Calls to this procedure can only take place when being within + -- a protected action and when the caller is the protected + -- object's owner. + + pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 + and then Object.Owner = Self_Id); + + -- Remove ownership of the protected object + + Object.Owner := Null_Task; + + -- We are exiting from a protected action, so we decrease the + -- protected object nesting level. + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting - 1; + end; + end if; + + -- Before releasing the mutex we must actually update its ceiling + -- priority if it has been changed. + + if Object.New_Ceiling /= Object.Ceiling then + if Locking_Policy = 'C' then + System.Task_Primitives.Operations.Set_Ceiling + (Object.L'Access, Object.New_Ceiling); + end if; + + Object.Ceiling := Object.New_Ceiling; + end if; + + Unlock (Object.L'Access); + + end Unlock; + +begin + -- Ensure that tasking is initialized, as well as tasking soft links + -- when using protected objects. + + Tasking.Initialize; + System.Soft_Links.Tasking.Init_Tasking_Soft_Links; +end System.Tasking.Protected_Objects; diff --git a/gcc/ada/libgnarl/s-taprob.ads b/gcc/ada/libgnarl/s-taprob.ads new file mode 100644 index 00000000000..10c0692f38b --- /dev/null +++ b/gcc/ada/libgnarl/s-taprob.ads @@ -0,0 +1,241 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T 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 package provides necessary definitions to handle simple (i.e without +-- entries) protected objects. + +-- All the routines that handle protected objects with entries have been moved +-- to two children: Entries and Operations. Note that Entries only contains +-- the type declaration and the OO primitives. This is needed to avoid +-- circular dependency. + +-- This package is part of the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls +-- (aka GNARLI, GNU Ada Run-time Library Interface) + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes +-- in exp_ch9.adb and possibly exp_ch7.adb and exp_attr.adb + +package System.Tasking.Protected_Objects is + pragma Elaborate_Body; + + --------------------------------- + -- Compiler Interface (GNARLI) -- + --------------------------------- + + -- The compiler will expand in the GNAT tree the following construct: + + -- protected PO is + -- procedure P; + -- private + -- open : boolean := false; + -- end PO; + + -- protected body PO is + -- procedure P is + -- ...variable declarations... + -- begin + -- ...B... + -- end P; + -- end PO; + + -- as follows: + + -- protected type poT is + -- procedure p; + -- private + -- open : boolean := false; + -- end poT; + -- type poTV is limited record + -- open : boolean := false; + -- _object : aliased protection; + -- end record; + -- procedure poPT__pN (_object : in out poTV); + -- procedure poPT__pP (_object : in out poTV); + -- freeze poTV [ + -- procedure poTVI (_init : in out poTV) is + -- begin + -- _init.open := false; + -- object-init-proc (_init._object); + -- initialize_protection (_init._object'unchecked_access, + -- unspecified_priority); + -- return; + -- end _init_proc; + -- ] + -- po : poT; + -- poTVI (poTV!(po)); + + -- procedure poPT__pN (_object : in out poTV) is + -- poR : protection renames _object._object; + -- openP : boolean renames _object.open; + -- ...variable declarations... + -- begin + -- ...B... + -- return; + -- end poPT__pN; + + -- procedure poPT__pP (_object : in out poTV) is + -- procedure _clean is + -- begin + -- unlock (_object._object'unchecked_access); + -- return; + -- end _clean; + -- begin + -- lock (_object._object'unchecked_access); + -- B2b : begin + -- poPT__pN (_object); + -- at end + -- _clean; + -- end B2b; + -- return; + -- end poPT__pP; + + Null_Protected_Entry : constant := Null_Entry; + + Max_Protected_Entry : constant := Max_Entry; + + type Protected_Entry_Index is new Entry_Index + range Null_Protected_Entry .. Max_Protected_Entry; + + type Barrier_Function_Pointer is access + function + (O : System.Address; + E : Protected_Entry_Index) + return Boolean; + -- Pointer to a function which evaluates the barrier of a protected + -- entry body. O is a pointer to the compiler-generated record + -- representing the protected object, and E is the index of the + -- entry serviced by the body. + + type Entry_Action_Pointer is access + procedure + (O : System.Address; + P : System.Address; + E : Protected_Entry_Index); + -- Pointer to a procedure which executes the sequence of statements + -- of a protected entry body. O is a pointer to the compiler-generated + -- record representing the protected object, P is a pointer to the + -- record of entry parameters, and E is the index of the + -- entry serviced by the body. + + type Entry_Body is record + Barrier : Barrier_Function_Pointer; + Action : Entry_Action_Pointer; + end record; + -- The compiler-generated code passes objects of this type to the GNARL + -- to allow it to access the executable code of an entry body and its + -- barrier. + + type Protection is limited private; + -- This type contains the GNARL state of a protected object. The + -- application-defined portion of the state (i.e. private objects) + -- is maintained by the compiler-generated code. + -- Note that there are now 2 Protection types. One for the simple + -- case (no entries) and one for the general case that needs the whole + -- Finalization mechanism. + -- This split helps in the case of restricted run time where we want to + -- minimize the size of the code. + + type Protection_Access is access all Protection; + + Null_PO : constant Protection_Access := null; + + function Get_Ceiling + (Object : Protection_Access) return System.Any_Priority; + -- Returns the new ceiling priority of the protected object + + procedure Initialize_Protection + (Object : Protection_Access; + Ceiling_Priority : Integer); + -- Initialize the Object parameter so that it can be used by the runtime + -- to keep track of the runtime state of a protected object. + + procedure Lock (Object : Protection_Access); + -- Lock a protected object for write access. Upon return, the caller + -- owns the lock to this object, and no other call to Lock or + -- Lock_Read_Only with the same argument will return until the + -- corresponding call to Unlock has been made by the caller. + + procedure Lock_Read_Only (Object : Protection_Access); + -- Lock a protected object for read access. Upon return, the caller + -- owns the lock for read access, and no other calls to Lock with the + -- same argument will return until the corresponding call to Unlock + -- has been made by the caller. Other calls to Lock_Read_Only may (but + -- need not) return before the call to Unlock, and the corresponding + -- callers will also own the lock for read access. + + procedure Set_Ceiling + (Object : Protection_Access; + Prio : System.Any_Priority); + -- Sets the new ceiling priority of the protected object + + procedure Unlock (Object : Protection_Access); + -- Relinquish ownership of the lock for the object represented by + -- the Object parameter. If this ownership was for write access, or + -- if it was for read access where there are no other read access + -- locks outstanding, one (or more, in the case of Lock_Read_Only) + -- of the tasks waiting on this lock (if any) will be given the + -- lock and allowed to return from the Lock or Lock_Read_Only call. + +private + type Protection is record + L : aliased Task_Primitives.Lock; + -- Lock used to ensure mutual exclusive access to the protected object + + Ceiling : System.Any_Priority; + -- Ceiling priority associated to the protected object + + New_Ceiling : System.Any_Priority; + -- New ceiling priority associated to the protected object. In case + -- of assignment of a new ceiling priority to the protected object the + -- frontend generates a call to set_ceiling to save the new value in + -- this field. After such assignment this value can be read by means + -- of the 'Priority attribute, which generates a call to get_ceiling. + -- However, the ceiling of the protected object will not be changed + -- until completion of the protected action in which the assignment + -- has been executed (AARM D.5.2 (10/2)). + + Owner : Task_Id; + -- This field contains the protected object's owner. Null_Task + -- indicates that the protected object is not currently being used. + -- This information is used for detecting the type of potentially + -- blocking operations described in the ARM 9.5.1, par. 15 (external + -- calls on a protected subprogram with the same target object as that + -- of the protected action). + end record; + + procedure Finalize_Protection (Object : in out Protection); + -- Clean up a Protection object (in particular, finalize the associated + -- Lock object). The compiler generates calls automatically to this + -- procedure + +end System.Tasking.Protected_Objects; 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-taprop.ads b/gcc/ada/libgnarl/s-taprop.ads new file mode 100644 index 00000000000..393de9f1ebe --- /dev/null +++ b/gcc/ada/libgnarl/s-taprop.ads @@ -0,0 +1,571 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- -- +-- 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 package contains all the GNULL primitives that interface directly with +-- the underlying OS. + +with System.Parameters; +with System.Tasking; +with System.OS_Interface; + +package System.Task_Primitives.Operations is + pragma Preelaborate; + + package ST renames System.Tasking; + package OSI renames System.OS_Interface; + + procedure Initialize (Environment_Task : ST.Task_Id); + -- Perform initialization and set up of the environment task for proper + -- operation of the tasking run-time. This must be called once, before any + -- other subprograms of this package are called. + + procedure Create_Task + (T : ST.Task_Id; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean); + pragma Inline (Create_Task); + -- Create a new low-level task with ST.Task_Id T and place other needed + -- information in the ATCB. + -- + -- A new thread of control is created, with a stack of at least Stack_Size + -- storage units, and the procedure Wrapper is called by this new thread + -- of control. If Stack_Size = Unspecified_Storage_Size, choose a default + -- stack size; this may be effectively "unbounded" on some systems. + -- + -- The newly created low-level task is associated with the ST.Task_Id T + -- such that any subsequent call to Self from within the context of the + -- low-level task returns T. + -- + -- The caller is responsible for ensuring that the storage of the Ada + -- task control block object pointed to by T persists for the lifetime + -- of the new task. + -- + -- Succeeded is set to true unless creation of the task failed, + -- as it may if there are insufficient resources to create another task. + + procedure Enter_Task (Self_ID : ST.Task_Id); + pragma Inline (Enter_Task); + -- Initialize data structures specific to the calling task. Self must be + -- the ID of the calling task. It must be called (once) by the task + -- immediately after creation, while abort is still deferred. The effects + -- of other operations defined below are not defined unless the caller has + -- previously called Initialize_Task. + + procedure Exit_Task; + pragma Inline (Exit_Task); + -- Destroy the thread of control. Self must be the ID of the calling task. + -- The effects of further calls to operations defined below on the task + -- are undefined thereafter. + + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package ATCB_Allocation is + + function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id; + pragma Inline (New_ATCB); + -- Allocate a new ATCB with the specified number of entries + + procedure Free_ATCB (T : ST.Task_Id); + pragma Inline (Free_ATCB); + -- Deallocate an ATCB previously allocated by New_ATCB + + end ATCB_Allocation; + + function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id + renames ATCB_Allocation.New_ATCB; + + procedure Initialize_TCB (Self_ID : ST.Task_Id; Succeeded : out Boolean); + pragma Inline (Initialize_TCB); + -- Initialize all fields of the TCB + + procedure Finalize_TCB (T : ST.Task_Id); + pragma Inline (Finalize_TCB); + -- Finalizes Private_Data of ATCB, and then deallocates it. This is also + -- responsible for recovering any storage or other resources that were + -- allocated by Create_Task (the one in this package). This should only be + -- called from Free_Task. After it is called there should be no further + -- reference to the ATCB that corresponds to T. + + procedure Abort_Task (T : ST.Task_Id); + pragma Inline (Abort_Task); + -- Abort the task specified by T (the target task). This causes the target + -- task to asynchronously raise Abort_Signal if abort is not deferred, or + -- if it is blocked on an interruptible system call. + -- + -- precondition: + -- the calling task is holding T's lock and has abort deferred + -- + -- postcondition: + -- the calling task is holding T's lock and has abort deferred. + + -- ??? modify GNARL to skip wakeup and always call Abort_Task + + function Self return ST.Task_Id; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + type Lock_Level is + (PO_Level, + Global_Task_Level, + RTS_Lock_Level, + ATCB_Level); + -- Type used to describe kind of lock for second form of Initialize_Lock + -- call specified below. See locking rules in System.Tasking (spec) for + -- more details. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : not null access Lock); + procedure Initialize_Lock + (L : not null access RTS_Lock; + Level : Lock_Level); + pragma Inline (Initialize_Lock); + -- Initialize a lock object + -- + -- For Lock, Prio is the ceiling priority associated with the lock. For + -- RTS_Lock, the ceiling is implicitly Priority'Last. + -- + -- If the underlying system does not support priority ceiling + -- locking, the Prio parameter is ignored. + -- + -- The effect of either initialize operation is undefined unless is a lock + -- object that has not been initialized, or which has been finalized since + -- it was last initialized. + -- + -- The effects of the other operations on lock objects are undefined + -- unless the lock object has been initialized and has not since been + -- finalized. + -- + -- Initialization of the per-task lock is implicit in Create_Task + -- + -- These operations raise Storage_Error if a lack of storage is detected + + procedure Finalize_Lock (L : not null access Lock); + procedure Finalize_Lock (L : not null access RTS_Lock); + pragma Inline (Finalize_Lock); + -- Finalize a lock object, freeing any resources allocated by the + -- corresponding Initialize_Lock operation. + + procedure Write_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean); + procedure Write_Lock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False); + procedure Write_Lock + (T : ST.Task_Id); + pragma Inline (Write_Lock); + -- Lock a lock object for write access. After this operation returns, + -- the calling task holds write permission for the lock object. No other + -- Write_Lock or Read_Lock operation on the same lock object will return + -- until this task executes an Unlock operation on the same object. The + -- effect is undefined if the calling task already holds read or write + -- permission for the lock object L. + -- + -- For the operation on Lock, Ceiling_Violation is set to true iff the + -- operation failed, which will happen if there is a priority ceiling + -- violation. + -- + -- For the operation on RTS_Lock, Global_Lock should be set to True + -- if L is a global lock (Single_RTS_Lock, Global_Task_Lock). + -- + -- For the operation on ST.Task_Id, the lock is the special lock object + -- associated with that task's ATCB. This lock has effective ceiling + -- priority high enough that it is safe to call by a task with any + -- priority in the range System.Priority. It is implicitly initialized + -- by task creation. The effect is undefined if the calling task already + -- holds T's lock, or has interrupt-level priority. Finalization of the + -- per-task lock is implicit in Exit_Task. + + procedure Read_Lock + (L : not null access Lock; + Ceiling_Violation : out Boolean); + pragma Inline (Read_Lock); + -- Lock a lock object for read access. After this operation returns, + -- the calling task has non-exclusive read permission for the logical + -- resources that are protected by the lock. No other Write_Lock operation + -- on the same object will return until this task and any other tasks with + -- read permission for this lock have executed Unlock operation(s) on the + -- lock object. A Read_Lock for a lock object may return immediately while + -- there are tasks holding read permission, provided there are no tasks + -- holding write permission for the object. The effect is undefined if + -- the calling task already holds read or write permission for L. + -- + -- Alternatively: An implementation may treat Read_Lock identically to + -- Write_Lock. This simplifies the implementation, but reduces the level + -- of concurrency that can be achieved. + -- + -- Note that Read_Lock is not defined for RT_Lock and ST.Task_Id. + -- That is because (1) so far Read_Lock has always been implemented + -- the same as Write_Lock, (2) most lock usage inside the RTS involves + -- potential write access, and (3) implementations of priority ceiling + -- locking that make a reader-writer distinction have higher overhead. + + procedure Unlock + (L : not null access Lock); + procedure Unlock + (L : not null access RTS_Lock; + Global_Lock : Boolean := False); + procedure Unlock + (T : ST.Task_Id); + pragma Inline (Unlock); + -- Unlock a locked lock object + -- + -- The effect is undefined unless the calling task holds read or write + -- permission for the lock L, and L is the lock object most recently + -- locked by the calling task for which the calling task still holds + -- read or write permission. (That is, matching pairs of Lock and Unlock + -- operations on each lock object must be properly nested.) + + -- For the operation on RTS_Lock, Global_Lock should be set to True if L + -- is a global lock (Single_RTS_Lock, Global_Task_Lock). + -- + -- Note that Write_Lock for RTS_Lock does not have an out-parameter. + -- RTS_Locks are used in situations where we have not made provision for + -- recovery from ceiling violations. We do not expect them to occur inside + -- the runtime system, because all RTS locks have ceiling Priority'Last. + + -- There is one way there can be a ceiling violation. That is if the + -- runtime system is called from a task that is executing in the + -- Interrupt_Priority range. + + -- It is not clear what to do about ceiling violations due to RTS calls + -- done at interrupt priority. In general, it is not acceptable to give + -- all RTS locks interrupt priority, since that would give terrible + -- performance on systems where this has the effect of masking hardware + -- interrupts, though we could get away allowing Interrupt_Priority'last + -- where we are layered on an OS that does not allow us to mask interrupts. + -- Ideally, we would like to raise Program_Error back at the original point + -- of the RTS call, but this would require a lot of detailed analysis and + -- recoding, with almost certain performance penalties. + + -- For POSIX systems, we considered just skipping setting priority ceiling + -- on RTS locks. This would mean there is no ceiling violation, but we + -- would end up with priority inversions inside the runtime system, + -- resulting in failure to satisfy the Ada priority rules, and possible + -- missed validation tests. This could be compensated-for by explicit + -- priority-change calls to raise the caller to Priority'Last whenever it + -- first enters the runtime system, but the expected overhead seems high, + -- though it might be lower than using locks with ceilings if the + -- underlying implementation of ceiling locks is an inefficient one. + + -- This issue should be reconsidered whenever we get around to checking + -- for calls to potentially blocking operations from within protected + -- operations. If we check for such calls and catch them on entry to the + -- OS, it may be that we can eliminate the possibility of ceiling + -- violations inside the RTS. For this to work, we would have to forbid + -- explicitly setting the priority of a task to anything in the + -- Interrupt_Priority range, at least. We would also have to check that + -- there are no RTS-lock operations done inside any operations that are + -- not treated as potentially blocking. + + -- The latter approach seems to be the best, i.e. to check on entry to RTS + -- calls that may need to use locks that the priority is not in the + -- interrupt range. If there are RTS operations that NEED to be called + -- from interrupt handlers, those few RTS locks should then be converted + -- to PO-type locks, with ceiling Interrupt_Priority'Last. + + -- For now, we will just shut down the system if there is ceiling violation + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority); + pragma Inline (Set_Ceiling); + -- Change the ceiling priority associated to the lock + -- + -- The effect is undefined unless the calling task holds read or write + -- permission for the lock L, and L is the lock object most recently + -- locked by the calling task for which the calling task still holds + -- read or write permission. (That is, matching pairs of Lock and Unlock + -- operations on each lock object must be properly nested.) + + procedure Yield (Do_Yield : Boolean := True); + pragma Inline (Yield); + -- Yield the processor. Add the calling task to the tail of the ready queue + -- for its active_priority. On most platforms, Yield is a no-op if Do_Yield + -- is False. But on some platforms (notably VxWorks), Do_Yield is ignored. + -- This is only used in some very rare cases where a Yield should have an + -- effect on a specific target and not on regular ones. + + procedure Set_Priority + (T : ST.Task_Id; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False); + pragma Inline (Set_Priority); + -- Set the priority of the task specified by T to Prio. The priority set + -- is what would correspond to the Ada concept of "base priority" in the + -- terms of the lower layer system, but the operation may be used by the + -- upper layer to implement changes in "active priority" that are not due + -- to lock effects. The effect should be consistent with the Ada Reference + -- Manual. In particular, when a task lowers its priority due to the loss + -- of inherited priority, it goes at the head of the queue for its new + -- priority (RM D.2.2 par 9). Loss_Of_Inheritance helps the underlying + -- implementation to do it right when the OS doesn't. + + function Get_Priority (T : ST.Task_Id) return System.Any_Priority; + pragma Inline (Get_Priority); + -- Returns the priority last set by Set_Priority for this task + + function Monotonic_Clock return Duration; + pragma Inline (Monotonic_Clock); + -- Returns "absolute" time, represented as an offset relative to "the + -- Epoch", which is Jan 1, 1970. This clock implementation is immune to + -- the system's clock changes. + + function RT_Resolution return Duration; + pragma Inline (RT_Resolution); + -- Returns resolution of the underlying clock used to implement RT_Clock + + ---------------- + -- Extensions -- + ---------------- + + -- Whoever calls either of the Sleep routines is responsible for checking + -- for pending aborts before the call. Pending priority changes are handled + -- internally. + + procedure Sleep + (Self_ID : ST.Task_Id; + Reason : System.Tasking.Task_States); + pragma Inline (Sleep); + -- Wait until the current task, T, is signaled to wake up + -- + -- precondition: + -- The calling task is holding its own ATCB lock + -- and has abort deferred + -- + -- postcondition: + -- The calling task is holding its own ATCB lock and has abort deferred. + + -- The effect is to atomically unlock T's lock and wait, so that another + -- task that is able to lock T's lock can be assured that the wait has + -- actually commenced, and that a Wakeup operation will cause the waiting + -- task to become ready for execution once again. When Sleep returns, the + -- waiting task will again hold its own ATCB lock. The waiting task may + -- become ready for execution at any time (that is, spurious wakeups are + -- permitted), but it will definitely become ready for execution when a + -- Wakeup operation is performed for the same task. + + procedure Timed_Sleep + (Self_ID : ST.Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean); + -- Combination of Sleep (above) and Timed_Delay + + procedure Timed_Delay + (Self_ID : ST.Task_Id; + Time : Duration; + Mode : ST.Delay_Modes); + -- Implement the semantics of the delay statement. + -- The caller should be abort-deferred and should not hold any locks. + + procedure Wakeup + (T : ST.Task_Id; + Reason : System.Tasking.Task_States); + pragma Inline (Wakeup); + -- Wake up task T if it is waiting on a Sleep call (of ordinary + -- or timed variety), making it ready for execution once again. + -- If the task T is not waiting on a Sleep, the operation has no effect. + + function Environment_Task return ST.Task_Id; + pragma Inline (Environment_Task); + -- Return the task ID of the environment task + -- Consider putting this into a variable visible directly + -- by the rest of the runtime system. ??? + + function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id; + -- Return the thread id of the specified task + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does the calling thread have an ATCB? + + function Register_Foreign_Thread return ST.Task_Id; + -- Allocate and initialize a new ATCB for the current thread + + ----------------------- + -- RTS Entrance/Exit -- + ----------------------- + + -- Following two routines are used for possible operations needed to be + -- setup/cleared upon entrance/exit of RTS while maintaining a single + -- thread of control in the RTS. Since we intend these routines to be used + -- for implementing the Single_Lock RTS, Lock_RTS should follow the first + -- Defer_Abort operation entering RTS. In the same fashion Unlock_RTS + -- should precede the last Undefer_Abort exiting RTS. + -- + -- These routines also replace the functions Lock/Unlock_All_Tasks_List + + procedure Lock_RTS; + -- Take the global RTS lock + + procedure Unlock_RTS; + -- Release the global RTS lock + + -------------------- + -- Stack Checking -- + -------------------- + + -- Stack checking in GNAT is done using the concept of stack probes. A + -- stack probe is an operation that will generate a storage error if + -- an insufficient amount of stack space remains in the current task. + + -- The exact mechanism for a stack probe is target dependent. Typical + -- possibilities are to use a load from a non-existent page, a store to a + -- read-only page, or a comparison with some stack limit constant. Where + -- possible we prefer to use a trap on a bad page access, since this has + -- less overhead. The generation of stack probes is either automatic if + -- the ABI requires it (as on for example DEC Unix), or is controlled by + -- the gcc parameter -fstack-check. + + -- When we are using bad-page accesses, we need a bad page, called guard + -- page, at the end of each task stack. On some systems, this is provided + -- automatically, but on other systems, we need to create the guard page + -- ourselves, and the procedure Stack_Guard is provided for this purpose. + + procedure Stack_Guard (T : ST.Task_Id; On : Boolean); + -- Ensure guard page is set if one is needed and the underlying thread + -- system does not provide it. The procedure is as follows: + -- + -- 1. When we create a task adjust its size so a guard page can + -- safely be set at the bottom of the stack. + -- + -- 2. When the thread is created (and its stack allocated by the + -- underlying thread system), get the stack base (and size, depending + -- how the stack is growing), and create the guard page taking care + -- of page boundaries issues. + -- + -- 3. When the task is destroyed, remove the guard page. + -- + -- If On is true then protect the stack bottom (i.e make it read only) + -- else unprotect it (i.e. On is True for the call when creating a task, + -- and False when a task is destroyed). + -- + -- The call to Stack_Guard has no effect if guard pages are not used on + -- the target, or if guard pages are automatically provided by the system. + + ------------------------ + -- Suspension objects -- + ------------------------ + + -- These subprograms provide the functionality required for synchronizing + -- on a suspension object. Tasks can suspend execution and relinquish the + -- processors until the condition is signaled. + + function Current_State (S : Suspension_Object) return Boolean; + -- Return the state of the suspension object + + procedure Set_False (S : in out Suspension_Object); + -- Set the state of the suspension object to False + + procedure Set_True (S : in out Suspension_Object); + -- Set the state of the suspension object to True. If a task were + -- suspended on the protected object then this task is released (and + -- the state of the suspension object remains set to False). + + procedure Suspend_Until_True (S : in out Suspension_Object); + -- If the state of the suspension object is True then the calling task + -- continues its execution, and the state is set to False. If the state + -- of the object is False then the task is suspended on the suspension + -- object until a Set_True operation is executed. Program_Error is raised + -- if another task is already waiting on that suspension object. + + procedure Initialize (S : in out Suspension_Object); + -- Initialize the suspension object + + procedure Finalize (S : in out Suspension_Object); + -- Finalize the suspension object + + ----------------------------------------- + -- Runtime System Debugging Interfaces -- + ----------------------------------------- + + -- These interfaces have been added to assist in debugging the + -- tasking runtime system. + + function Check_Exit (Self_ID : ST.Task_Id) return Boolean; + pragma Inline (Check_Exit); + -- Check that the current task is holding only Global_Task_Lock + + function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean; + pragma Inline (Check_No_Locks); + -- Check that current task is holding no locks + + function Suspend_Task + (T : ST.Task_Id; + Thread_Self : OSI.Thread_Id) return Boolean; + -- Suspend a specific task when the underlying thread library provides this + -- functionality, unless the thread associated with T is Thread_Self. Such + -- functionality is needed by gdb on some targets (e.g VxWorks) Return True + -- is the operation is successful. On targets where this operation is not + -- available, a dummy body is present which always returns False. + + function Resume_Task + (T : ST.Task_Id; + Thread_Self : OSI.Thread_Id) return Boolean; + -- Resume a specific task when the underlying thread library provides + -- such functionality, unless the thread associated with T is Thread_Self. + -- Such functionality is needed by gdb on some targets (e.g VxWorks) + -- Return True is the operation is successful + + procedure Stop_All_Tasks; + -- Stop all tasks when the underlying thread library provides such + -- functionality. Such functionality is needed by gdb on some targets (e.g + -- VxWorks) This function can be run from an interrupt handler. Return True + -- is the operation is successful + + function Stop_Task (T : ST.Task_Id) return Boolean; + -- Stop a specific task when the underlying thread library provides + -- such functionality. Such functionality is needed by gdb on some targets + -- (e.g VxWorks). Return True is the operation is successful. + + function Continue_Task (T : ST.Task_Id) return Boolean; + -- Continue a specific task when the underlying thread library provides + -- such functionality. Such functionality is needed by gdb on some targets + -- (e.g VxWorks) Return True is the operation is successful + + ------------------- + -- Task affinity -- + ------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id); + -- Enforce at the operating system level the task affinity defined in the + -- Ada Task Control Block. Has no effect if the underlying operating system + -- does not support this capability. + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/libgnarl/s-tarest.adb b/gcc/ada/libgnarl/s-tarest.adb new file mode 100644 index 00000000000..4bf2df6da09 --- /dev/null +++ b/gcc/ada/libgnarl/s-tarest.adb @@ -0,0 +1,810 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G E S -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram alpha order check, since we group soft link +-- bodies and also separate off subprograms for restricted GNARLI. + +-- This is a simplified version of the System.Tasking.Stages package, +-- intended to be used in a restricted run time. + +-- This package represents the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls. + +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.Exceptions; + +with System.Task_Primitives.Operations; +with System.Soft_Links.Tasking; +with System.Storage_Elements; + +with System.Secondary_Stack; +pragma Elaborate_All (System.Secondary_Stack); +-- Make sure the body of Secondary_Stack is elaborated before calling +-- Init_Tasking_Soft_Links. See comments for this routine for explanation. + +with System.Soft_Links; +-- Used for the non-tasking routines (*_NT) that refer to global data. They +-- are needed here before the tasking run time has been elaborated. used for +-- Create_TSD This package also provides initialization routines for task +-- specific data. The GNARL must call these to be sure that all non-tasking +-- Ada constructs will work. + +package body System.Tasking.Restricted.Stages is + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + package SSE renames System.Storage_Elements; + package SST renames System.Secondary_Stack; + + use Ada.Exceptions; + + use Parameters; + use Task_Primitives.Operations; + use Task_Info; + + Tasks_Activation_Chain : Task_Id; + -- Chain of all the tasks to activate + + Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock; + -- This is a global lock; it is used to execute in mutual exclusion + -- from all other tasks. It is only used by Task_Lock and Task_Unlock. + + ----------------------------------------------------------------- + -- Tasking versions of services needed by non-tasking programs -- + ----------------------------------------------------------------- + + function Get_Current_Excep return SSL.EOA; + -- Task-safe version of SSL.Get_Current_Excep + + procedure Task_Lock; + -- Locks out other tasks. Preceding a section of code by Task_Lock and + -- following it by Task_Unlock creates a critical region. This is used + -- for ensuring that a region of non-tasking code (such as code used to + -- allocate memory) is tasking safe. Note that it is valid for calls to + -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e. + -- only the corresponding outer level Task_Unlock will actually unlock. + + procedure Task_Unlock; + -- Releases lock previously set by call to Task_Lock. In the nested case, + -- all nested locks must be released before other tasks competing for the + -- tasking lock are released. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Task_Wrapper (Self_ID : Task_Id); + -- This is the procedure that is called by the GNULL from the + -- new context when a task is created. It waits for activation + -- and then calls the task body procedure. When the task body + -- procedure completes, it terminates the task. + + procedure Terminate_Task (Self_ID : Task_Id); + -- Terminate the calling task. + -- This should only be called by the Task_Wrapper procedure. + + procedure Create_Restricted_Task + (Priority : Integer; + Stack_Address : System.Address; + Size : System.Parameters.Size_Type; + Secondary_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Task_Image : String; + Created_Task : Task_Id); + -- Code shared between Create_Restricted_Task (the concurrent version) and + -- Create_Restricted_Task_Sequential. See comment of the former in the + -- specification of this package. + + procedure Activate_Tasks (Chain : Task_Id); + -- Activate the list of tasks started by Chain + + procedure Init_RTS; + -- This procedure performs the initialization of the GNARL. + -- It consists of initializing the environment task, global locks, and + -- installing tasking versions of certain operations used by the compiler. + -- Init_RTS is called during elaboration. + + ----------------------- + -- Get_Current_Excep -- + ----------------------- + + function Get_Current_Excep return SSL.EOA is + begin + return STPO.Self.Common.Compiler_Data.Current_Excep'Access; + end Get_Current_Excep; + + --------------- + -- Task_Lock -- + --------------- + + procedure Task_Lock is + Self_ID : constant Task_Id := STPO.Self; + + begin + Self_ID.Common.Global_Task_Lock_Nesting := + Self_ID.Common.Global_Task_Lock_Nesting + 1; + + if Self_ID.Common.Global_Task_Lock_Nesting = 1 then + STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True); + end if; + end Task_Lock; + + ----------------- + -- Task_Unlock -- + ----------------- + + procedure Task_Unlock is + Self_ID : constant Task_Id := STPO.Self; + + begin + pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting > 0); + Self_ID.Common.Global_Task_Lock_Nesting := + Self_ID.Common.Global_Task_Lock_Nesting - 1; + + if Self_ID.Common.Global_Task_Lock_Nesting = 0 then + STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True); + end if; + end Task_Unlock; + + ------------------ + -- Task_Wrapper -- + ------------------ + + -- The task wrapper is a procedure that is called first for each task + -- task body, and which in turn calls the compiler-generated task body + -- procedure. The wrapper's main job is to do initialization for the task. + + -- The variable ID in the task wrapper is used to implement the Self + -- function on targets where there is a fast way to find the stack base + -- of the current thread, since it should be at a fixed offset from the + -- stack base. + + procedure Task_Wrapper (Self_ID : Task_Id) is + ID : Task_Id := Self_ID; + pragma Volatile (ID); + pragma Warnings (Off, ID); + -- Variable used on some targets to implement a fast self. We turn off + -- warnings because a stand alone volatile constant has to be imported, + -- so we don't want warnings about ID not being referenced, and volatile + -- having no effect. + -- + -- DO NOT delete ID. As noted, it is needed on some targets. + + function Secondary_Stack_Size return Storage_Elements.Storage_Offset; + -- Returns the size of the secondary stack for the task. For fixed + -- secondary stacks, the function will return the ATCB field + -- Secondary_Stack_Size if it is not set to Unspecified_Size, + -- otherwise a percentage of the stack is reserved using the + -- System.Parameters.Sec_Stack_Percentage property. + + -- Dynamic secondary stacks are allocated in System.Soft_Links. + -- Create_TSD and thus the function returns 0 to suppress the + -- creation of the fixed secondary stack in the primary stack. + + -------------------------- + -- Secondary_Stack_Size -- + -------------------------- + + function Secondary_Stack_Size return Storage_Elements.Storage_Offset is + use System.Storage_Elements; + use System.Secondary_Stack; + + begin + if Parameters.Sec_Stack_Dynamic then + return 0; + + elsif Self_ID.Common.Secondary_Stack_Size = Unspecified_Size then + return (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size + * SSE.Storage_Offset (Sec_Stack_Percentage) / 100); + else + -- Use the size specified by aspect Secondary_Stack_Size padded + -- by the amount of space used by the stack data structure. + + return Storage_Offset (Self_ID.Common.Secondary_Stack_Size) + + Storage_Offset (Minimum_Secondary_Stack_Size); + end if; + end Secondary_Stack_Size; + + Secondary_Stack : aliased Storage_Elements.Storage_Array + (1 .. Secondary_Stack_Size); + for Secondary_Stack'Alignment use Standard'Maximum_Alignment; + -- This is the secondary stack data. Note that it is critical that this + -- have maximum alignment, since any kind of data can be allocated here. + + pragma Warnings (Off); + Secondary_Stack_Address : System.Address := Secondary_Stack'Address; + pragma Warnings (On); + -- Address of secondary stack. In the fixed secondary stack case, this + -- value is not modified, causing a warning, hence the bracketing with + -- Warnings (Off/On). + + Cause : Cause_Of_Termination := Normal; + -- Indicates the reason why this task terminates. Normal corresponds to + -- a task terminating due to completing the last statement of its body. + -- If the task terminates because of an exception raised by the + -- execution of its task body, then Cause is set to Unhandled_Exception. + -- Aborts are not allowed in the restricted profile to which this file + -- belongs. + + EO : Exception_Occurrence; + -- If the task terminates because of an exception raised by the + -- execution of its task body, then EO will contain the associated + -- exception occurrence. Otherwise, it will contain Null_Occurrence. + + -- Start of processing for Task_Wrapper + + begin + if not Parameters.Sec_Stack_Dynamic then + Self_ID.Common.Compiler_Data.Sec_Stack_Addr := + Secondary_Stack'Address; + SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last)); + end if; + + -- Initialize low-level TCB components, that cannot be initialized by + -- the creator. + + Enter_Task (Self_ID); + + -- Call the task body procedure + + begin + -- We are separating the following portion of the code in order to + -- place the exception handlers in a different block. In this way we + -- do not call Set_Jmpbuf_Address (which needs Self) before we set + -- Self in Enter_Task. + + -- Note that in the case of Ravenscar HI-E where there are no + -- exception handlers, the exception handler is suppressed. + + -- Call the task body procedure + + Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg); + + -- Normal task termination + + Cause := Normal; + Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); + + exception + when E : others => + + -- Task terminating because of an unhandled exception + + Cause := Unhandled_Exception; + Save_Occurrence (EO, E); + end; + + -- Look for a fall-back handler + + -- This package is part of the restricted run time which supports + -- neither task hierarchies (No_Task_Hierarchy) nor specific task + -- termination handlers (No_Specific_Termination_Handlers). + + -- As specified in ARM C.7.3 par. 9/2, "the fall-back handler applies + -- only to the dependent tasks of the task". Hence, if the terminating + -- tasks (Self_ID) had a fall-back handler, it would not apply to + -- itself. This code is always executed by a task whose master is the + -- environment task (the task termination code for the environment task + -- is executed by SSL.Task_Termination_Handler), so the fall-back + -- handler to execute for this task can only be defined by its parent + -- (there is no grandparent). + + declare + TH : Termination_Handler := null; + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID.Common.Parent); + + TH := Self_ID.Common.Parent.Common.Fall_Back_Handler; + + Unlock (Self_ID.Common.Parent); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Execute the task termination handler if we found it + + if TH /= null then + TH.all (Cause, Self_ID, EO); + end if; + end; + + Terminate_Task (Self_ID); + end Task_Wrapper; + + ----------------------- + -- Restricted GNARLI -- + ----------------------- + + ----------------------------------- + -- Activate_All_Tasks_Sequential -- + ----------------------------------- + + procedure Activate_All_Tasks_Sequential is + begin + pragma Assert (Partition_Elaboration_Policy = 'S'); + + Activate_Tasks (Tasks_Activation_Chain); + Tasks_Activation_Chain := Null_Task; + end Activate_All_Tasks_Sequential; + + ------------------------------- + -- Activate_Restricted_Tasks -- + ------------------------------- + + procedure Activate_Restricted_Tasks + (Chain_Access : Activation_Chain_Access) is + begin + if Partition_Elaboration_Policy = 'S' then + + -- In sequential elaboration policy, the chain must be empty. This + -- procedure can be called if the unit has been compiled without + -- partition elaboration policy, but the partition has a sequential + -- elaboration policy. + + pragma Assert (Chain_Access.T_ID = Null_Task); + null; + else + Activate_Tasks (Chain_Access.T_ID); + Chain_Access.T_ID := Null_Task; + end if; + end Activate_Restricted_Tasks; + + -------------------- + -- Activate_Tasks -- + -------------------- + + -- Note that locks of activator and activated task are both locked here. + -- This is necessary because C.State and Self.Wait_Count have to be + -- synchronized. This is safe from deadlock because the activator is always + -- created before the activated task. That satisfies our + -- in-order-of-creation ATCB locking policy. + + procedure Activate_Tasks (Chain : Task_Id) is + Self_ID : constant Task_Id := STPO.Self; + C : Task_Id; + Activate_Prio : System.Any_Priority; + Success : Boolean; + + begin + pragma Assert (Self_ID = Environment_Task); + pragma Assert (Self_ID.Common.Wait_Count = 0); + + if Single_Lock then + Lock_RTS; + end if; + + -- Lock self, to prevent activated tasks from racing ahead before we + -- finish activating the chain. + + Write_Lock (Self_ID); + + -- Activate all the tasks in the chain. Creation of the thread of + -- control was deferred until activation. So create it now. + + C := Chain; + while C /= null loop + if C.Common.State /= Terminated then + pragma Assert (C.Common.State = Unactivated); + + Write_Lock (C); + + Activate_Prio := + (if C.Common.Base_Priority < Get_Priority (Self_ID) + then Get_Priority (Self_ID) + else C.Common.Base_Priority); + + STPO.Create_Task + (C, Task_Wrapper'Address, + Parameters.Size_Type + (C.Common.Compiler_Data.Pri_Stack_Info.Size), + Activate_Prio, Success); + + Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; + + if Success then + C.Common.State := Runnable; + else + raise Program_Error; + end if; + + Unlock (C); + end if; + + C := C.Common.Activation_Link; + end loop; + + Self_ID.Common.State := Activator_Sleep; + + -- Wait for the activated tasks to complete activation. It is unsafe to + -- abort any of these tasks until the count goes to zero. + + loop + exit when Self_ID.Common.Wait_Count = 0; + Sleep (Self_ID, Activator_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + end Activate_Tasks; + + ------------------------------------ + -- Complete_Restricted_Activation -- + ------------------------------------ + + -- As in several other places, the locks of the activator and activated + -- task are both locked here. This follows our deadlock prevention lock + -- ordering policy, since the activated task must be created after the + -- activator. + + procedure Complete_Restricted_Activation is + Self_ID : constant Task_Id := STPO.Self; + Activator : constant Task_Id := Self_ID.Common.Activator; + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Activator); + Write_Lock (Self_ID); + + -- Remove dangling reference to Activator, since a task may outlive its + -- activator. + + Self_ID.Common.Activator := null; + + -- Wake up the activator, if it is waiting for a chain of tasks to + -- activate, and we are the last in the chain to complete activation + + if Activator.Common.State = Activator_Sleep then + Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1; + + if Activator.Common.Wait_Count = 0 then + Wakeup (Activator, Activator_Sleep); + end if; + end if; + + Unlock (Self_ID); + Unlock (Activator); + + if Single_Lock then + Unlock_RTS; + end if; + + -- After the activation, active priority should be the same as base + -- priority. We must unlock the Activator first, though, since it should + -- not wait if we have lower priority. + + if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + end Complete_Restricted_Activation; + + ------------------------------ + -- Complete_Restricted_Task -- + ------------------------------ + + procedure Complete_Restricted_Task is + begin + STPO.Self.Common.State := Terminated; + end Complete_Restricted_Task; + + ---------------------------- + -- Create_Restricted_Task -- + ---------------------------- + + procedure Create_Restricted_Task + (Priority : Integer; + Stack_Address : System.Address; + Size : System.Parameters.Size_Type; + Secondary_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Task_Image : String; + Created_Task : Task_Id) + is + Self_ID : constant Task_Id := STPO.Self; + Base_Priority : System.Any_Priority; + Base_CPU : System.Multiprocessors.CPU_Range; + Success : Boolean; + Len : Integer; + + begin + -- Stack is not preallocated on this target, so that Stack_Address must + -- be null. + + pragma Assert (Stack_Address = Null_Address); + + Base_Priority := + (if Priority = Unspecified_Priority + then Self_ID.Common.Base_Priority + else System.Any_Priority (Priority)); + + -- Legal values of CPU are the special Unspecified_CPU value which is + -- inserted by the compiler for tasks without CPU aspect, and those in + -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise + -- the task is defined to have failed, and it becomes a completed task + -- (RM D.16(14/3)). + + if CPU /= Unspecified_CPU + and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) + or else CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) + then + raise Tasking_Error with "CPU not in range"; + + -- Normal CPU affinity + else + -- When the application code says nothing about the task affinity + -- (task without CPU aspect) then the compiler inserts the + -- Unspecified_CPU value which indicates to the run-time library that + -- the task will activate and execute on the same processor as its + -- activating task if the activating task is assigned a processor + -- (RM D.16(14/3)). + + Base_CPU := + (if CPU = Unspecified_CPU + then Self_ID.Common.Base_CPU + else System.Multiprocessors.CPU_Range (CPU)); + end if; + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + -- With no task hierarchy, the parent of all non-Environment tasks that + -- are created must be the Environment task. Dispatching domains are + -- not allowed in Ravenscar, so the dispatching domain parameter will + -- always be null. + + Initialize_ATCB + (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority, + Base_CPU, null, Task_Info, Size, Secondary_Stack_Size, + Created_Task, Success); + + -- If we do our job right then there should never be any failures, which + -- was probably said about the Titanic; so just to be safe, let's retain + -- this code for now + + if not Success then + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + raise Program_Error; + end if; + + Created_Task.Entry_Calls (1).Self := Created_Task; + + Len := + Integer'Min (Created_Task.Common.Task_Image'Length, Task_Image'Length); + Created_Task.Common.Task_Image_Len := Len; + Created_Task.Common.Task_Image (1 .. Len) := + Task_Image (Task_Image'First .. Task_Image'First + Len - 1); + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Create TSD as early as possible in the creation of a task, since it + -- may be used by the operation of Ada code within the task. + + SSL.Create_TSD (Created_Task.Common.Compiler_Data); + end Create_Restricted_Task; + + procedure Create_Restricted_Task + (Priority : Integer; + Stack_Address : System.Address; + Size : System.Parameters.Size_Type; + Secondary_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : String; + Created_Task : Task_Id) + is + begin + if Partition_Elaboration_Policy = 'S' then + + -- A unit may have been compiled without partition elaboration + -- policy, and in this case the compiler will emit calls for the + -- default policy (concurrent). But if the partition policy is + -- sequential, activation must be deferred. + + Create_Restricted_Task_Sequential + (Priority, Stack_Address, Size, Secondary_Stack_Size, + Task_Info, CPU, State, Discriminants, Elaborated, + Task_Image, Created_Task); + + else + Create_Restricted_Task + (Priority, Stack_Address, Size, Secondary_Stack_Size, + Task_Info, CPU, State, Discriminants, Elaborated, + Task_Image, Created_Task); + + -- Append this task to the activation chain + + Created_Task.Common.Activation_Link := Chain.T_ID; + Chain.T_ID := Created_Task; + end if; + end Create_Restricted_Task; + + --------------------------------------- + -- Create_Restricted_Task_Sequential -- + --------------------------------------- + + procedure Create_Restricted_Task_Sequential + (Priority : Integer; + Stack_Address : System.Address; + Size : System.Parameters.Size_Type; + Secondary_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Task_Image : String; + Created_Task : Task_Id) is + begin + Create_Restricted_Task (Priority, Stack_Address, Size, + Secondary_Stack_Size, Task_Info, + CPU, State, Discriminants, Elaborated, + Task_Image, Created_Task); + + -- Append this task to the activation chain + + Created_Task.Common.Activation_Link := Tasks_Activation_Chain; + Tasks_Activation_Chain := Created_Task; + end Create_Restricted_Task_Sequential; + + --------------------------- + -- Finalize_Global_Tasks -- + --------------------------- + + -- This is needed to support the compiler interface; it will only be called + -- by the Environment task. Instead, it will cause the Environment to block + -- forever, since none of the dependent tasks are expected to terminate + + procedure Finalize_Global_Tasks is + Self_ID : constant Task_Id := STPO.Self; + + begin + pragma Assert (Self_ID = STPO.Environment_Task); + + if Single_Lock then + Lock_RTS; + end if; + + -- Handle normal task termination by the environment task, but only for + -- the normal task termination. In the case of Abnormal and + -- Unhandled_Exception they must have been handled before, and the task + -- termination soft link must have been changed so the task termination + -- routine is not executed twice. + + -- Note that in the "normal" implementation in s-tassta.adb the task + -- termination procedure for the environment task should be executed + -- after termination of library-level tasks. However, this + -- implementation is to be used when the Ravenscar restrictions are in + -- effect, and AI-394 says that if there is a fall-back handler set for + -- the partition it should be called when the first task (including the + -- environment task) attempts to terminate. + + SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence); + + Write_Lock (Self_ID); + Sleep (Self_ID, Master_Completion_Sleep); + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Should never return from Master Completion Sleep + + raise Program_Error; + end Finalize_Global_Tasks; + + --------------------------- + -- Restricted_Terminated -- + --------------------------- + + function Restricted_Terminated (T : Task_Id) return Boolean is + begin + return T.Common.State = Terminated; + end Restricted_Terminated; + + -------------------- + -- Terminate_Task -- + -------------------- + + procedure Terminate_Task (Self_ID : Task_Id) is + begin + Self_ID.Common.State := Terminated; + end Terminate_Task; + + -------------- + -- Init_RTS -- + -------------- + + procedure Init_RTS is + begin + Tasking.Initialize; + + -- Initialize lock used to implement mutual exclusion between all tasks + + STPO.Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level); + + -- Notify that the tasking run time has been elaborated so that + -- the tasking version of the soft links can be used. + + SSL.Lock_Task := Task_Lock'Access; + SSL.Unlock_Task := Task_Unlock'Access; + SSL.Adafinal := Finalize_Global_Tasks'Access; + SSL.Get_Current_Excep := Get_Current_Excep'Access; + + -- Initialize the tasking soft links (if not done yet) that are common + -- to the full and the restricted run times. + + SSL.Tasking.Init_Tasking_Soft_Links; + end Init_RTS; + +begin + Init_RTS; +end System.Tasking.Restricted.Stages; diff --git a/gcc/ada/libgnarl/s-tarest.ads b/gcc/ada/libgnarl/s-tarest.ads new file mode 100644 index 00000000000..ccc5683bd31 --- /dev/null +++ b/gcc/ada/libgnarl/s-tarest.ads @@ -0,0 +1,264 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G 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 simplified version of the System.Tasking.Stages package, +-- intended to be used in a restricted run time. + +-- This package represents the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls +-- (aka GNARLI, GNU Ada Run-time Library Interface) + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes +-- in exp_ch9.adb and possibly exp_ch7.adb + +-- The restricted GNARLI is also composed of System.Protected_Objects and +-- System.Protected_Objects.Single_Entry + +with System.Task_Info; +with System.Parameters; + +package System.Tasking.Restricted.Stages is + pragma Elaborate_Body; + + --------------------------------- + -- Compiler Interface (GNARLI) -- + --------------------------------- + + -- The compiler will expand in the GNAT tree the following construct: + + -- task type T (Discr : Integer); + + -- task body T is + -- ...declarations, possibly some controlled... + -- begin + -- ...B...; + -- end T; + + -- T1 : T (1); + + -- as follows: + + -- task type t (discr : integer); + -- tE : aliased boolean := false; + -- tZ : size_type := unspecified_size; + + -- type tV (discr : integer) is limited record + -- _task_id : task_id; + -- _atcb : aliased system__tasking__ada_task_control_block (0); + -- end record; + + -- procedure tB (_task : access tV); + -- freeze tV [ + -- procedure tVIP (_init : in out tV; _master : master_id; + -- _chain : in out activation_chain; _task_name : in string; + -- discr : integer) is + -- begin + -- _init.discr := discr; + -- _init._task_id := null; + -- system__tasking__ada_task_control_blockIP (_init._atcb, 0); + -- _init._task_id := _init._atcb'unchecked_access; + -- create_restricted_task (unspecified_priority, tZ, + -- unspecified_task_info, unspecified_cpu, + -- task_procedure_access!(tB'address), _init'address, + -- tE'unchecked_access, _task_name, _init._task_id); + -- return; + -- end tVIP; + + -- _chain : aliased activation_chain; + -- activation_chainIP (_chain); + + -- procedure tB (_task : access tV) is + -- discr : integer renames _task.discr; + + -- procedure _clean is + -- begin + -- complete_restricted_task; + -- finalize_list (F14b); + -- return; + -- end _clean; + + -- begin + -- ...declarations... + -- complete_restricted_activation; + -- ...B...; + -- return; + -- at end + -- _clean; + -- end tB; + + -- tE := true; + -- t1 : t (1); + -- t1S : constant String := "t1"; + -- tIP (t1, 3, _chain, t1S, 1); + + Partition_Elaboration_Policy : Character := 'C'; + pragma Export (C, Partition_Elaboration_Policy, + "__gnat_partition_elaboration_policy"); + -- Partition elaboration policy. Value can be either 'C' for concurrent, + -- which is the default or 'S' for sequential. This value can be modified + -- by the binder generated code, before calling elaboration code. + + procedure Create_Restricted_Task + (Priority : Integer; + Stack_Address : System.Address; + Size : System.Parameters.Size_Type; + Secondary_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : String; + Created_Task : Task_Id); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called to create a new task, when the partition + -- elaboration policy is not specified (or is concurrent). + -- + -- Priority is the task's priority (assumed to be in the + -- System.Any_Priority'Range) + -- + -- Stack_Address is the start address of the stack associated to the task, + -- in case it has been preallocated by the compiler; it is equal to + -- Null_Address when the stack needs to be allocated by the underlying + -- operating system. + -- + -- Size is the stack size of the task to create + -- + -- Secondary_Stack_Size is the secondary stack size of the task to create + -- + -- Task_Info is the task info associated with the created task, or + -- Unspecified_Task_Info if none. + -- + -- CPU is the task affinity. We pass it as an Integer to avoid an explicit + -- dependency from System.Multiprocessors when not needed. Static range + -- checks are performed when analyzing the pragma, and dynamic ones are + -- performed before setting the affinity at run time. + -- + -- State is the compiler generated task's procedure body + -- + -- Discriminants is a pointer to a limited record whose discriminants are + -- those of the task to create. This parameter should be passed as the + -- single argument to State. + -- + -- Elaborated is a pointer to a Boolean that must be set to true on exit + -- if the task could be successfully elaborated. + -- + -- Chain is a linked list of task that needs to be created. On exit, + -- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID will be + -- Created_Task (the created task will be linked at the front of Chain). + -- + -- Task_Image is a string created by the compiler that the run time can + -- store to ease the debugging and the Ada.Task_Identification facility. + -- + -- Created_Task is the resulting task. + -- + -- This procedure can raise Storage_Error if the task creation fails + + procedure Create_Restricted_Task_Sequential + (Priority : Integer; + Stack_Address : System.Address; + Size : System.Parameters.Size_Type; + Secondary_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Task_Image : String; + Created_Task : Task_Id); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called to create a new task, when the sequential partition + -- elaboration policy is used. + -- + -- The parameters are the same as Create_Restricted_Task except there is + -- no Chain parameter (for the activation chain), as there is only one + -- global activation chain, which is declared in the body of this package. + + procedure Activate_Restricted_Tasks + (Chain_Access : Activation_Chain_Access); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called by the creator of a chain of one or more new tasks, + -- to activate them. The chain is a linked list that up to this point is + -- only known to the task that created them, though the individual tasks + -- are already in the All_Tasks_List. + -- + -- The compiler builds the chain in LIFO order (as a stack). Another + -- version of this procedure had code to reverse the chain, so as to + -- activate the tasks in the order of declaration. This might be nice, but + -- it is not needed if priority-based scheduling is supported, since all + -- the activated tasks synchronize on the activators lock before they start + -- activating and so they should start activating in priority order. + -- + -- When the partition elaboration policy is sequential, this procedure + -- does nothing, tasks will be activated at end of elaboration. + + procedure Activate_All_Tasks_Sequential; + pragma Export (C, Activate_All_Tasks_Sequential, + "__gnat_activate_all_tasks"); + -- Binder interface only. Do not call from within the RTS. This must be + -- called an the end of the elaboration to activate all tasks, in order + -- to implement the sequential elaboration policy. + + procedure Complete_Restricted_Activation; + -- Compiler interface only. Do not call from within the RTS. This should be + -- called from the task body at the end of the elaboration code for its + -- declarative part. Decrement the count of tasks to be activated by the + -- activator and wake it up so it can check to see if all tasks have been + -- activated. Except for the environment task, which should never call this + -- procedure, T.Activator should only be null iff T has completed + -- activation. + + procedure Complete_Restricted_Task; + -- Compiler interface only. Do not call from within the RTS. This should be + -- called from an implicit at-end handler associated with the task body, + -- when it completes. From this point, the current task will become not + -- callable. If the current task have not completed activation, this should + -- be done now in order to wake up the activator (the environment task). + + function Restricted_Terminated (T : Task_Id) return Boolean; + -- Compiler interface only. Do not call from within the RTS. This is called + -- by the compiler to implement the 'Terminated attribute. + -- + -- source code: + -- T1'Terminated + -- + -- code expansion: + -- restricted_terminated (t1._task_id) + + procedure Finalize_Global_Tasks; + -- This is needed to support the compiler interface. It will only be called + -- by the Environment task in the binder generated file (by adafinal). + -- Instead, it will cause the Environment to block forever, since none of + -- the dependent tasks are expected to terminate + +end System.Tasking.Restricted.Stages; diff --git a/gcc/ada/libgnarl/s-tasdeb.adb b/gcc/ada/libgnarl/s-tasdeb.adb new file mode 100644 index 00000000000..26b81fc0506 --- /dev/null +++ b/gcc/ada/libgnarl/s-tasdeb.adb @@ -0,0 +1,470 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . D E B U G -- +-- -- +-- 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 package encapsulates all direct interfaces to task debugging services +-- that are needed by gdb with gnat mode. + +-- Note : This file *must* be compiled with debugging information + +-- Do not add any dependency to GNARL packages since this package is used +-- in both normal and restricted (ravenscar) environments. + +pragma Restriction_Warnings (No_Secondary_Stack); +-- We wish to avoid secondary stack usage here, because (e.g.) Trace is called +-- at delicate times, such as during task termination after the secondary +-- stack has been deallocated. It's just a warning, so we don't require +-- partition-wide consistency. + +with System.CRTL; +with System.Storage_Elements; use System.Storage_Elements; +with System.Task_Primitives; +with System.Task_Primitives.Operations; + +package body System.Tasking.Debug is + + package STPO renames System.Task_Primitives.Operations; + + type Trace_Flag_Set is array (Character) of Boolean; + + Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True); + + Stderr_Fd : constant := 2; + -- File descriptor for standard error + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Write (Fd : Integer; S : String; Count : Integer); + -- Write Count characters of S to the file descriptor Fd + + procedure Put (S : String); + -- Display S on standard error + + procedure Put_Line (S : String := ""); + -- Display S on standard error with an additional line terminator + + procedure Put_Task_Image (T : Task_Id); + -- Display relevant characters from T.Common.Task_Image on standard error + + procedure Put_Task_Id_Image (T : Task_Id); + -- Display address in hexadecimal form on standard error + + ------------------------ + -- Continue_All_Tasks -- + ------------------------ + + procedure Continue_All_Tasks is + C : Task_Id; + Dummy : Boolean; + + begin + STPO.Lock_RTS; + + C := All_Tasks_List; + while C /= null loop + Dummy := STPO.Continue_Task (C); + C := C.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + end Continue_All_Tasks; + + -------------------- + -- Get_User_State -- + -------------------- + + function Get_User_State return Long_Integer is + begin + return STPO.Self.User_State; + end Get_User_State; + + ---------------- + -- List_Tasks -- + ---------------- + + procedure List_Tasks is + C : Task_Id; + begin + C := All_Tasks_List; + while C /= null loop + Print_Task_Info (C); + C := C.Common.All_Tasks_Link; + end loop; + end List_Tasks; + + ------------------------ + -- Print_Current_Task -- + ------------------------ + + procedure Print_Current_Task is + begin + Print_Task_Info (STPO.Self); + end Print_Current_Task; + + --------------------- + -- Print_Task_Info -- + --------------------- + + procedure Print_Task_Info (T : Task_Id) is + Entry_Call : Entry_Call_Link; + Parent : Task_Id; + + begin + if T = null then + Put_Line ("null task"); + return; + end if; + + Put_Task_Image (T); + Put (": " & Task_States'Image (T.Common.State)); + Parent := T.Common.Parent; + + if Parent = null then + Put (", parent: "); + else + Put (", parent: "); + Put_Task_Image (Parent); + end if; + + Put (", prio:" & T.Common.Current_Priority'Img); + + if not T.Callable then + Put (", not callable"); + end if; + + if T.Aborting then + Put (", aborting"); + end if; + + if T.Deferral_Level /= 0 then + Put (", abort deferred"); + end if; + + if T.Common.Call /= null then + Entry_Call := T.Common.Call; + Put (", serving:"); + + while Entry_Call /= null loop + Put_Task_Id_Image (Entry_Call.Self); + Entry_Call := Entry_Call.Acceptor_Prev_Call; + end loop; + end if; + + if T.Open_Accepts /= null then + Put (", accepting:"); + + for J in T.Open_Accepts'Range loop + Put (T.Open_Accepts (J).S'Img); + end loop; + + if T.Terminate_Alternative then + Put (" or terminate"); + end if; + end if; + + if T.User_State /= 0 then + Put (", state:" & T.User_State'Img); + end if; + + Put_Line; + end Print_Task_Info; + + --------- + -- Put -- + --------- + + procedure Put (S : String) is + begin + Write (Stderr_Fd, S, S'Length); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (S : String := "") is + begin + Write (Stderr_Fd, S & ASCII.LF, S'Length + 1); + end Put_Line; + + ----------------------- + -- Put_Task_Id_Image -- + ----------------------- + + procedure Put_Task_Id_Image (T : Task_Id) is + Address_Image_Length : constant := + 13 + (if Standard'Address_Size = 64 then 10 else 0); + -- Length of string to be printed for address of task + + H : constant array (0 .. 15) of Character := "0123456789ABCDEF"; + -- Table of hex digits + + S : String (1 .. Address_Image_Length); + P : Natural; + N : Integer_Address; + U : Natural := 0; + + begin + if T = null then + Put ("Null_Task_Id"); + + else + S (S'Last) := '#'; + P := Address_Image_Length - 1; + N := To_Integer (T.all'Address); + while P > 3 loop + if U = 4 then + S (P) := '_'; + P := P - 1; + U := 1; + else + U := U + 1; + end if; + + S (P) := H (Integer (N mod 16)); + P := P - 1; + N := N / 16; + end loop; + + S (1 .. 3) := "16#"; + Put (S); + end if; + end Put_Task_Id_Image; + + -------------------- + -- Put_Task_Image -- + -------------------- + + procedure Put_Task_Image (T : Task_Id) is + begin + -- In case T.Common.Task_Image_Len is uninitialized junk, we check that + -- it is in range, to make this more robust. + + if T.Common.Task_Image_Len in T.Common.Task_Image'Range then + Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len)); + else + Put (T.Common.Task_Image); + end if; + end Put_Task_Image; + + ---------------------- + -- Resume_All_Tasks -- + ---------------------- + + procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is + C : Task_Id; + Dummy : Boolean; + + begin + STPO.Lock_RTS; + + C := All_Tasks_List; + while C /= null loop + Dummy := STPO.Resume_Task (C, Thread_Self); + C := C.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + end Resume_All_Tasks; + + --------------- + -- Set_Trace -- + --------------- + + procedure Set_Trace (Flag : Character; Value : Boolean := True) is + begin + Trace_On (Flag) := Value; + end Set_Trace; + + -------------------- + -- Set_User_State -- + -------------------- + + procedure Set_User_State (Value : Long_Integer) is + begin + STPO.Self.User_State := Value; + end Set_User_State; + + ------------------------ + -- Signal_Debug_Event -- + ------------------------ + + procedure Signal_Debug_Event + (Event_Kind : Event_Kind_Type; + Task_Value : Task_Id) + is + begin + null; + end Signal_Debug_Event; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + C : Task_Id; + Dummy : Boolean; + + begin + STPO.Lock_RTS; + + C := All_Tasks_List; + while C /= null loop + Dummy := STPO.Stop_Task (C); + C := C.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + end Stop_All_Tasks; + + ---------------------------- + -- Stop_All_Tasks_Handler -- + ---------------------------- + + procedure Stop_All_Tasks_Handler is + begin + STPO.Stop_All_Tasks; + end Stop_All_Tasks_Handler; + + ----------------------- + -- Suspend_All_Tasks -- + ----------------------- + + procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is + C : Task_Id; + Dummy : Boolean; + + begin + STPO.Lock_RTS; + + C := All_Tasks_List; + while C /= null loop + Dummy := STPO.Suspend_Task (C, Thread_Self); + C := C.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + end Suspend_All_Tasks; + + ------------------------ + -- Task_Creation_Hook -- + ------------------------ + + procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is + pragma Inspection_Point (Thread); + -- gdb needs to access the thread parameter in order to implement + -- the multitask mode under VxWorks. + + begin + null; + end Task_Creation_Hook; + + --------------------------- + -- Task_Termination_Hook -- + --------------------------- + + procedure Task_Termination_Hook is + begin + null; + end Task_Termination_Hook; + + ----------- + -- Trace -- + ----------- + + procedure Trace + (Self_Id : Task_Id; + Msg : String; + Flag : Character; + Other_Id : Task_Id := null) + is + begin + if Trace_On (Flag) then + Put_Task_Id_Image (Self_Id); + Put (":" & Flag & ":"); + Put_Task_Image (Self_Id); + Put (":"); + + if Other_Id /= null then + Put_Task_Id_Image (Other_Id); + Put (":"); + end if; + + Put_Line (Msg); + end if; + end Trace; + + ----------- + -- Write -- + ----------- + + procedure Write (Fd : Integer; S : String; Count : Integer) is + Discard : System.CRTL.ssize_t; + -- Ignore write errors here; this is just debugging output, and there's + -- nothing to be done about errors anyway. + begin + Discard := + System.CRTL.write + (Fd, S'Address, System.CRTL.size_t (Count)); + end Write; + + ----------------- + -- Master_Hook -- + ----------------- + + procedure Master_Hook + (Dependent : Task_Id; + Parent : Task_Id; + Master_Level : Integer) + is + pragma Inspection_Point (Dependent); + pragma Inspection_Point (Parent); + pragma Inspection_Point (Master_Level); + begin + null; + end Master_Hook; + + --------------------------- + -- Master_Completed_Hook -- + --------------------------- + + procedure Master_Completed_Hook + (Self_ID : Task_Id; + Master_Level : Integer) + is + pragma Inspection_Point (Self_ID); + pragma Inspection_Point (Master_Level); + begin + null; + end Master_Completed_Hook; + +end System.Tasking.Debug; diff --git a/gcc/ada/libgnarl/s-tasdeb.ads b/gcc/ada/libgnarl/s-tasdeb.ads new file mode 100644 index 00000000000..73a0030a397 --- /dev/null +++ b/gcc/ada/libgnarl/s-tasdeb.ads @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . D E B U G -- +-- -- +-- 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 package encapsulates all direct interfaces to task debugging services +-- that are needed by gdb with gnat mode. + +with System.Tasking; +with System.OS_Interface; + +package System.Tasking.Debug is + pragma Preelaborate; + + ------------------------------------------ + -- Application-level debugging routines -- + ------------------------------------------ + + procedure List_Tasks; + -- Print a list of all the known Ada tasks with abbreviated state + -- information, one-per-line, to the standard error file. + + procedure Print_Current_Task; + -- Write information about current task, in hexadecimal, as one line, to + -- the standard error file. + + procedure Print_Task_Info (T : Task_Id); + -- Similar to Print_Current_Task, for a given task + + procedure Set_User_State (Value : Long_Integer); + -- Set user state value in the current task. This state will be displayed + -- when calling List_Tasks or Print_Current_Task. It is useful for setting + -- task specific state. + + function Get_User_State return Long_Integer; + -- Return the user state for the current task + + ------------------------- + -- General GDB support -- + ------------------------- + + Known_Tasks : array (0 .. 999) of Task_Id := (others => null); + -- Global array of tasks read by gdb, and updated by Create_Task and + -- Finalize_TCB + + Debug_Event_Activating : constant := 1; + Debug_Event_Run : constant := 2; + Debug_Event_Suspended : constant := 3; + Debug_Event_Preempted : constant := 4; + Debug_Event_Terminated : constant := 5; + Debug_Event_Abort_Terminated : constant := 6; + Debug_Event_Exception_Terminated : constant := 7; + Debug_Event_Rendezvous_Exception : constant := 8; + Debug_Event_Handled : constant := 9; + Debug_Event_Dependents_Exception : constant := 10; + Debug_Event_Handled_Others : constant := 11; + + subtype Event_Kind_Type is Positive range 1 .. 11; + -- Event kinds currently defined for debugging, used globally + -- below and on a per task basis. + + procedure Signal_Debug_Event + (Event_Kind : Event_Kind_Type; + Task_Value : Task_Id); + + ---------------------------------- + -- VxWorks specific GDB support -- + ---------------------------------- + + -- Although the following routines are implemented in a target independent + -- manner, only VxWorks currently uses them. + + procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id); + -- This procedure is used to notify GDB of task's creation. It must be + -- called by the task's creator. + + procedure Task_Termination_Hook; + -- This procedure is used to notify GDB of task's termination + + procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id); + -- Suspend all the tasks except the one whose associated thread is + -- Thread_Self by traversing All_Tasks_List and calling + -- System.Task_Primitives.Operations.Suspend_Task. + + procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id); + -- Resume all the tasks except the one whose associated thread is + -- Thread_Self by traversing All_Tasks_List and calling + -- System.Task_Primitives.Operations.Continue_Task. + + procedure Stop_All_Tasks_Handler; + -- Stop all the tasks by traversing All_Tasks_List and calling + -- System.Task_Primitives.Operations.Stop_All_Task. This function + -- can be used in an interrupt handler. + + procedure Stop_All_Tasks; + -- Stop all the tasks by traversing All_Tasks_List and calling + -- System.Task_Primitives.Operations.Stop_Task. + + procedure Continue_All_Tasks; + -- Continue all the tasks by traversing All_Tasks_List and calling + -- System.Task_Primitives.Operations.Continue_Task. + + ------------------------------- + -- Run-time tracing routines -- + ------------------------------- + + procedure Trace + (Self_Id : Task_Id; + Msg : String; + Flag : Character; + Other_Id : Task_Id := null); + -- If traces for Flag are enabled, display on Standard_Error a given + -- message for the current task. Other_Id is an optional second task id + -- to display. + + procedure Set_Trace + (Flag : Character; + Value : Boolean := True); + -- Enable or disable tracing for Flag. By default, flags in the range + -- 'A' .. 'Z' are disabled, others are enabled. + + --------------------------------- + -- Hooks for Valgrind/Helgrind -- + --------------------------------- + + procedure Master_Hook + (Dependent : Task_Id; + Parent : Task_Id; + Master_Level : Integer); + -- Indicate to Valgrind/Helgrind that the master of Dependent is + -- Parent + Master_Level. + + procedure Master_Completed_Hook + (Self_ID : Task_Id; + Master_Level : Integer); + -- Indicate to Valgrind/Helgrind that Self_ID has completed the master + -- Master_Level. + +end System.Tasking.Debug; 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-tasinf.adb b/gcc/ada/libgnarl/s-tasinf.adb new file mode 100644 index 00000000000..cc2e6fef164 --- /dev/null +++ b/gcc/ada/libgnarl/s-tasinf.adb @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- B o d y -- +-- (Compiler Interface) -- +-- -- +-- Copyright (C) 1998-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 a dummy version of this package that is needed to solve bootstrap +-- problems when compiling a library that doesn't require s-tasinf.adb from +-- a compiler that contains one. + +-- This package contains the definitions and routines associated with the +-- implementation of the Task_Info pragma. + +package body System.Task_Info is +end System.Task_Info; diff --git a/gcc/ada/libgnarl/s-tasinf.ads b/gcc/ada/libgnarl/s-tasinf.ads new file mode 100644 index 00000000000..804f001bc68 --- /dev/null +++ b/gcc/ada/libgnarl/s-tasinf.ads @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- 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. + +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 -- + ------------------ + + type Scope_Type is + (Process_Scope, + -- Contend only with threads in same process + + System_Scope, + -- Contend with all threads on same CPU + + Default_Scope); + + type Task_Info_Type is new Scope_Type; + -- Type used for passing information to task create call, using the + -- Task_Info pragma. This type may be specialized for individual + -- implementations, but it must be a type that can be used as a + -- discriminant (i.e. a scalar or access type). + + Unspecified_Task_Info : constant Task_Info_Type := Default_Scope; + -- Value passed to task in the absence of a Task_Info pragma + +end System.Task_Info; diff --git a/gcc/ada/libgnarl/s-tasini.adb b/gcc/ada/libgnarl/s-tasini.adb new file mode 100644 index 00000000000..21404d0cd52 --- /dev/null +++ b/gcc/ada/libgnarl/s-tasini.adb @@ -0,0 +1,785 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . I N I T I A L I Z A T I O N -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram alpha ordering check, since we group soft link bodies +-- and dummy soft link bodies together separately in this unit. + +pragma Polling (Off); +-- Turn polling off for this package. We don't need polling during any of the +-- routines in this package, and more to the point, if we try to poll it can +-- cause infinite loops. + +with System.Task_Primitives; +with System.Task_Primitives.Operations; +with System.Soft_Links; +with System.Soft_Links.Tasking; +with System.Tasking.Debug; +with System.Tasking.Task_Attributes; +with System.Parameters; + +with System.Secondary_Stack; +pragma Elaborate_All (System.Secondary_Stack); +pragma Unreferenced (System.Secondary_Stack); +-- Make sure the body of Secondary_Stack is elaborated before calling +-- Init_Tasking_Soft_Links. See comments for this routine for explanation. + +package body System.Tasking.Initialization is + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + + use Parameters; + use Task_Primitives.Operations; + + Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock; + -- This is a global lock; it is used to execute in mutual exclusion from + -- all other tasks. It is only used by Task_Lock, Task_Unlock, and + -- Final_Task_Unlock. + + ---------------------------------------------------------------------- + -- Tasking versions of some services needed by non-tasking programs -- + ---------------------------------------------------------------------- + + procedure Abort_Defer; + -- NON-INLINE versions without Self_ID for soft links + + procedure Abort_Undefer; + -- NON-INLINE versions without Self_ID for soft links + + procedure Task_Lock; + -- Locks out other tasks. Preceding a section of code by Task_Lock and + -- following it by Task_Unlock creates a critical region. This is used + -- for ensuring that a region of non-tasking code (such as code used to + -- allocate memory) is tasking safe. Note that it is valid for calls to + -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e. + -- only the corresponding outer level Task_Unlock will actually unlock. + + procedure Task_Unlock; + -- Releases lock previously set by call to Task_Lock. In the nested case, + -- all nested locks must be released before other tasks competing for the + -- tasking lock are released. + + function Get_Current_Excep return SSL.EOA; + -- Task-safe version of SSL.Get_Current_Excep + + function Task_Name return String; + -- Returns current task's name + + ------------------------ + -- Local Subprograms -- + ------------------------ + + ---------------------------- + -- Tasking Initialization -- + ---------------------------- + + procedure Init_RTS; + -- This procedure completes the initialization of the GNARL. The first part + -- of the initialization is done in the body of System.Tasking. It consists + -- of initializing global locks, and installing tasking versions of certain + -- operations used by the compiler. Init_RTS is called during elaboration. + + -------------------------- + -- Change_Base_Priority -- + -------------------------- + + -- Call only with abort deferred and holding Self_ID locked + + procedure Change_Base_Priority (T : Task_Id) is + begin + if T.Common.Base_Priority /= T.New_Base_Priority then + T.Common.Base_Priority := T.New_Base_Priority; + Set_Priority (T, T.Common.Base_Priority); + end if; + end Change_Base_Priority; + + ------------------------ + -- Check_Abort_Status -- + ------------------------ + + function Check_Abort_Status return Integer is + Self_ID : constant Task_Id := Self; + begin + if Self_ID /= null + and then Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + then + return 1; + else + return 0; + end if; + end Check_Abort_Status; + + ----------------- + -- Defer_Abort -- + ----------------- + + procedure Defer_Abort (Self_ID : Task_Id) is + begin + if No_Abort then + return; + end if; + + pragma Assert (Self_ID.Deferral_Level = 0); + + -- pragma Assert + -- (Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level); + + -- The above check has been useful in detecting mismatched defer/undefer + -- pairs. You may uncomment it when testing on systems that support + -- preemptive abort. + + -- If the OS supports preemptive abort (e.g. pthread_kill), it should + -- have happened already. A problem is with systems that do not support + -- preemptive abort, and so rely on polling. On such systems we may get + -- false failures of the assertion, since polling for pending abort does + -- no occur until the abort undefer operation. + + -- Even on systems that only poll for abort, the assertion may be useful + -- for catching missed abort completion polling points. The operations + -- that undefer abort poll for pending aborts. This covers most of the + -- places where the core Ada semantics require abort to be caught, + -- without any special attention. However, this generally happens on + -- exit from runtime system call, which means a pending abort will not + -- be noticed on the way into the runtime system. We considered adding a + -- check for pending aborts at this point, but chose not to, because of + -- the overhead. Instead, we searched for RTS calls where abort + -- completion is required and a task could go farther than Ada allows + -- before undeferring abort; we then modified the code to ensure the + -- abort would be detected. + + Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; + end Defer_Abort; + + -------------------------- + -- Defer_Abort_Nestable -- + -------------------------- + + procedure Defer_Abort_Nestable (Self_ID : Task_Id) is + begin + if No_Abort then + return; + end if; + + -- The following assertion is by default disabled. See the comment in + -- Defer_Abort on the situations in which it may be useful to uncomment + -- this assertion and enable the test. + + -- pragma Assert + -- (Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level or else + -- Self_ID.Deferral_Level > 0); + + Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; + end Defer_Abort_Nestable; + + ----------------- + -- Abort_Defer -- + ----------------- + + procedure Abort_Defer is + Self_ID : Task_Id; + begin + if No_Abort then + return; + end if; + + Self_ID := STPO.Self; + Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; + end Abort_Defer; + + ----------------------- + -- Get_Current_Excep -- + ----------------------- + + function Get_Current_Excep return SSL.EOA is + begin + return STPO.Self.Common.Compiler_Data.Current_Excep'Access; + end Get_Current_Excep; + + ----------------------- + -- Do_Pending_Action -- + ----------------------- + + -- Call only when holding no locks + + procedure Do_Pending_Action (Self_ID : Task_Id) is + + begin + pragma Assert (Self_ID = Self and then Self_ID.Deferral_Level = 0); + + -- Needs loop to recheck for pending action in case a new one occurred + -- while we had abort deferred below. + + loop + -- Temporarily defer abort so that we can lock Self_ID + + Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + Self_ID.Pending_Action := False; + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Restore the original Deferral value + + Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; + + if not Self_ID.Pending_Action then + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then + if not Self_ID.Aborting then + Self_ID.Aborting := True; + pragma Debug + (Debug.Trace (Self_ID, "raise Abort_Signal", 'B')); + raise Standard'Abort_Signal; + + pragma Assert (not Self_ID.ATC_Hack); + + elsif Self_ID.ATC_Hack then + + -- The solution really belongs in the Abort_Signal handler + -- for async. entry calls. The present hack is very + -- fragile. It relies that the very next point after + -- Exit_One_ATC_Level at which the task becomes abortable + -- will be the call to Undefer_Abort in the + -- Abort_Signal handler. + + Self_ID.ATC_Hack := False; + + pragma Debug + (Debug.Trace + (Self_ID, "raise Abort_Signal (ATC hack)", 'B')); + raise Standard'Abort_Signal; + end if; + end if; + + return; + end if; + end loop; + end Do_Pending_Action; + + ----------------------- + -- Final_Task_Unlock -- + ----------------------- + + -- This version is only for use in Terminate_Task, when the task is + -- relinquishing further rights to its own ATCB. + + -- There is a very interesting potential race condition there, where the + -- old task may run concurrently with a new task that is allocated the old + -- tasks (now reused) ATCB. The critical thing here is to not make any + -- reference to the ATCB after the lock is released. See also comments on + -- Terminate_Task and Unlock. + + procedure Final_Task_Unlock (Self_ID : Task_Id) is + begin + pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting = 1); + Unlock (Global_Task_Lock'Access, Global_Lock => True); + end Final_Task_Unlock; + + -------------- + -- Init_RTS -- + -------------- + + procedure Init_RTS is + Self_Id : Task_Id; + begin + Tasking.Initialize; + + -- Terminate run time (regular vs restricted) specific initialization + -- of the environment task. + + Self_Id := Environment_Task; + Self_Id.Master_of_Task := Environment_Task_Level; + Self_Id.Master_Within := Self_Id.Master_of_Task + 1; + + for L in Self_Id.Entry_Calls'Range loop + Self_Id.Entry_Calls (L).Self := Self_Id; + Self_Id.Entry_Calls (L).Level := L; + end loop; + + Self_Id.Awake_Count := 1; + Self_Id.Alive_Count := 1; + + -- Normally, a task starts out with internal master nesting level one + -- larger than external master nesting level. It is incremented to one + -- by Enter_Master, which is called in the task body only if the + -- compiler thinks the task may have dependent tasks. There is no + -- corresponding call to Enter_Master for the environment task, so we + -- would need to increment it to 2 here. Instead, we set it to 3. By + -- doing this we reserve the level 2 for server tasks of the runtime + -- system. The environment task does not need to wait for these server + + Self_Id.Master_Within := Library_Task_Level; + + -- Initialize lock used to implement mutual exclusion between all tasks + + Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level); + + -- Notify that the tasking run time has been elaborated so that + -- the tasking version of the soft links can be used. + + if not No_Abort then + SSL.Abort_Defer := Abort_Defer'Access; + SSL.Abort_Undefer := Abort_Undefer'Access; + end if; + + SSL.Lock_Task := Task_Lock'Access; + SSL.Unlock_Task := Task_Unlock'Access; + SSL.Check_Abort_Status := Check_Abort_Status'Access; + SSL.Task_Name := Task_Name'Access; + SSL.Get_Current_Excep := Get_Current_Excep'Access; + + -- Initialize the tasking soft links (if not done yet) that are common + -- to the full and the restricted run times. + + SSL.Tasking.Init_Tasking_Soft_Links; + + -- Abort is deferred in a new ATCB, so we need to undefer abort at this + -- stage to make the environment task abortable. + + Undefer_Abort (Environment_Task); + end Init_RTS; + + --------------------------- + -- Locked_Abort_To_Level-- + --------------------------- + + -- Abort a task to the specified ATC nesting level. + -- Call this only with T locked. + + -- An earlier version of this code contained a call to Wakeup. That should + -- not be necessary here, if Abort_Task is implemented correctly, since + -- Abort_Task should include the effect of Wakeup. However, the above call + -- was in earlier versions of this file, and at least for some targets + -- Abort_Task has not been doing Wakeup. It should not hurt to uncomment + -- the above call, until the error is corrected for all targets. + + -- See extended comments in package body System.Tasking.Abort for the + -- overall design of the implementation of task abort. + -- ??? there is no such package ??? + + -- If the task is sleeping it will be in an abort-deferred region, and will + -- not have Abort_Signal raised by Abort_Task. Such an "abort deferral" is + -- just to protect the RTS internals, and not necessarily required to + -- enforce Ada semantics. Abort_Task should wake the task up and let it + -- decide if it wants to complete the aborted construct immediately. + + -- Note that the effect of the low-level Abort_Task is not persistent. + -- If the target task is not blocked, this wakeup will be missed. + + -- We don't bother calling Abort_Task if this task is aborting itself, + -- since we are inside the RTS and have abort deferred. Similarly, We don't + -- bother to call Abort_Task if T is terminated, since there is no need to + -- abort a terminated task, and it could be dangerous to try if the task + -- has stopped executing. + + -- Note that an earlier version of this code had some false reasoning about + -- being able to reliably wake up a task that had suspended on a blocking + -- system call that does not atomically release the task's lock (e.g., UNIX + -- nanosleep, which we once thought could be used to implement delays). + -- That still left the possibility of missed wakeups. + + -- We cannot safely call Vulnerable_Complete_Activation here, since that + -- requires locking Self_ID.Parent. The anti-deadlock lock ordering rules + -- would then require us to release the lock on Self_ID first, which would + -- create a timing window for other tasks to lock Self_ID. This is + -- significant for tasks that may be aborted before their execution can + -- enter the task body, and so they do not get a chance to call + -- Complete_Task. The actual work for this case is done in Terminate_Task. + + procedure Locked_Abort_To_Level + (Self_ID : Task_Id; + T : Task_Id; + L : ATC_Level) + is + begin + if not T.Aborting and then T /= Self_ID then + case T.Common.State is + when Terminated + | Unactivated + => + pragma Assert (False); + null; + + when Activating + | Runnable + => + -- This is needed to cancel an asynchronous protected entry + -- call during a requeue with abort. + + T.Entry_Calls + (T.ATC_Nesting_Level).Cancellation_Attempted := True; + + when Interrupt_Server_Blocked_On_Event_Flag => + null; + + when AST_Server_Sleep + | Async_Select_Sleep + | Delay_Sleep + | Interrupt_Server_Blocked_Interrupt_Sleep + | Interrupt_Server_Idle_Sleep + | Timer_Server_Sleep + => + Wakeup (T, T.Common.State); + + when Acceptor_Delay_Sleep + | Acceptor_Sleep + => + T.Open_Accepts := null; + Wakeup (T, T.Common.State); + + when Entry_Caller_Sleep => + T.Entry_Calls + (T.ATC_Nesting_Level).Cancellation_Attempted := True; + Wakeup (T, T.Common.State); + + when Activator_Sleep + | Asynchronous_Hold + | Master_Completion_Sleep + | Master_Phase_2_Sleep + => + null; + end case; + end if; + + if T.Pending_ATC_Level > L then + T.Pending_ATC_Level := L; + T.Pending_Action := True; + + if L = 0 then + T.Callable := False; + end if; + + -- This prevents aborted task from accepting calls + + if T.Aborting then + + -- The test above is just a heuristic, to reduce wasteful + -- calls to Abort_Task. We are holding T locked, and this + -- value will not be set to False except with T also locked, + -- inside Exit_One_ATC_Level, so we should not miss wakeups. + + if T.Common.State = Acceptor_Sleep + or else + T.Common.State = Acceptor_Delay_Sleep + then + T.Open_Accepts := null; + end if; + + elsif T /= Self_ID and then + (T.Common.State = Runnable + or else T.Common.State = Interrupt_Server_Blocked_On_Event_Flag) + + -- The task is blocked on a system call waiting for the + -- completion event. In this case Abort_Task may need to take + -- special action in order to succeed. + + then + Abort_Task (T); + end if; + end if; + end Locked_Abort_To_Level; + + -------------------------------- + -- Remove_From_All_Tasks_List -- + -------------------------------- + + procedure Remove_From_All_Tasks_List (T : Task_Id) is + C : Task_Id; + Previous : Task_Id; + + begin + pragma Debug + (Debug.Trace (Self, "Remove_From_All_Tasks_List", 'C')); + + Previous := Null_Task; + C := All_Tasks_List; + while C /= Null_Task loop + if C = T then + if Previous = Null_Task then + All_Tasks_List := All_Tasks_List.Common.All_Tasks_Link; + else + Previous.Common.All_Tasks_Link := C.Common.All_Tasks_Link; + end if; + + return; + end if; + + Previous := C; + C := C.Common.All_Tasks_Link; + end loop; + + pragma Assert (False); + end Remove_From_All_Tasks_List; + + --------------- + -- Task_Lock -- + --------------- + + procedure Task_Lock (Self_ID : Task_Id) is + begin + Self_ID.Common.Global_Task_Lock_Nesting := + Self_ID.Common.Global_Task_Lock_Nesting + 1; + + if Self_ID.Common.Global_Task_Lock_Nesting = 1 then + Defer_Abort_Nestable (Self_ID); + Write_Lock (Global_Task_Lock'Access, Global_Lock => True); + end if; + end Task_Lock; + + procedure Task_Lock is + begin + Task_Lock (STPO.Self); + end Task_Lock; + + --------------- + -- Task_Name -- + --------------- + + function Task_Name return String is + Self_Id : constant Task_Id := STPO.Self; + begin + return Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len); + end Task_Name; + + ----------------- + -- Task_Unlock -- + ----------------- + + procedure Task_Unlock (Self_ID : Task_Id) is + begin + pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting > 0); + Self_ID.Common.Global_Task_Lock_Nesting := + Self_ID.Common.Global_Task_Lock_Nesting - 1; + + if Self_ID.Common.Global_Task_Lock_Nesting = 0 then + Unlock (Global_Task_Lock'Access, Global_Lock => True); + Undefer_Abort_Nestable (Self_ID); + end if; + end Task_Unlock; + + procedure Task_Unlock is + begin + Task_Unlock (STPO.Self); + end Task_Unlock; + + ------------------- + -- Undefer_Abort -- + ------------------- + + -- Precondition : Self does not hold any locks + + -- Undefer_Abort is called on any abort completion point (aka. + -- synchronization point). It performs the following actions if they + -- are pending: (1) change the base priority, (2) abort the task. + + -- The priority change has to occur before abort. Otherwise, it would + -- take effect no earlier than the next abort completion point. + + procedure Undefer_Abort (Self_ID : Task_Id) is + begin + if No_Abort then + return; + end if; + + pragma Assert (Self_ID.Deferral_Level = 1); + + Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; + + if Self_ID.Deferral_Level = 0 then + pragma Assert (Check_No_Locks (Self_ID)); + + if Self_ID.Pending_Action then + Do_Pending_Action (Self_ID); + end if; + end if; + end Undefer_Abort; + + ---------------------------- + -- Undefer_Abort_Nestable -- + ---------------------------- + + -- An earlier version would re-defer abort if an abort is in progress. + -- Then, we modified the effect of the raise statement so that it defers + -- abort until control reaches a handler. That was done to prevent + -- "skipping over" a handler if another asynchronous abort occurs during + -- the propagation of the abort to the handler. + + -- There has been talk of reversing that decision, based on a newer + -- implementation of exception propagation. Care must be taken to evaluate + -- how such a change would interact with the above code and all the places + -- where abort-deferral is used to bridge over critical transitions, such + -- as entry to the scope of a region with a finalizer and entry into the + -- body of an accept-procedure. + + procedure Undefer_Abort_Nestable (Self_ID : Task_Id) is + begin + if No_Abort then + return; + end if; + + pragma Assert (Self_ID.Deferral_Level > 0); + + Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; + + if Self_ID.Deferral_Level = 0 then + + pragma Assert (Check_No_Locks (Self_ID)); + + if Self_ID.Pending_Action then + Do_Pending_Action (Self_ID); + end if; + end if; + end Undefer_Abort_Nestable; + + ------------------- + -- Abort_Undefer -- + ------------------- + + procedure Abort_Undefer is + Self_ID : Task_Id; + begin + if No_Abort then + return; + end if; + + Self_ID := STPO.Self; + + if Self_ID.Deferral_Level = 0 then + + -- In case there are different views on whether Abort is supported + -- between the expander and the run time, we may end up with + -- Self_ID.Deferral_Level being equal to zero, when called from + -- the procedure created by the expander that corresponds to a + -- task body. In this case, there's nothing to be done. + + -- See related code in System.Tasking.Stages.Create_Task resetting + -- Deferral_Level when System.Restrictions.Abort_Allowed is False. + + return; + end if; + + pragma Assert (Self_ID.Deferral_Level > 0); + Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; + + if Self_ID.Deferral_Level = 0 then + pragma Assert (Check_No_Locks (Self_ID)); + + if Self_ID.Pending_Action then + Do_Pending_Action (Self_ID); + end if; + end if; + end Abort_Undefer; + + -------------------------- + -- Wakeup_Entry_Caller -- + -------------------------- + + -- This is called at the end of service of an entry call, to abort the + -- caller if he is in an abortable part, and to wake up the caller if it + -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue. + + -- (This enforces the rule that a task must be off-queue if its state is + -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self. + + -- Timed_Call or Simple_Call: + -- The caller is waiting on Entry_Caller_Sleep, in + -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. + + -- Conditional_Call: + -- The caller might be in Wait_For_Completion, + -- waiting for a rendezvous (possibly requeued without abort) + -- to complete. + + -- Asynchronous_Call: + -- The caller may be executing in the abortable part o + -- an async. select, or on a time delay, + -- if Entry_Call.State >= Was_Abortable. + + procedure Wakeup_Entry_Caller + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link; + New_State : Entry_Call_State) + is + Caller : constant Task_Id := Entry_Call.Self; + + begin + pragma Debug (Debug.Trace + (Self_ID, "Wakeup_Entry_Caller", 'E', Caller)); + pragma Assert (New_State = Done or else New_State = Cancelled); + + pragma Assert (Caller.Common.State /= Unactivated); + + Entry_Call.State := New_State; + + if Entry_Call.Mode = Asynchronous_Call then + + -- Abort the caller in his abortable part, but do so only if call has + -- been queued abortably. + + if Entry_Call.State >= Was_Abortable or else New_State = Done then + Locked_Abort_To_Level (Self_ID, Caller, Entry_Call.Level - 1); + end if; + + elsif Caller.Common.State = Entry_Caller_Sleep then + Wakeup (Caller, Entry_Caller_Sleep); + end if; + end Wakeup_Entry_Caller; + + ------------------------- + -- Finalize_Attributes -- + ------------------------- + + procedure Finalize_Attributes (T : Task_Id) is + Attr : Atomic_Address; + + begin + for J in T.Attributes'Range loop + Attr := T.Attributes (J); + + if Attr /= 0 and then Task_Attributes.Require_Finalization (J) then + Task_Attributes.To_Attribute (Attr).Free (Attr); + T.Attributes (J) := 0; + end if; + end loop; + end Finalize_Attributes; + +begin + Init_RTS; +end System.Tasking.Initialization; diff --git a/gcc/ada/libgnarl/s-tasini.ads b/gcc/ada/libgnarl/s-tasini.ads new file mode 100644 index 00000000000..9ee2d086aae --- /dev/null +++ b/gcc/ada/libgnarl/s-tasini.ads @@ -0,0 +1,178 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . I N I T I A L I Z A T I O N -- +-- -- +-- 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 package provides overall initialization of the tasking portion of the +-- RTS. This package must be elaborated before any tasking features are used. + +package System.Tasking.Initialization is + + procedure Remove_From_All_Tasks_List (T : Task_Id); + -- Remove T from All_Tasks_List. Call this function with RTS_Lock taken + + procedure Finalize_Attributes (T : Task_Id); + -- Finalize all attributes from T. This is to be called just before the + -- ATCB is deallocated. It relies on the caller holding T.L write-lock + -- on entry. + + --------------------------------- + -- Tasking-Specific Soft Links -- + --------------------------------- + + ------------------------- + -- Abort Defer/Undefer -- + ------------------------- + + -- Defer_Abort defers the effects of low-level abort and priority change + -- in the calling task until a matching Undefer_Abort call is executed. + + -- Undefer_Abort DOES MORE than just undo the effects of one call to + -- Defer_Abort. It is the universal "polling point" for deferred + -- processing, including the following: + + -- 1) base priority changes + + -- 2) abort/ATC + + -- Abort deferral MAY be nested (Self_ID.Deferral_Level is a count), but + -- to avoid waste and undetected errors, it generally SHOULD NOT be + -- nested. The symptom of over-deferring abort is that an exception may + -- fail to be raised, or an abort may fail to take place. + + -- Therefore, there are two sets of the inlineable defer/undefer routines, + -- which are the ones to be used inside GNARL. One set allows nesting. The + -- other does not. People who maintain the GNARL should try to avoid using + -- the nested versions, or at least look very critically at the places + -- where they are used. + + -- In general, any GNARL call that is potentially blocking, or whose + -- semantics require that it sometimes raise an exception, or that is + -- required to be an abort completion point, must be made with abort + -- Deferral_Level = 1. + + -- In general, non-blocking GNARL calls, which may be made from inside a + -- protected action, are likely to need to allow nested abort deferral. + + -- With some critical exceptions (which are supposed to be documented), + -- internal calls to the tasking runtime system assume abort is already + -- deferred, and do not modify the deferral level. + + -- There is also a set of non-inlineable defer/undefer routines, for direct + -- call from the compiler. These are not inlineable because they may need + -- to be called via pointers ("soft links"). For the sake of efficiency, + -- the version with Self_ID as parameter should used wherever possible. + -- These are all nestable. + + -- Non-nestable inline versions + + procedure Defer_Abort (Self_ID : Task_Id); + pragma Inline (Defer_Abort); + + procedure Undefer_Abort (Self_ID : Task_Id); + pragma Inline (Undefer_Abort); + + -- Nestable inline versions + + procedure Defer_Abort_Nestable (Self_ID : Task_Id); + pragma Inline (Defer_Abort_Nestable); + + procedure Undefer_Abort_Nestable (Self_ID : Task_Id); + pragma Inline (Undefer_Abort_Nestable); + + procedure Do_Pending_Action (Self_ID : Task_Id); + -- Only call with no locks, and when Self_ID.Pending_Action = True Perform + -- necessary pending actions (e.g. abort, priority change). This procedure + -- is usually called when needed as a result of calling Undefer_Abort, + -- although in the case of e.g. No_Abort restriction, it can be necessary + -- to force execution of pending actions. + + function Check_Abort_Status return Integer; + -- Returns Boolean'Pos (True) iff abort signal should raise + -- Standard'Abort_Signal. Only used by IRIX currently. + + -------------------------- + -- Change Base Priority -- + -------------------------- + + procedure Change_Base_Priority (T : Task_Id); + -- Change the base priority of T. Has to be called with the affected + -- task's ATCB write-locked. May temporarily release the lock. + + ---------------------- + -- Task Lock/Unlock -- + ---------------------- + + procedure Task_Lock (Self_ID : Task_Id); + pragma Inline (Task_Lock); + + procedure Task_Unlock (Self_ID : Task_Id); + pragma Inline (Task_Unlock); + -- These are versions of Lock_Task and Unlock_Task created for use + -- within the GNARL. + + procedure Final_Task_Unlock (Self_ID : Task_Id); + -- This version is only for use in Terminate_Task, when the task is + -- relinquishing further rights to its own ATCB. There is a very + -- interesting potential race condition there, where the old task may run + -- concurrently with a new task that is allocated the old tasks (now + -- reused) ATCB. The critical thing here is to not make any reference to + -- the ATCB after the lock is released. See also comments on + -- Terminate_Task and Unlock. + + procedure Wakeup_Entry_Caller + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link; + New_State : Entry_Call_State); + pragma Inline (Wakeup_Entry_Caller); + -- This is called at the end of service of an entry call, to abort the + -- caller if he is in an abortable part, and to wake up the caller if he + -- is on Entry_Caller_Sleep. Call it holding the lock of Entry_Call.Self. + -- + -- Timed_Call or Simple_Call: + -- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion, + -- or Wait_For_Completion_With_Timeout. + -- + -- Conditional_Call: + -- The caller might be in Wait_For_Completion, + -- waiting for a rendezvous (possibly requeued without abort) to + -- complete. + -- + -- Asynchronous_Call: + -- The caller may be executing in the abortable part an async. select, + -- or on a time delay, if Entry_Call.State >= Was_Abortable. + + procedure Locked_Abort_To_Level + (Self_ID : Task_Id; + T : Task_Id; + L : ATC_Level); + pragma Inline (Locked_Abort_To_Level); + -- Abort a task to a specified ATC level. Call this only with T locked + +end System.Tasking.Initialization; diff --git a/gcc/ada/libgnarl/s-taskin.adb b/gcc/ada/libgnarl/s-taskin.adb new file mode 100644 index 00000000000..462e229645c --- /dev/null +++ b/gcc/ada/libgnarl/s-taskin.adb @@ -0,0 +1,278 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +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.Task_Primitives.Operations; +with System.Storage_Elements; + +package body System.Tasking is + + package STPO renames System.Task_Primitives.Operations; + + --------------------- + -- Detect_Blocking -- + --------------------- + + function Detect_Blocking return Boolean is + GL_Detect_Blocking : Integer; + pragma Import (C, GL_Detect_Blocking, "__gl_detect_blocking"); + -- Global variable exported by the binder generated file. A value equal + -- to 1 indicates that pragma Detect_Blocking is active, while 0 is used + -- for the pragma not being present. + + begin + return GL_Detect_Blocking = 1; + end Detect_Blocking; + + ----------------------- + -- Number_Of_Entries -- + ----------------------- + + function Number_Of_Entries (Self_Id : Task_Id) return Entry_Index is + begin + return Entry_Index (Self_Id.Entry_Num); + end Number_Of_Entries; + + ---------- + -- Self -- + ---------- + + function Self return Task_Id renames STPO.Self; + + ------------------ + -- Storage_Size -- + ------------------ + + function Storage_Size (T : Task_Id) return System.Parameters.Size_Type is + begin + return + System.Parameters.Size_Type + (T.Common.Compiler_Data.Pri_Stack_Info.Size); + end Storage_Size; + + --------------------- + -- Initialize_ATCB -- + --------------------- + + procedure Initialize_ATCB + (Self_ID : Task_Id; + Task_Entry_Point : Task_Procedure_Access; + Task_Arg : System.Address; + Parent : Task_Id; + Elaborated : Access_Boolean; + Base_Priority : System.Any_Priority; + Base_CPU : System.Multiprocessors.CPU_Range; + Domain : Dispatching_Domain_Access; + Task_Info : System.Task_Info.Task_Info_Type; + Stack_Size : System.Parameters.Size_Type; + Secondary_Stack_Size : System.Parameters.Size_Type; + T : Task_Id; + Success : out Boolean) + is + begin + T.Common.State := Unactivated; + + -- Initialize T.Common.LL + + STPO.Initialize_TCB (T, Success); + + if not Success then + return; + end if; + + -- Note that use of an aggregate here for this assignment + -- would be illegal, because Common_ATCB is limited because + -- Task_Primitives.Private_Data is limited. + + T.Common.Parent := Parent; + T.Common.Base_Priority := Base_Priority; + T.Common.Base_CPU := Base_CPU; + + -- The Domain defaults to that of the activator. But that can be null in + -- the case of foreign threads (see Register_Foreign_Thread), in which + -- case we default to the System_Domain. + + if Domain /= null then + T.Common.Domain := Domain; + elsif Self_ID.Common.Domain /= null then + T.Common.Domain := Self_ID.Common.Domain; + else + T.Common.Domain := System_Domain; + end if; + pragma Assert (T.Common.Domain /= null); + + T.Common.Current_Priority := 0; + T.Common.Protected_Action_Nesting := 0; + T.Common.Call := null; + T.Common.Task_Arg := Task_Arg; + T.Common.Task_Entry_Point := Task_Entry_Point; + T.Common.Activator := Self_ID; + T.Common.Wait_Count := 0; + T.Common.Elaborated := Elaborated; + T.Common.Activation_Failed := False; + T.Common.Task_Info := Task_Info; + T.Common.Global_Task_Lock_Nesting := 0; + T.Common.Fall_Back_Handler := null; + T.Common.Specific_Handler := null; + T.Common.Debug_Events := (others => False); + T.Common.Task_Image_Len := 0; + T.Common.Secondary_Stack_Size := Secondary_Stack_Size; + + if T.Common.Parent = null then + + -- For the environment task, the adjusted stack size is meaningless. + -- For example, an unspecified Stack_Size means that the stack size + -- is determined by the environment, or can grow dynamically. The + -- Stack_Checking algorithm therefore needs to use the requested + -- size, or 0 in case of an unknown size. + + T.Common.Compiler_Data.Pri_Stack_Info.Size := + Storage_Elements.Storage_Offset (Stack_Size); + + else + T.Common.Compiler_Data.Pri_Stack_Info.Size := + Storage_Elements.Storage_Offset + (Parameters.Adjust_Storage_Size (Stack_Size)); + end if; + + -- Link the task into the list of all tasks + + T.Common.All_Tasks_Link := All_Tasks_List; + All_Tasks_List := T; + end Initialize_ATCB; + + ---------------- + -- Initialize -- + ---------------- + + Main_Task_Image : constant String := "main_task"; + -- Image of environment task + + Main_Priority : Integer; + pragma Import (C, Main_Priority, "__gl_main_priority"); + -- Priority for main task. Note that this is of type Integer, not Priority, + -- because we use the value -1 to indicate the default main priority, and + -- that is of course not in Priority'range. + + Main_CPU : Integer; + pragma Import (C, Main_CPU, "__gl_main_cpu"); + -- Affinity for main task. Note that this is of type Integer, not + -- CPU_Range, because we use the value -1 to indicate the unassigned + -- affinity, and that is of course not in CPU_Range'Range. + + Initialized : Boolean := False; + -- Used to prevent multiple calls to Initialize + + procedure Initialize is + T : Task_Id; + Base_Priority : Any_Priority; + Base_CPU : System.Multiprocessors.CPU_Range; + Success : Boolean; + + use type System.Multiprocessors.CPU_Range; + + begin + if Initialized then + return; + end if; + + Initialized := True; + + -- Initialize Environment Task + + Base_Priority := + (if Main_Priority = Unspecified_Priority + then Default_Priority + else Priority (Main_Priority)); + + Base_CPU := + (if Main_CPU = Unspecified_CPU + then System.Multiprocessors.Not_A_Specific_CPU + else System.Multiprocessors.CPU_Range (Main_CPU)); + + -- At program start-up the environment task is allocated to the default + -- system dispatching domain. + -- Make sure that the processors which are not available are not taken + -- into account. Use Number_Of_CPUs to know the exact number of + -- processors in the system at execution time. + + System_Domain := + new Dispatching_Domain' + (Multiprocessors.CPU'First .. Multiprocessors.Number_Of_CPUs => + True); + + T := STPO.New_ATCB (0); + Initialize_ATCB + (Self_ID => null, + Task_Entry_Point => null, + Task_Arg => Null_Address, + Parent => Null_Task, + Elaborated => null, + Base_Priority => Base_Priority, + Base_CPU => Base_CPU, + Domain => System_Domain, + Task_Info => Task_Info.Unspecified_Task_Info, + Stack_Size => 0, + Secondary_Stack_Size => Parameters.Unspecified_Size, + T => T, + Success => Success); + pragma Assert (Success); + + STPO.Initialize (T); + STPO.Set_Priority (T, T.Common.Base_Priority); + T.Common.State := Runnable; + T.Common.Task_Image_Len := Main_Task_Image'Length; + T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image; + + Dispatching_Domain_Tasks := + new Array_Allocated_Tasks' + (Multiprocessors.CPU'First .. Multiprocessors.Number_Of_CPUs => 0); + + -- Signal that this task is being allocated to a processor + + if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then + + -- Increase the number of tasks attached to the CPU to which this + -- task is allocated. + + Dispatching_Domain_Tasks (Base_CPU) := + Dispatching_Domain_Tasks (Base_CPU) + 1; + end if; + + -- Only initialize the first element since others are not relevant + -- in ravenscar mode. Rest of the initialization is done in Init_RTS. + + T.Entry_Calls (1).Self := T; + end Initialize; +end System.Tasking; diff --git a/gcc/ada/libgnarl/s-taskin.ads b/gcc/ada/libgnarl/s-taskin.ads new file mode 100644 index 00000000000..cd53cf93471 --- /dev/null +++ b/gcc/ada/libgnarl/s-taskin.ads @@ -0,0 +1,1200 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G -- +-- -- +-- 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 package provides necessary type definitions for compiler interface + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +with Ada.Exceptions; +with Ada.Unchecked_Conversion; + +with System.Parameters; +with System.Task_Info; +with System.Soft_Links; +with System.Task_Primitives; +with System.Stack_Usage; +with System.Multiprocessors; + +package System.Tasking is + pragma Preelaborate; + + ------------------- + -- Locking Rules -- + ------------------- + + -- The following rules must be followed at all times, to prevent + -- deadlock and generally ensure correct operation of locking. + + -- Never lock a lock unless abort is deferred + + -- Never undefer abort while holding a lock + + -- Overlapping critical sections must be properly nested, and locks must + -- be released in LIFO order. E.g., the following is not allowed: + + -- Lock (X); + -- ... + -- Lock (Y); + -- ... + -- Unlock (X); + -- ... + -- Unlock (Y); + + -- Locks with lower (smaller) level number cannot be locked + -- while holding a lock with a higher level number. (The level + + -- 1. System.Tasking.PO_Simple.Protection.L (any PO lock) + -- 2. System.Tasking.Initialization.Global_Task_Lock (in body) + -- 3. System.Task_Primitives.Operations.Single_RTS_Lock + -- 4. System.Tasking.Ada_Task_Control_Block.LL.L (any TCB lock) + + -- Clearly, there can be no circular chain of hold-and-wait + -- relationships involving locks in different ordering levels. + + -- We used to have Global_Task_Lock before Protection.L but this was + -- clearly wrong since there can be calls to "new" inside protected + -- operations. The new ordering prevents these failures. + + -- Sometimes we need to hold two ATCB locks at the same time. To allow us + -- to order the locking, each ATCB is given a unique serial number. If one + -- needs to hold locks on two ATCBs at once, the lock with lower serial + -- number must be locked first. We avoid holding three or more ATCB locks, + -- because that can easily lead to complications that cause race conditions + -- and deadlocks. + + -- We don't always need to check the serial numbers, since the serial + -- numbers are assigned sequentially, and so: + + -- . The parent of a task always has a lower serial number. + -- . The activator of a task always has a lower serial number. + -- . The environment task has a lower serial number than any other task. + -- . If the activator of a task is different from the task's parent, + -- the parent always has a lower serial number than the activator. + + --------------------------------- + -- Task_Id related definitions -- + --------------------------------- + + type Ada_Task_Control_Block; + + type Task_Id is access all Ada_Task_Control_Block; + for Task_Id'Size use System.Task_Primitives.Task_Address_Size; + + Null_Task : constant Task_Id; + + type Task_List is array (Positive range <>) of Task_Id; + + function Self return Task_Id; + pragma Inline (Self); + -- This is the compiler interface version of this function. Do not call + -- from the run-time system. + + function To_Task_Id is + new Ada.Unchecked_Conversion + (System.Task_Primitives.Task_Address, Task_Id); + function To_Address is + new Ada.Unchecked_Conversion + (Task_Id, System.Task_Primitives.Task_Address); + + ----------------------- + -- Enumeration types -- + ----------------------- + + type Task_States is + (Unactivated, + -- TCB initialized but not task has not been created. + -- It cannot be executing. + +-- Activating, +-- -- ??? Temporarily at end of list for GDB compatibility +-- -- Task has been created and is being made Runnable. + + -- Active states + -- For all states from here down, the task has been activated. + -- For all states from here down, except for Terminated, the task + -- may be executing. + -- Activator = null iff it has not yet completed activating. + + Runnable, + -- Task is not blocked for any reason known to Ada. + -- (It may be waiting for a mutex, though.) + -- It is conceptually "executing" in normal mode. + + Terminated, + -- The task is terminated, in the sense of ARM 9.3 (5). + -- Any dependents that were waiting on terminate + -- alternatives have been awakened and have terminated themselves. + + Activator_Sleep, + -- Task is waiting for created tasks to complete activation + + Acceptor_Sleep, + -- Task is waiting on an accept or select with terminate + +-- Acceptor_Delay_Sleep, +-- -- ??? Temporarily at end of list for GDB compatibility +-- -- Task is waiting on an selective wait statement + + Entry_Caller_Sleep, + -- Task is waiting on an entry call + + Async_Select_Sleep, + -- Task is waiting to start the abortable part of an + -- asynchronous select statement. + + Delay_Sleep, + -- Task is waiting on a select statement with only a delay + -- alternative open. + + Master_Completion_Sleep, + -- Master completion has two phases. + -- In Phase 1 the task is sleeping in Complete_Master + -- having completed a master within itself, + -- and is waiting for the tasks dependent on that master to become + -- terminated or waiting on a terminate Phase. + + Master_Phase_2_Sleep, + -- In Phase 2 the task is sleeping in Complete_Master + -- waiting for tasks on terminate alternatives to finish + -- terminating. + + -- The following are special uses of sleep, for server tasks + -- within the run-time system. + + Interrupt_Server_Idle_Sleep, + Interrupt_Server_Blocked_Interrupt_Sleep, + Timer_Server_Sleep, + AST_Server_Sleep, + + Asynchronous_Hold, + -- The task has been held by Asynchronous_Task_Control.Hold_Task + + Interrupt_Server_Blocked_On_Event_Flag, + -- The task has been blocked on a system call waiting for a + -- completion event/signal to occur. + + Activating, + -- Task has been created and is being made Runnable + + Acceptor_Delay_Sleep + -- Task is waiting on an selective wait statement + ); + + type Call_Modes is + (Simple_Call, Conditional_Call, Asynchronous_Call, Timed_Call); + + type Select_Modes is (Simple_Mode, Else_Mode, Terminate_Mode, Delay_Mode); + + subtype Delay_Modes is Integer; + + ------------------------------- + -- Entry related definitions -- + ------------------------------- + + Null_Entry : constant := 0; + + Max_Entry : constant := Integer'Last; + + Interrupt_Entry : constant := -2; + + Cancelled_Entry : constant := -1; + + type Entry_Index is range Interrupt_Entry .. Max_Entry; + + Null_Task_Entry : constant := Null_Entry; + + Max_Task_Entry : constant := Max_Entry; + + type Task_Entry_Index is new Entry_Index + range Null_Task_Entry .. Max_Task_Entry; + + type Entry_Call_Record; + + type Entry_Call_Link is access all Entry_Call_Record; + + type Entry_Queue is record + Head : Entry_Call_Link; + Tail : Entry_Call_Link; + end record; + + type Task_Entry_Queue_Array is + array (Task_Entry_Index range <>) of Entry_Queue; + + -- A data structure which contains the string names of entries and entry + -- family members. + + type String_Access is access all String; + + ---------------------------------- + -- Entry_Call_Record definition -- + ---------------------------------- + + type Entry_Call_State is + (Never_Abortable, + -- the call is not abortable, and never can be + + Not_Yet_Abortable, + -- the call is not abortable, but may become so + + Was_Abortable, + -- the call is not abortable, but once was + + Now_Abortable, + -- the call is abortable + + Done, + -- the call has been completed + + Cancelled + -- the call was asynchronous, and was cancelled + ); + pragma Ordered (Entry_Call_State); + + -- Never_Abortable is used for calls that are made in a abort deferred + -- region (see ARM 9.8(5-11), 9.8 (20)). Such a call is never abortable. + + -- The Was_ vs. Not_Yet_ distinction is needed to decide whether it is OK + -- to advance into the abortable part of an async. select stmt. That is + -- allowed iff the mode is Now_ or Was_. + + -- Done indicates the call has been completed, without cancellation, or no + -- call has been made yet at this ATC nesting level, and so aborting the + -- call is no longer an issue. Completion of the call does not necessarily + -- indicate "success"; the call may be returning an exception if + -- Exception_To_Raise is non-null. + + -- Cancelled indicates the call was cancelled, and so aborting the call is + -- no longer an issue. + + -- The call is on an entry queue unless State >= Done, in which case it may + -- or may not be still Onqueue. + + -- Please do not modify the order of the values, without checking all uses + -- of this type. We rely on partial "monotonicity" of + -- Entry_Call_Record.State to avoid locking when we access this value for + -- certain tests. In particular: + + -- 1) Once State >= Done, we can rely that the call has been + -- completed. If State >= Done, it will not + -- change until the task does another entry call at this level. + + -- 2) Once State >= Was_Abortable, we can rely that the call has + -- been queued abortably at least once, and so the check for + -- whether it is OK to advance to the abortable part of an + -- async. select statement does not need to lock anything. + + type Restricted_Entry_Call_Record is record + Self : Task_Id; + -- ID of the caller + + Mode : Call_Modes; + + State : Entry_Call_State; + pragma Atomic (State); + -- Indicates part of the state of the call. + -- + -- Protection: If the call is not on a queue, it should only be + -- accessed by Self, and Self does not need any lock to modify this + -- field. + -- + -- Once the call is on a queue, the value should be something other + -- than Done unless it is cancelled, and access is controller by the + -- "server" of the queue -- i.e., the lock of Checked_To_Protection + -- (Call_Target) if the call record is on the queue of a PO, or the + -- lock of Called_Target if the call is on the queue of a task. See + -- comments on type declaration for more details. + + Uninterpreted_Data : System.Address; + -- Data passed by the compiler + + Exception_To_Raise : Ada.Exceptions.Exception_Id; + -- The exception to raise once this call has been completed without + -- being aborted. + end record; + pragma Suppress_Initialization (Restricted_Entry_Call_Record); + + ------------------------------------------- + -- Task termination procedure definition -- + ------------------------------------------- + + -- We need to redefine here these types (already defined in + -- Ada.Task_Termination) for avoiding circular dependencies. + + type Cause_Of_Termination is (Normal, Abnormal, Unhandled_Exception); + -- Possible causes for task termination: + -- + -- Normal means that the task terminates due to completing the + -- last sentence of its body, or as a result of waiting on a + -- terminate alternative. + + -- Abnormal means that the task terminates because it is being aborted + + -- handled_Exception means that the task terminates because of exception + -- raised by the execution of its task_body. + + type Termination_Handler is access protected procedure + (Cause : Cause_Of_Termination; + T : Task_Id; + X : Ada.Exceptions.Exception_Occurrence); + -- Used to represent protected procedures to be executed when task + -- terminates. + + ------------------------------------ + -- Dispatching domain definitions -- + ------------------------------------ + + -- We need to redefine here these types (already defined in + -- System.Multiprocessor.Dispatching_Domains) for avoiding circular + -- dependencies. + + type Dispatching_Domain is + array (System.Multiprocessors.CPU range <>) of Boolean; + -- A dispatching domain needs to contain the set of processors belonging + -- to it. This is a processor mask where a True indicates that the + -- processor belongs to the dispatching domain. + -- Do not use the full range of CPU_Range because it would create a very + -- long array. This way we can use the exact range of processors available + -- in the system. + + type Dispatching_Domain_Access is access Dispatching_Domain; + + System_Domain : Dispatching_Domain_Access; + -- All processors belong to default system dispatching domain at start up. + -- We use a pointer which creates the actual variable for the reasons + -- explained bellow in Dispatching_Domain_Tasks. + + Dispatching_Domains_Frozen : Boolean := False; + -- True when the main procedure has been called. Hence, no new dispatching + -- domains can be created when this flag is True. + + type Array_Allocated_Tasks is + array (System.Multiprocessors.CPU range <>) of Natural; + -- At start-up time, we need to store the number of tasks attached to + -- concrete processors within the system domain (we can only create + -- dispatching domains with processors belonging to the system domain and + -- without tasks allocated). + + type Array_Allocated_Tasks_Access is access Array_Allocated_Tasks; + + Dispatching_Domain_Tasks : Array_Allocated_Tasks_Access; + -- We need to store whether there are tasks allocated to concrete + -- processors in the default system dispatching domain because we need to + -- check it before creating a new dispatching domain. Two comments about + -- why we use a pointer here and not in package Dispatching_Domains: + -- + -- 1) We use an array created dynamically in procedure Initialize which + -- is called at the beginning of the initialization of the run-time + -- library. Declaring a static array here in the spec would not work + -- across different installations because it would get the value of + -- Number_Of_CPUs from the machine where the run-time library is built, + -- and not from the machine where the application is executed. That is + -- the reason why we create the array (CPU'First .. Number_Of_CPUs) at + -- execution time in the procedure body, ensuring that the function + -- Number_Of_CPUs is executed at execution time (the same trick as we + -- use for System_Domain). + -- + -- 2) We have moved this declaration from package Dispatching_Domains + -- because when we use a pragma CPU, the affinity is passed through the + -- call to Create_Task. Hence, at this point, we may need to update the + -- number of tasks associated to the processor, but we do not want to + -- force a dependency from this package on Dispatching_Domains. + + ------------------------------------ + -- Task related other definitions -- + ------------------------------------ + + type Activation_Chain is limited private; + -- Linked list of to-be-activated tasks, linked through + -- Activation_Link. The order of tasks on the list is irrelevant, because + -- the priority rules will ensure that they actually start activating in + -- priority order. + + type Activation_Chain_Access is access all Activation_Chain; + + type Task_Procedure_Access is access procedure (Arg : System.Address); + + type Access_Boolean is access all Boolean; + + function Detect_Blocking return Boolean; + pragma Inline (Detect_Blocking); + -- Return whether the Detect_Blocking pragma is enabled + + function Storage_Size (T : Task_Id) return System.Parameters.Size_Type; + -- Retrieve from the TCB of the task the allocated size of its stack, + -- either the system default or the size specified by a pragma. This is in + -- general a non-static value that can depend on discriminants of the task. + + type Bit_Array is array (Integer range <>) of Boolean; + pragma Pack (Bit_Array); + + subtype Debug_Event_Array is Bit_Array (1 .. 16); + + Global_Task_Debug_Event_Set : Boolean := False; + -- Set True when running under debugger control and a task debug event + -- signal has been requested. + + ---------------------------------------------- + -- Ada_Task_Control_Block (ATCB) definition -- + ---------------------------------------------- + + -- Notes on protection (synchronization) of TRTS data structures + + -- Any field of the TCB can be written by the activator of a task when the + -- task is created, since no other task can access the new task's + -- state until creation is complete. + + -- The protection for each field is described in a comment starting with + -- "Protection:". + + -- When a lock is used to protect an ATCB field, this lock is simply named + + -- Some protection is described in terms of tasks related to the + -- ATCB being protected. These are: + + -- Self: The task which is controlled by this ATCB + -- Acceptor: A task accepting a call from Self + -- Caller: A task calling an entry of Self + -- Parent: The task executing the master on which Self depends + -- Dependent: A task dependent on Self + -- Activator: The task that created Self and initiated its activation + -- Created: A task created and activated by Self + + -- Note: The order of the fields is important to implement efficiently + -- tasking support under gdb. + -- Currently gdb relies on the order of the State, Parent, Base_Priority, + -- Task_Image, Task_Image_Len, Call and LL fields. + + ------------------------- + -- Common ATCB section -- + ------------------------- + + -- Section used by all GNARL implementations (regular and restricted) + + type Common_ATCB is limited record + State : Task_States; + pragma Atomic (State); + -- Encodes some basic information about the state of a task, + -- including whether it has been activated, whether it is sleeping, + -- and whether it is terminated. + -- + -- Protection: Self.L + + Parent : Task_Id; + -- The task on which this task depends. + -- See also Master_Level and Master_Within. + + Base_Priority : System.Any_Priority; + -- Base priority, not changed during entry calls, only changed + -- via dynamic priorities package. + -- + -- Protection: Only written by Self, accessed by anyone + + Base_CPU : System.Multiprocessors.CPU_Range; + -- Base CPU, only changed via dispatching domains package. + -- + -- Protection: Self.L + + Current_Priority : System.Any_Priority; + -- Active priority, except that the effects of protected object + -- priority ceilings are not reflected. This only reflects explicit + -- priority changes and priority inherited through task activation + -- and rendezvous. + -- + -- Ada 95 notes: In Ada 95, this field will be transferred to the + -- Priority field of an Entry_Calls component when an entry call is + -- initiated. The Priority of the Entry_Calls component will not change + -- for the duration of the call. The accepting task can use it to boost + -- its own priority without fear of its changing in the meantime. + -- + -- This can safely be used in the priority ordering of entry queues. + -- Once a call is queued, its priority does not change. + -- + -- Since an entry call cannot be made while executing a protected + -- action, the priority of a task will never reflect a priority ceiling + -- change at the point of an entry call. + -- + -- Protection: Only written by Self, and only accessed when Acceptor + -- accepts an entry or when Created activates, at which points Self is + -- suspended. + + Protected_Action_Nesting : Natural; + pragma Atomic (Protected_Action_Nesting); + -- The dynamic level of protected action nesting for this task. This + -- field is needed for checking whether potentially blocking operations + -- are invoked from protected actions. pragma Atomic is used because it + -- can be read/written from protected interrupt handlers. + + Task_Image : String (1 .. System.Parameters.Max_Task_Image_Length); + -- Hold a string that provides a readable id for task, built from the + -- variable of which it is a value or component. + + Task_Image_Len : Natural; + -- Actual length of Task_Image + + Call : Entry_Call_Link; + -- The entry call that has been accepted by this task. + -- + -- Protection: Self.L. Self will modify this field when Self.Accepting + -- is False, and will not need the mutex to do so. Once a task sets + -- Pending_ATC_Level = 0, no other task can access this field. + + LL : aliased Task_Primitives.Private_Data; + -- Control block used by the underlying low-level tasking service + -- (GNULLI). + -- + -- Protection: This is used only by the GNULLI implementation, which + -- takes care of all of its synchronization. + + Task_Arg : System.Address; + -- The argument to task procedure. Provide a handle for discriminant + -- information. + -- + -- Protection: Part of the synchronization between Self and Activator. + -- Activator writes it, once, before Self starts executing. Thereafter, + -- Self only reads it. + + Task_Alternate_Stack : System.Address; + -- The address of the alternate signal stack for this task, if any + -- + -- Protection: Only accessed by Self + + Task_Entry_Point : Task_Procedure_Access; + -- Information needed to call the procedure containing the code for + -- the body of this task. + -- + -- Protection: Part of the synchronization between Self and Activator. + -- Activator writes it, once, before Self starts executing. Self reads + -- it, once, as part of its execution. + + Compiler_Data : System.Soft_Links.TSD; + -- Task-specific data needed by the compiler to store per-task + -- structures. + -- + -- Protection: Only accessed by Self + + All_Tasks_Link : Task_Id; + -- Used to link this task to the list of all tasks in the system + -- + -- Protection: RTS_Lock + + Activation_Link : Task_Id; + -- Used to link this task to a list of tasks to be activated + -- + -- Protection: Only used by Activator + + Activator : Task_Id; + pragma Atomic (Activator); + -- The task that created this task, either by declaring it as a task + -- object or by executing a task allocator. The value is null iff Self + -- has completed activation. + -- + -- Protection: Set by Activator before Self is activated, and + -- only modified by Self after that. Can be read by any task via + -- Ada.Task_Identification.Activation_Is_Complete; hence Atomic. + + Wait_Count : Natural; + -- This count is used by a task that is waiting for other tasks. At all + -- other times, the value should be zero. It is used differently in + -- several different states. Since a task cannot be in more than one of + -- these states at the same time, a single counter suffices. + -- + -- Protection: Self.L + + -- Activator_Sleep + + -- This is the number of tasks that this task is activating, i.e. the + -- children that have started activation but have not completed it. + -- + -- Protection: Self.L and Created.L. Both mutexes must be locked, since + -- Self.Activation_Count and Created.State must be synchronized. + + -- Master_Completion_Sleep (phase 1) + + -- This is the number dependent tasks of a master being completed by + -- Self that are activated, but have not yet terminated, and are not + -- waiting on a terminate alternative. + + -- Master_Completion_2_Sleep (phase 2) + + -- This is the count of tasks dependent on a master being completed by + -- Self which are waiting on a terminate alternative. + + Elaborated : Access_Boolean; + -- Pointer to a flag indicating that this task's body has been + -- elaborated. The flag is created and managed by the + -- compiler-generated code. + -- + -- Protection: The field itself is only accessed by Activator. The flag + -- that it points to is updated by Master and read by Activator; access + -- is assumed to be atomic. + + Activation_Failed : Boolean; + -- Set to True if activation of a chain of tasks fails, + -- so that the activator should raise Tasking_Error. + + Task_Info : System.Task_Info.Task_Info_Type; + -- System-specific attributes of the task as specified by the + -- Task_Info pragma. + + Analyzer : System.Stack_Usage.Stack_Analyzer; + -- For storing information used to measure the stack usage + + Global_Task_Lock_Nesting : Natural; + -- This is the current nesting level of calls to + -- System.Tasking.Initialization.Lock_Task. This allows a task to call + -- Lock_Task multiple times without deadlocking. A task only locks + -- Global_Task_Lock when its Global_Task_Lock_Nesting goes from 0 to 1, + -- and only unlocked when it goes from 1 to 0. + -- + -- Protection: Only accessed by Self + + Fall_Back_Handler : Termination_Handler; + -- This is the fall-back handler that applies to the dependent tasks of + -- the task. + -- + -- Protection: Self.L + + Specific_Handler : Termination_Handler; + -- This is the specific handler that applies only to this task, and not + -- any of its dependent tasks. + -- + -- Protection: Self.L + + Debug_Events : Debug_Event_Array; + -- Word length array of per task debug events, of which 11 kinds are + -- currently defined in System.Tasking.Debugging package. + + Domain : Dispatching_Domain_Access; + -- Domain is the dispatching domain to which the task belongs. It is + -- only changed via dispatching domains package. This field is made + -- part of the Common_ATCB, even when restricted run-times (namely + -- Ravenscar) do not use it, because this way the field is always + -- available to the underlying layers to set the affinity and we do not + -- need to do different things depending on the situation. + -- + -- Protection: Self.L + + Secondary_Stack_Size : System.Parameters.Size_Type; + -- Secondary_Stack_Size is the size of the secondary stack for the + -- task. Defined here since it is the responsibility of the task to + -- creates its own secondary stack. + -- + -- Protected: Only accessed by Self + end record; + + --------------------------------------- + -- Restricted_Ada_Task_Control_Block -- + --------------------------------------- + + -- This type should only be used by the restricted GNARLI and by restricted + -- GNULL implementations to allocate an ATCB (see System.Task_Primitives. + -- Operations.New_ATCB) that will take significantly less memory. + + -- Note that the restricted GNARLI should only access fields that are + -- present in the Restricted_Ada_Task_Control_Block structure. + + type Restricted_Ada_Task_Control_Block (Entry_Num : Task_Entry_Index) is + limited record + Common : Common_ATCB; + -- The common part between various tasking implementations + + Entry_Call : aliased Restricted_Entry_Call_Record; + -- Protection: This field is used on entry call "queues" associated + -- with protected objects, and is protected by the protected object + -- lock. + end record; + pragma Suppress_Initialization (Restricted_Ada_Task_Control_Block); + + Interrupt_Manager_ID : Task_Id; + -- This task ID is declared here to break circular dependencies. + -- Also declare Interrupt_Manager_ID after Task_Id is known, to avoid + -- generating unneeded finalization code. + + ----------------------- + -- List of all Tasks -- + ----------------------- + + All_Tasks_List : Task_Id; + -- Global linked list of all tasks + + ------------------------------------------ + -- Regular (non restricted) definitions -- + ------------------------------------------ + + -------------------------------- + -- Master Related Definitions -- + -------------------------------- + + subtype Master_Level is Integer; + subtype Master_ID is Master_Level; + + -- Normally, a task starts out with internal master nesting level one + -- larger than external master nesting level. It is incremented by one by + -- Enter_Master, which is called in the task body only if the compiler + -- thinks the task may have dependent tasks. It is set to 1 for the + -- environment task, the level 2 is reserved for server tasks of the + -- run-time system (the so called "independent tasks"), and the level 3 is + -- for the library level tasks. Foreign threads which are detected by + -- the run-time have a level of 0, allowing these tasks to be easily + -- distinguished if needed. + + Foreign_Task_Level : constant Master_Level := 0; + Environment_Task_Level : constant Master_Level := 1; + Independent_Task_Level : constant Master_Level := 2; + Library_Task_Level : constant Master_Level := 3; + + ------------------- + -- Priority info -- + ------------------- + + Unspecified_Priority : constant Integer := System.Priority'First - 1; + + Priority_Not_Boosted : constant Integer := System.Priority'First - 1; + -- Definition of Priority actually has to come from the RTS configuration + + subtype Rendezvous_Priority is Integer + range Priority_Not_Boosted .. System.Any_Priority'Last; + + ------------------- + -- Affinity info -- + ------------------- + + Unspecified_CPU : constant := -1; + -- No affinity specified + + ------------------------------------ + -- Rendezvous related definitions -- + ------------------------------------ + + No_Rendezvous : constant := 0; + + Max_Select : constant Integer := Integer'Last; + -- RTS-defined + + subtype Select_Index is Integer range No_Rendezvous .. Max_Select; + -- type Select_Index is range No_Rendezvous .. Max_Select; + + subtype Positive_Select_Index is + Select_Index range 1 .. Select_Index'Last; + + type Accept_Alternative is record + Null_Body : Boolean; + S : Task_Entry_Index; + end record; + + type Accept_List is + array (Positive_Select_Index range <>) of Accept_Alternative; + + type Accept_List_Access is access constant Accept_List; + + ----------------------------------- + -- ATC_Level related definitions -- + ----------------------------------- + + Max_ATC_Nesting : constant Natural := 20; + + subtype ATC_Level_Base is Integer range 0 .. Max_ATC_Nesting; + + ATC_Level_Infinity : constant ATC_Level_Base := ATC_Level_Base'Last; + + subtype ATC_Level is ATC_Level_Base range 0 .. ATC_Level_Base'Last - 1; + + subtype ATC_Level_Index is ATC_Level range 1 .. ATC_Level'Last; + + ---------------------------------- + -- Entry_Call_Record definition -- + ---------------------------------- + + type Entry_Call_Record is record + Self : Task_Id; + -- ID of the caller + + Mode : Call_Modes; + + State : Entry_Call_State; + pragma Atomic (State); + -- Indicates part of the state of the call + -- + -- Protection: If the call is not on a queue, it should only be + -- accessed by Self, and Self does not need any lock to modify this + -- field. Once the call is on a queue, the value should be something + -- other than Done unless it is cancelled, and access is controller by + -- the "server" of the queue -- i.e., the lock of Checked_To_Protection + -- (Call_Target) if the call record is on the queue of a PO, or the + -- lock of Called_Target if the call is on the queue of a task. See + -- comments on type declaration for more details. + + Uninterpreted_Data : System.Address; + -- Data passed by the compiler + + Exception_To_Raise : Ada.Exceptions.Exception_Id; + -- The exception to raise once this call has been completed without + -- being aborted. + + Prev : Entry_Call_Link; + + Next : Entry_Call_Link; + + Level : ATC_Level; + -- One of Self and Level are redundant in this implementation, since + -- each Entry_Call_Record is at Self.Entry_Calls (Level). Since we must + -- have access to the entry call record to be reading this, we could + -- get Self from Level, or Level from Self. However, this requires + -- non-portable address arithmetic. + + E : Entry_Index; + + Prio : System.Any_Priority; + + -- The above fields are those that there may be some hope of packing. + -- They are gathered together to allow for compilers that lay records + -- out contiguously, to allow for such packing. + + Called_Task : Task_Id; + pragma Atomic (Called_Task); + -- Use for task entry calls. The value is null if the call record is + -- not in use. Conversely, unless State is Done and Onqueue is false, + -- Called_Task points to an ATCB. + -- + -- Protection: Called_Task.L + + Called_PO : System.Address; + pragma Atomic (Called_PO); + -- Similar to Called_Task but for protected objects + -- + -- Note that the previous implementation tried to merge both + -- Called_Task and Called_PO but this ended up in many unexpected + -- complications (e.g having to add a magic number in the ATCB, which + -- caused gdb lots of confusion) with no real gain since the + -- Lock_Server implementation still need to loop around chasing for + -- pointer changes even with a single pointer. + + Acceptor_Prev_Call : Entry_Call_Link; + -- For task entry calls only + + Acceptor_Prev_Priority : Rendezvous_Priority := Priority_Not_Boosted; + -- For task entry calls only. The priority of the most recent prior + -- call being serviced. For protected entry calls, this function should + -- be performed by GNULLI ceiling locking. + + Cancellation_Attempted : Boolean := False; + pragma Atomic (Cancellation_Attempted); + -- Cancellation of the call has been attempted. + -- Consider merging this into State??? + + With_Abort : Boolean := False; + -- Tell caller whether the call may be aborted + -- ??? consider merging this with Was_Abortable state + + Needs_Requeue : Boolean := False; + -- Temporary to tell acceptor of task entry call that + -- Exceptional_Complete_Rendezvous needs to do requeue. + end record; + + ------------------------------------ + -- Task related other definitions -- + ------------------------------------ + + type Access_Address is access all System.Address; + -- Anonymous pointer used to implement task attributes (see s-tataat.adb + -- and a-tasatt.adb) + + pragma No_Strict_Aliasing (Access_Address); + -- This type is used in contexts where aliasing may be an issue (see + -- for example s-tataat.adb), so we avoid any incorrect aliasing + -- assumptions. + + ---------------------------------------------- + -- Ada_Task_Control_Block (ATCB) definition -- + ---------------------------------------------- + + type Entry_Call_Array is array (ATC_Level_Index) of + aliased Entry_Call_Record; + + type Atomic_Address is mod Memory_Size; + pragma Atomic (Atomic_Address); + type Attribute_Array is + array (1 .. Parameters.Max_Attribute_Count) of Atomic_Address; + -- Array of task attributes. The value (Atomic_Address) will either be + -- converted to a task attribute if it fits, or to a pointer to a record + -- by Ada.Task_Attributes. + + type Task_Serial_Number is mod 2 ** Long_Long_Integer'Size; + -- Used to give each task a unique serial number. We want 64-bits for this + -- type to get as much uniqueness as possible (2**64 is operationally + -- infinite in this context, but 2**32 perhaps could recycle). We use + -- Long_Long_Integer (which in the normal case is always 64-bits) rather + -- than 64-bits explicitly to allow codepeer to analyze this unit when + -- a target configuration file forces the maximum integer size to 32. + + type Ada_Task_Control_Block (Entry_Num : Task_Entry_Index) is limited record + Common : Common_ATCB; + -- The common part between various tasking implementations + + Entry_Calls : Entry_Call_Array; + -- An array of entry calls + -- + -- Protection: The elements of this array are on entry call queues + -- associated with protected objects or task entries, and are protected + -- by the protected object lock or Acceptor.L, respectively. + + New_Base_Priority : System.Any_Priority; + -- New value for Base_Priority (for dynamic priorities package) + -- + -- Protection: Self.L + + Open_Accepts : Accept_List_Access; + -- This points to the Open_Accepts array of accept alternatives passed + -- to the RTS by the compiler-generated code to Selective_Wait. It is + -- non-null iff this task is ready to accept an entry call. + -- + -- Protection: Self.L + + Chosen_Index : Select_Index; + -- The index in Open_Accepts of the entry call accepted by a selective + -- wait executed by this task. + -- + -- Protection: Written by both Self and Caller. Usually protected by + -- Self.L. However, once the selection is known to have been written it + -- can be accessed without protection. This happens after Self has + -- updated it itself using information from a suspended Caller, or + -- after Caller has updated it and awakened Self. + + Master_of_Task : Master_Level; + -- The task executing the master of this task, and the ID of this task's + -- master (unique only among masters currently active within Parent). + -- + -- Protection: Set by Activator before Self is activated, and read + -- after Self is activated. + + Master_Within : Master_Level; + -- The ID of the master currently executing within this task; that is, + -- the most deeply nested currently active master. + -- + -- Protection: Only written by Self, and only read by Self or by + -- dependents when Self is attempting to exit a master. Since Self will + -- not write this field until the master is complete, the + -- synchronization should be adequate to prevent races. + + Alive_Count : Natural := 0; + -- Number of tasks directly dependent on this task (including itself) + -- that are still "alive", i.e. not terminated. + -- + -- Protection: Self.L + + Awake_Count : Natural := 0; + -- Number of tasks directly dependent on this task (including itself) + -- still "awake", i.e., are not terminated and not waiting on a + -- terminate alternative. + -- + -- Invariant: Awake_Count <= Alive_Count + + -- Protection: Self.L + + -- Beginning of flags + + Aborting : Boolean := False; + pragma Atomic (Aborting); + -- Self is in the process of aborting. While set, prevents multiple + -- abort signals from being sent by different aborter while abort + -- is acted upon. This is essential since an aborter which calls + -- Abort_To_Level could set the Pending_ATC_Level to yet a lower level + -- (than the current level), may be preempted and would send the + -- abort signal when resuming execution. At this point, the abortee + -- may have completed abort to the proper level such that the + -- signal (and resulting abort exception) are not handled any more. + -- In other words, the flag prevents a race between multiple aborters + -- + -- Protection: protected by atomic access. + + ATC_Hack : Boolean := False; + pragma Atomic (ATC_Hack); + -- ????? + -- Temporary fix, to allow Undefer_Abort to reset Aborting in the + -- handler for Abort_Signal that encloses an async. entry call. + -- For the longer term, this should be done via code in the + -- handler itself. + + Callable : Boolean := True; + -- It is OK to call entries of this task + + Dependents_Aborted : Boolean := False; + -- This is set to True by whichever task takes responsibility for + -- aborting the dependents of this task. + -- + -- Protection: Self.L + + Interrupt_Entry : Boolean := False; + -- Indicates if one or more Interrupt Entries are attached to the task. + -- This flag is needed for cleaning up the Interrupt Entry bindings. + + Pending_Action : Boolean := False; + -- Unified flag indicating some action needs to be take when abort + -- next becomes undeferred. Currently set if: + -- . Pending_Priority_Change is set + -- . Pending_ATC_Level is changed + -- . Requeue involving POs + -- (Abortable field may have changed and the Wait_Until_Abortable + -- has to recheck the abortable status of the call.) + -- . Exception_To_Raise is non-null + -- + -- Protection: Self.L + -- + -- This should never be reset back to False outside of the procedure + -- Do_Pending_Action, which is called by Undefer_Abort. It should only + -- be set to True by Set_Priority and Abort_To_Level. + + Pending_Priority_Change : Boolean := False; + -- Flag to indicate pending priority change (for dynamic priorities + -- package). The base priority is updated on the next abort + -- completion point (aka. synchronization point). + -- + -- Protection: Self.L + + Terminate_Alternative : Boolean := False; + -- Task is accepting Select with Terminate Alternative + -- + -- Protection: Self.L + + -- End of flags + + -- Beginning of counts + + ATC_Nesting_Level : ATC_Level := 1; + -- The dynamic level of ATC nesting (currently executing nested + -- asynchronous select statements) in this task. + + -- Protection: Self_ID.L. Only Self reads or updates this field. + -- Decrementing it deallocates an Entry_Calls component, and care must + -- be taken that all references to that component are eliminated before + -- doing the decrement. This in turn will require locking a protected + -- object (for a protected entry call) or the Acceptor's lock (for a + -- task entry call). No other task should attempt to read or modify + -- this value. + + Deferral_Level : Natural := 1; + -- This is the number of times that Defer_Abort has been called by + -- this task without a matching Undefer_Abort call. Abortion is only + -- allowed when this zero. It is initially 1, to protect the task at + -- startup. + + -- Protection: Only updated by Self; access assumed to be atomic + + Pending_ATC_Level : ATC_Level_Base := ATC_Level_Infinity; + -- The ATC level to which this task is currently being aborted. If the + -- value is zero, the entire task has "completed". That may be via + -- abort, exception propagation, or normal exit. If the value is + -- ATC_Level_Infinity, the task is not being aborted to any level. If + -- the value is positive, the task has not completed. This should ONLY + -- be modified by Abort_To_Level and Exit_One_ATC_Level. + -- + -- Protection: Self.L + + Serial_Number : Task_Serial_Number; + -- Monotonic counter to provide some way to check locking rules/ordering + + Known_Tasks_Index : Integer := -1; + -- Index in the System.Tasking.Debug.Known_Tasks array + + User_State : Long_Integer := 0; + -- User-writeable location, for use in debugging tasks; also provides a + -- simple task specific data. + + Free_On_Termination : Boolean := False; + -- Deallocate the ATCB when the task terminates. This flag is normally + -- False, and is set True when Unchecked_Deallocation is called on a + -- non-terminated task so that the associated storage is automatically + -- reclaimed when the task terminates. + + Attributes : Attribute_Array := (others => 0); + -- Task attributes + + -- IMPORTANT Note: the Entry_Queues field is last for efficiency of + -- access to other fields, do not put new fields after this one. + + Entry_Queues : Task_Entry_Queue_Array (1 .. Entry_Num); + -- An array of task entry queues + -- + -- Protection: Self.L. Once a task has set Self.Stage to Completing, it + -- has exclusive access to this field. + end record; + + -------------------- + -- Initialization -- + -------------------- + + procedure Initialize; + -- This procedure constitutes the first part of the initialization of the + -- GNARL. This includes creating data structures to make the initial thread + -- into the environment task. The last part of the initialization is done + -- in System.Tasking.Initialization or System.Tasking.Restricted.Stages. + -- All the initializations used to be in Tasking.Initialization, but this + -- is no longer possible with the run time simplification (including + -- optimized PO and the restricted run time) since one cannot rely on + -- System.Tasking.Initialization being present, as was done before. + + procedure Initialize_ATCB + (Self_ID : Task_Id; + Task_Entry_Point : Task_Procedure_Access; + Task_Arg : System.Address; + Parent : Task_Id; + Elaborated : Access_Boolean; + Base_Priority : System.Any_Priority; + Base_CPU : System.Multiprocessors.CPU_Range; + Domain : Dispatching_Domain_Access; + Task_Info : System.Task_Info.Task_Info_Type; + Stack_Size : System.Parameters.Size_Type; + Secondary_Stack_Size : System.Parameters.Size_Type; + T : Task_Id; + Success : out Boolean); + -- Initialize fields of the TCB for task T, and link into global TCB + -- structures. Call this only with abort deferred and holding RTS_Lock. + -- Self_ID is the calling task (normally the activator of T). Success is + -- set to indicate whether the TCB was successfully initialized. + +private + + Null_Task : constant Task_Id := null; + + type Activation_Chain is limited record + T_ID : Task_Id; + end record; + + -- Activation_Chain is an in-out parameter of initialization procedures and + -- it must be passed by reference because the init proc may terminate + -- abnormally after creating task components, and these must be properly + -- registered for removal (Expunge_Unactivated_Tasks). The "limited" forces + -- Activation_Chain to be a by-reference type; see RM-6.2(4). + + function Number_Of_Entries (Self_Id : Task_Id) return Entry_Index; + -- Given a task, return the number of entries it contains +end System.Tasking; 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-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-tasque.adb b/gcc/ada/libgnarl/s-tasque.adb new file mode 100644 index 00000000000..f6014682f95 --- /dev/null +++ b/gcc/ada/libgnarl/s-tasque.adb @@ -0,0 +1,625 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . Q U E U I N G -- +-- -- +-- 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 version of the body implements queueing policy according to the policy +-- specified by the pragma Queuing_Policy. When no such pragma is specified +-- FIFO policy is used as default. + +with System.Task_Primitives.Operations; +with System.Tasking.Initialization; +with System.Parameters; + +package body System.Tasking.Queuing is + + use Parameters; + use Task_Primitives.Operations; + use Protected_Objects; + use Protected_Objects.Entries; + + -- Entry Queues implemented as doubly linked list + + Queuing_Policy : Character; + pragma Import (C, Queuing_Policy, "__gl_queuing_policy"); + + Priority_Queuing : constant Boolean := Queuing_Policy = 'P'; + + procedure Send_Program_Error + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + -- Raise Program_Error in the caller of the specified entry call + + function Check_Queue (E : Entry_Queue) return Boolean; + -- Check the validity of E. + -- Return True if E is valid, raise Assert_Failure if assertions are + -- enabled and False otherwise. + + ----------------------------- + -- Broadcast_Program_Error -- + ----------------------------- + + procedure Broadcast_Program_Error + (Self_ID : Task_Id; + Object : Protection_Entries_Access; + Pending_Call : Entry_Call_Link; + RTS_Locked : Boolean := False) + is + Entry_Call : Entry_Call_Link; + begin + if Single_Lock and then not RTS_Locked then + Lock_RTS; + end if; + + if Pending_Call /= null then + Send_Program_Error (Self_ID, Pending_Call); + end if; + + for E in Object.Entry_Queues'Range loop + Dequeue_Head (Object.Entry_Queues (E), Entry_Call); + + while Entry_Call /= null loop + pragma Assert (Entry_Call.Mode /= Conditional_Call); + + Send_Program_Error (Self_ID, Entry_Call); + Dequeue_Head (Object.Entry_Queues (E), Entry_Call); + end loop; + end loop; + + if Single_Lock and then not RTS_Locked then + Unlock_RTS; + end if; + end Broadcast_Program_Error; + + ----------------- + -- Check_Queue -- + ----------------- + + function Check_Queue (E : Entry_Queue) return Boolean is + Valid : Boolean := True; + C, Prev : Entry_Call_Link; + + begin + if E.Head = null then + if E.Tail /= null then + Valid := False; + pragma Assert (Valid); + end if; + else + if E.Tail = null + or else E.Tail.Next /= E.Head + then + Valid := False; + pragma Assert (Valid); + + else + C := E.Head; + + loop + Prev := C; + C := C.Next; + + if C = null then + Valid := False; + pragma Assert (Valid); + exit; + end if; + + if Prev /= C.Prev then + Valid := False; + pragma Assert (Valid); + exit; + end if; + + exit when C = E.Head; + end loop; + + if Prev /= E.Tail then + Valid := False; + pragma Assert (Valid); + end if; + end if; + end if; + + return Valid; + end Check_Queue; + + ------------------- + -- Count_Waiting -- + ------------------- + + -- Return number of calls on the waiting queue of E + + function Count_Waiting (E : Entry_Queue) return Natural is + Count : Natural; + Temp : Entry_Call_Link; + + begin + pragma Assert (Check_Queue (E)); + + Count := 0; + + if E.Head /= null then + Temp := E.Head; + + loop + Count := Count + 1; + exit when E.Tail = Temp; + Temp := Temp.Next; + end loop; + end if; + + return Count; + end Count_Waiting; + + ------------- + -- Dequeue -- + ------------- + + -- Dequeue call from entry_queue E + + procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is + begin + pragma Assert (Check_Queue (E)); + pragma Assert (Call /= null); + + -- If empty queue, simply return + + if E.Head = null then + return; + end if; + + pragma Assert (Call.Prev /= null); + pragma Assert (Call.Next /= null); + + Call.Prev.Next := Call.Next; + Call.Next.Prev := Call.Prev; + + if E.Head = Call then + + -- Case of one element + + if E.Tail = Call then + E.Head := null; + E.Tail := null; + + -- More than one element + + else + E.Head := Call.Next; + end if; + + elsif E.Tail = Call then + E.Tail := Call.Prev; + end if; + + -- Successfully dequeued + + Call.Prev := null; + Call.Next := null; + pragma Assert (Check_Queue (E)); + end Dequeue; + + ------------------ + -- Dequeue_Call -- + ------------------ + + procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is + Called_PO : Protection_Entries_Access; + + begin + pragma Assert (Entry_Call /= null); + + if Entry_Call.Called_Task /= null then + Dequeue + (Entry_Call.Called_Task.Entry_Queues + (Task_Entry_Index (Entry_Call.E)), + Entry_Call); + + else + Called_PO := To_Protection (Entry_Call.Called_PO); + Dequeue (Called_PO.Entry_Queues + (Protected_Entry_Index (Entry_Call.E)), + Entry_Call); + end if; + end Dequeue_Call; + + ------------------ + -- Dequeue_Head -- + ------------------ + + -- Remove and return the head of entry_queue E + + procedure Dequeue_Head + (E : in out Entry_Queue; + Call : out Entry_Call_Link) + is + Temp : Entry_Call_Link; + + begin + pragma Assert (Check_Queue (E)); + -- If empty queue, return null pointer + + if E.Head = null then + Call := null; + return; + end if; + + Temp := E.Head; + + -- Case of one element + + if E.Head = E.Tail then + E.Head := null; + E.Tail := null; + + -- More than one element + + else + pragma Assert (Temp /= null); + pragma Assert (Temp.Next /= null); + pragma Assert (Temp.Prev /= null); + + E.Head := Temp.Next; + Temp.Prev.Next := Temp.Next; + Temp.Next.Prev := Temp.Prev; + end if; + + -- Successfully dequeued + + Temp.Prev := null; + Temp.Next := null; + Call := Temp; + pragma Assert (Check_Queue (E)); + end Dequeue_Head; + + ------------- + -- Enqueue -- + ------------- + + -- Enqueue call at the end of entry_queue E, for FIFO queuing policy. + -- Enqueue call priority ordered, FIFO at same priority level, for + -- Priority queuing policy. + + procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is + Temp : Entry_Call_Link := E.Head; + + begin + pragma Assert (Check_Queue (E)); + pragma Assert (Call /= null); + + -- Priority Queuing + + if Priority_Queuing then + if Temp = null then + Call.Prev := Call; + Call.Next := Call; + E.Head := Call; + E.Tail := Call; + + else + loop + -- Find the entry that the new guy should precede + + exit when Call.Prio > Temp.Prio; + Temp := Temp.Next; + + if Temp = E.Head then + Temp := null; + exit; + end if; + end loop; + + if Temp = null then + -- Insert at tail + + Call.Prev := E.Tail; + Call.Next := E.Head; + E.Tail := Call; + + else + Call.Prev := Temp.Prev; + Call.Next := Temp; + + -- Insert at head + + if Temp = E.Head then + E.Head := Call; + end if; + end if; + + pragma Assert (Call.Prev /= null); + pragma Assert (Call.Next /= null); + + Call.Prev.Next := Call; + Call.Next.Prev := Call; + end if; + + pragma Assert (Check_Queue (E)); + return; + end if; + + -- FIFO Queuing + + if E.Head = null then + E.Head := Call; + else + E.Tail.Next := Call; + Call.Prev := E.Tail; + end if; + + E.Head.Prev := Call; + E.Tail := Call; + Call.Next := E.Head; + pragma Assert (Check_Queue (E)); + end Enqueue; + + ------------------ + -- Enqueue_Call -- + ------------------ + + procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is + Called_PO : Protection_Entries_Access; + + begin + pragma Assert (Entry_Call /= null); + + if Entry_Call.Called_Task /= null then + Enqueue + (Entry_Call.Called_Task.Entry_Queues + (Task_Entry_Index (Entry_Call.E)), + Entry_Call); + + else + Called_PO := To_Protection (Entry_Call.Called_PO); + Enqueue (Called_PO.Entry_Queues + (Protected_Entry_Index (Entry_Call.E)), + Entry_Call); + end if; + end Enqueue_Call; + + ---------- + -- Head -- + ---------- + + -- Return the head of entry_queue E + + function Head (E : Entry_Queue) return Entry_Call_Link is + begin + pragma Assert (Check_Queue (E)); + return E.Head; + end Head; + + ------------- + -- Onqueue -- + ------------- + + -- Return True if Call is on any entry_queue at all + + function Onqueue (Call : Entry_Call_Link) return Boolean is + begin + pragma Assert (Call /= null); + + -- Utilize the fact that every queue is circular, so if Call + -- is on any queue at all, Call.Next must NOT be null. + + return Call.Next /= null; + end Onqueue; + + -------------------------------- + -- Requeue_Call_With_New_Prio -- + -------------------------------- + + procedure Requeue_Call_With_New_Prio + (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is + begin + pragma Assert (Entry_Call /= null); + + -- Perform a queue reordering only when the policy being used is the + -- Priority Queuing. + + if Priority_Queuing then + if Onqueue (Entry_Call) then + Dequeue_Call (Entry_Call); + Entry_Call.Prio := Prio; + Enqueue_Call (Entry_Call); + end if; + end if; + end Requeue_Call_With_New_Prio; + + --------------------------------- + -- Select_Protected_Entry_Call -- + --------------------------------- + + -- Select an entry of a protected object. Selection depends on the + -- queuing policy being used. + + procedure Select_Protected_Entry_Call + (Self_ID : Task_Id; + Object : Protection_Entries_Access; + Call : out Entry_Call_Link) + is + Entry_Call : Entry_Call_Link; + Temp_Call : Entry_Call_Link; + Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning + + begin + Entry_Call := null; + + begin + -- Priority queuing case + + if Priority_Queuing then + for J in Object.Entry_Queues'Range loop + Temp_Call := Head (Object.Entry_Queues (J)); + + if Temp_Call /= null + and then + Object.Entry_Bodies + (Object.Find_Body_Index + (Object.Compiler_Info, J)). + Barrier (Object.Compiler_Info, J) + then + if Entry_Call = null + or else Entry_Call.Prio < Temp_Call.Prio + then + Entry_Call := Temp_Call; + Entry_Index := J; + end if; + end if; + end loop; + + -- FIFO queueing case + + else + for J in Object.Entry_Queues'Range loop + Temp_Call := Head (Object.Entry_Queues (J)); + + if Temp_Call /= null + and then + Object.Entry_Bodies + (Object.Find_Body_Index + (Object.Compiler_Info, J)). + Barrier (Object.Compiler_Info, J) + then + Entry_Call := Temp_Call; + Entry_Index := J; + exit; + end if; + end loop; + end if; + + exception + when others => + Broadcast_Program_Error (Self_ID, Object, null); + end; + + -- If a call was selected, dequeue it and return it for service + + if Entry_Call /= null then + Temp_Call := Entry_Call; + Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call); + pragma Assert (Temp_Call = Entry_Call); + end if; + + Call := Entry_Call; + end Select_Protected_Entry_Call; + + ---------------------------- + -- Select_Task_Entry_Call -- + ---------------------------- + + -- Select an entry for rendezvous. Selection depends on the queuing policy + -- being used. + + procedure Select_Task_Entry_Call + (Acceptor : Task_Id; + Open_Accepts : Accept_List_Access; + Call : out Entry_Call_Link; + Selection : out Select_Index; + Open_Alternative : out Boolean) + is + Entry_Call : Entry_Call_Link; + Temp_Call : Entry_Call_Link; + Entry_Index : Task_Entry_Index := Task_Entry_Index'First; + Temp_Entry : Task_Entry_Index; + + begin + Open_Alternative := False; + Entry_Call := null; + Selection := No_Rendezvous; + + if Priority_Queuing then + -- Priority queueing case + + for J in Open_Accepts'Range loop + Temp_Entry := Open_Accepts (J).S; + + if Temp_Entry /= Null_Task_Entry then + Open_Alternative := True; + Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + + if Temp_Call /= null + and then (Entry_Call = null + or else Entry_Call.Prio < Temp_Call.Prio) + then + Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + Entry_Index := Temp_Entry; + Selection := J; + end if; + end if; + end loop; + + else + -- FIFO Queuing case + + for J in Open_Accepts'Range loop + Temp_Entry := Open_Accepts (J).S; + + if Temp_Entry /= Null_Task_Entry then + Open_Alternative := True; + Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + + if Temp_Call /= null then + Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + Entry_Index := Temp_Entry; + Selection := J; + exit; + end if; + end if; + end loop; + end if; + + if Entry_Call /= null then + Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call); + + -- Guard is open + end if; + + Call := Entry_Call; + end Select_Task_Entry_Call; + + ------------------------ + -- Send_Program_Error -- + ------------------------ + + procedure Send_Program_Error + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + Caller : Task_Id; + begin + Caller := Entry_Call.Self; + Entry_Call.Exception_To_Raise := Program_Error'Identity; + Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + Unlock (Caller); + end Send_Program_Error; + +end System.Tasking.Queuing; diff --git a/gcc/ada/libgnarl/s-tasque.ads b/gcc/ada/libgnarl/s-tasque.ads new file mode 100644 index 00000000000..2222644aac3 --- /dev/null +++ b/gcc/ada/libgnarl/s-tasque.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . Q U E U I N G -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Tasking.Protected_Objects.Entries; + +package System.Tasking.Queuing is + + package POE renames System.Tasking.Protected_Objects.Entries; + + procedure Broadcast_Program_Error + (Self_ID : Task_Id; + Object : POE.Protection_Entries_Access; + Pending_Call : Entry_Call_Link; + RTS_Locked : Boolean := False); + -- Raise Program_Error in all tasks calling the protected entries of Object + -- The exception will not be raised immediately for the calling task; it + -- will be deferred until it calls Check_Exception. + -- RTS_Locked indicates whether the global RTS lock is taken (only + -- relevant if Single_Lock is True). + + procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link); + -- Enqueue Call at the end of entry_queue E + + procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link); + -- Dequeue Call from entry_queue E + + function Head (E : Entry_Queue) return Entry_Call_Link; + pragma Inline (Head); + -- Return the head of entry_queue E + + procedure Dequeue_Head + (E : in out Entry_Queue; + Call : out Entry_Call_Link); + -- Remove and return the head of entry_queue E + + function Onqueue (Call : Entry_Call_Link) return Boolean; + pragma Inline (Onqueue); + -- Return True if Call is on any entry_queue at all + + function Count_Waiting (E : Entry_Queue) return Natural; + -- Return number of calls on the waiting queue of E + + procedure Select_Task_Entry_Call + (Acceptor : Task_Id; + Open_Accepts : Accept_List_Access; + Call : out Entry_Call_Link; + Selection : out Select_Index; + Open_Alternative : out Boolean); + -- Select an entry for rendezvous. On exit: + -- Call will contain a pointer to the entry call record selected; + -- Selection will contain the index of the alternative selected + -- Open_Alternative will be True if there were any open alternatives + + procedure Select_Protected_Entry_Call + (Self_ID : Task_Id; + Object : POE.Protection_Entries_Access; + Call : out Entry_Call_Link); + -- Select an entry of a protected object + + procedure Enqueue_Call (Entry_Call : Entry_Call_Link); + procedure Dequeue_Call (Entry_Call : Entry_Call_Link); + -- Enqueue (dequeue) the call to (from) whatever server they are + -- calling, whether a task or a protected object. + + procedure Requeue_Call_With_New_Prio + (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority); + -- Change Priority of the call and re insert to the queue when priority + -- queueing is in effect. When FIFO is enforced, this routine + -- should not have any effect. + +end System.Tasking.Queuing; diff --git a/gcc/ada/libgnarl/s-tasren.adb b/gcc/ada/libgnarl/s-tasren.adb new file mode 100644 index 00000000000..c1b35482c41 --- /dev/null +++ b/gcc/ada/libgnarl/s-tasren.adb @@ -0,0 +1,1732 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E N D E Z V O U 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Primitives.Operations; +with System.Tasking.Entry_Calls; +with System.Tasking.Initialization; +with System.Tasking.Queuing; +with System.Tasking.Utilities; +with System.Tasking.Protected_Objects.Operations; +with System.Tasking.Debug; +with System.Restrictions; +with System.Parameters; + +package body System.Tasking.Rendezvous is + + package STPO renames System.Task_Primitives.Operations; + package POO renames Protected_Objects.Operations; + package POE renames Protected_Objects.Entries; + + use Parameters; + use Task_Primitives.Operations; + + type Select_Treatment is ( + Accept_Alternative_Selected, -- alternative with non-null body + Accept_Alternative_Completed, -- alternative with null body + Else_Selected, + Terminate_Selected, + Accept_Alternative_Open, + No_Alternative_Open); + + ---------------- + -- Local Data -- + ---------------- + + Default_Treatment : constant array (Select_Modes) of Select_Treatment := + (Simple_Mode => No_Alternative_Open, + Else_Mode => Else_Selected, + Terminate_Mode => Terminate_Selected, + Delay_Mode => No_Alternative_Open); + + New_State : constant array (Boolean, Entry_Call_State) + of Entry_Call_State := + (True => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Now_Abortable, + Was_Abortable => Now_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled), + False => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Not_Yet_Abortable, + Was_Abortable => Was_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled) + ); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Local_Defer_Abort (Self_Id : Task_Id) renames + System.Tasking.Initialization.Defer_Abort_Nestable; + + procedure Local_Undefer_Abort (Self_Id : Task_Id) renames + System.Tasking.Initialization.Undefer_Abort_Nestable; + + -- Florist defers abort around critical sections that make entry calls + -- to the Interrupt_Manager task, which violates the general rule about + -- top-level runtime system calls from abort-deferred regions. It is not + -- that this is unsafe, but when it occurs in "normal" programs it usually + -- means either the user is trying to do a potentially blocking operation + -- from within a protected object, or there is a runtime system/compiler + -- error that has failed to undefer an earlier abort deferral. Thus, for + -- debugging it may be wise to modify the above renamings to the + -- non-nestable forms. + + procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id); + -- Internal version of Complete_Rendezvous, used to implement + -- Complete_Rendezvous and Exceptional_Complete_Rendezvous. + -- Should be called holding no locks, generally with abort + -- not yet deferred. + + procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id); + pragma Inline (Boost_Priority); + -- Call this only with abort deferred and holding lock of Acceptor + + procedure Call_Synchronous + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean); + pragma Inline (Call_Synchronous); + -- This call is used to make a simple or conditional entry call. + -- Called from Call_Simple and Task_Entry_Call. + + procedure Setup_For_Rendezvous_With_Body + (Entry_Call : Entry_Call_Link; + Acceptor : Task_Id); + pragma Inline (Setup_For_Rendezvous_With_Body); + -- Call this only with abort deferred and holding lock of Acceptor. When + -- a rendezvous selected (ready for rendezvous) we need to save previous + -- caller and adjust the priority. Also we need to make this call not + -- Abortable (Cancellable) since the rendezvous has already been started. + + procedure Wait_For_Call (Self_Id : Task_Id); + pragma Inline (Wait_For_Call); + -- Call this only with abort deferred and holding lock of Self_Id. An + -- accepting task goes into Sleep by calling this routine waiting for a + -- call from the caller or waiting for an abort. Make sure Self_Id is + -- locked before calling this routine. + + ----------------- + -- Accept_Call -- + ----------------- + + procedure Accept_Call + (E : Task_Entry_Index; + Uninterpreted_Data : out System.Address) + is + Self_Id : constant Task_Id := STPO.Self; + Caller : Task_Id := null; + Open_Accepts : aliased Accept_List (1 .. 1); + Entry_Call : Entry_Call_Link; + + begin + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); + + if Entry_Call /= null then + Caller := Entry_Call.Self; + Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); + Uninterpreted_Data := Entry_Call.Uninterpreted_Data; + + else + -- Wait for a caller + + Open_Accepts (1).Null_Body := False; + Open_Accepts (1).S := E; + Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; + + -- Wait for normal call + + pragma Debug + (Debug.Trace (Self_Id, "Accept_Call: wait", 'R')); + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + if Self_Id.Common.Call /= null then + Caller := Self_Id.Common.Call.Self; + Uninterpreted_Data := + Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data; + else + -- Case of an aborted task + + Uninterpreted_Data := System.Null_Address; + end if; + end if; + + -- Self_Id.Common.Call should already be updated by the Caller. On + -- return, we will start the rendezvous. + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + end Accept_Call; + + -------------------- + -- Accept_Trivial -- + -------------------- + + procedure Accept_Trivial (E : Task_Entry_Index) is + Self_Id : constant Task_Id := STPO.Self; + Caller : Task_Id := null; + Open_Accepts : aliased Accept_List (1 .. 1); + Entry_Call : Entry_Call_Link; + + begin + Initialization.Defer_Abort_Nestable (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort_Nestable (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); + + if Entry_Call = null then + + -- Need to wait for entry call + + Open_Accepts (1).Null_Body := True; + Open_Accepts (1).S := E; + Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; + + pragma Debug + (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R')); + + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + -- No need to do anything special here for pending abort. + -- Abort_Signal will be raised by Undefer on exit. + + STPO.Unlock (Self_Id); + + -- Found caller already waiting + + else + pragma Assert (Entry_Call.State < Done); + + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + end if; + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort_Nestable (Self_Id); + end Accept_Trivial; + + -------------------- + -- Boost_Priority -- + -------------------- + + procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id) is + Caller : constant Task_Id := Call.Self; + Caller_Prio : constant System.Any_Priority := Get_Priority (Caller); + Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor); + begin + if Caller_Prio > Acceptor_Prio then + Call.Acceptor_Prev_Priority := Acceptor_Prio; + Set_Priority (Acceptor, Caller_Prio); + else + Call.Acceptor_Prev_Priority := Priority_Not_Boosted; + end if; + end Boost_Priority; + + ----------------- + -- Call_Simple -- + ----------------- + + procedure Call_Simple + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address) + is + Rendezvous_Successful : Boolean; + pragma Unreferenced (Rendezvous_Successful); + + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then STPO.Self.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with + "potentially blocking operation"; + end if; + + Call_Synchronous + (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful); + end Call_Simple; + + ---------------------- + -- Call_Synchronous -- + ---------------------- + + procedure Call_Synchronous + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Level : ATC_Level; + Entry_Call : Entry_Call_Link; + + begin + pragma Assert (Mode /= Asynchronous_Call); + + Local_Defer_Abort (Self_Id); + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_Id, "CS: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + Level := Self_Id.ATC_Nesting_Level; + Entry_Call := Self_Id.Entry_Calls (Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Mode; + Entry_Call.Cancellation_Attempted := False; + + -- If this is a call made inside of an abort deferred region, + -- the call should be never abortable. + + Entry_Call.State := + (if Self_Id.Deferral_Level > 1 + then Never_Abortable + else Now_Abortable); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_Task := Acceptor; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + -- Note: the caller will undefer abort on return (see WARNING above) + + if Single_Lock then + Lock_RTS; + end if; + + if not Task_Do_Or_Queue (Self_Id, Entry_Call) then + STPO.Write_Lock (Self_Id); + Utilities.Exit_One_ATC_Level (Self_Id); + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Local_Undefer_Abort (Self_Id); + raise Tasking_Error; + end if; + + STPO.Write_Lock (Self_Id); + pragma Debug + (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R')); + Entry_Calls.Wait_For_Completion (Entry_Call); + pragma Debug + (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R')); + Rendezvous_Successful := Entry_Call.State = Done; + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Local_Undefer_Abort (Self_Id); + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + end Call_Synchronous; + + -------------- + -- Callable -- + -------------- + + function Callable (T : Task_Id) return Boolean is + Result : Boolean; + Self_Id : constant Task_Id := STPO.Self; + + begin + Initialization.Defer_Abort_Nestable (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (T); + Result := T.Callable; + STPO.Unlock (T); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort_Nestable (Self_Id); + return Result; + end Callable; + + ---------------------------- + -- Cancel_Task_Entry_Call -- + ---------------------------- + + procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is + begin + Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled); + end Cancel_Task_Entry_Call; + + ------------------------- + -- Complete_Rendezvous -- + ------------------------- + + procedure Complete_Rendezvous is + begin + Local_Complete_Rendezvous (Ada.Exceptions.Null_Id); + end Complete_Rendezvous; + + ------------------------------------- + -- Exceptional_Complete_Rendezvous -- + ------------------------------------- + + procedure Exceptional_Complete_Rendezvous + (Ex : Ada.Exceptions.Exception_Id) + is + procedure Internal_Reraise; + pragma No_Return (Internal_Reraise); + pragma Import (C, Internal_Reraise, "__gnat_reraise"); + + begin + Local_Complete_Rendezvous (Ex); + Internal_Reraise; + + -- ??? Do we need to give precedence to Program_Error that might be + -- raised due to failure of finalization, over Tasking_Error from + -- failure of requeue? + end Exceptional_Complete_Rendezvous; + + ------------------------------- + -- Local_Complete_Rendezvous -- + ------------------------------- + + procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id) is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link := Self_Id.Common.Call; + Caller : Task_Id; + Called_PO : STPE.Protection_Entries_Access; + Acceptor_Prev_Priority : Integer; + + Ceiling_Violation : Boolean; + + use type Ada.Exceptions.Exception_Id; + procedure Transfer_Occurrence + (Target : Ada.Exceptions.Exception_Occurrence_Access; + Source : Ada.Exceptions.Exception_Occurrence); + pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); + + begin + -- The deferral level is critical here, since we want to raise an + -- exception or allow abort to take place, if there is an exception or + -- abort pending. + + pragma Debug + (Debug.Trace (Self_Id, "Local_Complete_Rendezvous", 'R')); + + if Ex = Ada.Exceptions.Null_Id then + + -- The call came from normal end-of-rendezvous, so abort is not yet + -- deferred. + + Initialization.Defer_Abort (Self_Id); + + elsif ZCX_By_Default then + + -- With ZCX, aborts are not automatically deferred in handlers + + Initialization.Defer_Abort (Self_Id); + end if; + + -- We need to clean up any accepts which Self may have been serving when + -- it was aborted. + + if Ex = Standard'Abort_Signal'Identity then + if Single_Lock then + Lock_RTS; + end if; + + while Entry_Call /= null loop + Entry_Call.Exception_To_Raise := Tasking_Error'Identity; + + -- All forms of accept make sure that the acceptor is not + -- completed, before accepting further calls, so that we + -- can be sure that no further calls are made after the + -- current calls are purged. + + Caller := Entry_Call.Self; + + -- Take write lock. This follows the lock precedence rule that + -- Caller may be locked while holding lock of Acceptor. Complete + -- the call abnormally, with exception. + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + Entry_Call := Entry_Call.Acceptor_Prev_Call; + end loop; + + if Single_Lock then + Unlock_RTS; + end if; + + else + Caller := Entry_Call.Self; + + if Entry_Call.Needs_Requeue then + + -- We dare not lock Self_Id at the same time as Caller, for fear + -- of deadlock. + + Entry_Call.Needs_Requeue := False; + Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; + + if Entry_Call.Called_Task /= null then + + -- Requeue to another task entry + + if Single_Lock then + Lock_RTS; + end if; + + if not Task_Do_Or_Queue (Self_Id, Entry_Call) then + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + raise Tasking_Error; + end if; + + if Single_Lock then + Unlock_RTS; + end if; + + else + -- Requeue to a protected entry + + Called_PO := POE.To_Protection (Entry_Call.Called_PO); + STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation); + + if Ceiling_Violation then + pragma Assert (Ex = Ada.Exceptions.Null_Id); + Entry_Call.Exception_To_Raise := Program_Error'Identity; + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller + (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + if Single_Lock then + Unlock_RTS; + end if; + + else + POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call); + POO.PO_Service_Entries (Self_Id, Called_PO); + end if; + end if; + + Entry_Calls.Reset_Priority + (Self_Id, Entry_Call.Acceptor_Prev_Priority); + + else + -- The call does not need to be requeued + + Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; + Entry_Call.Exception_To_Raise := Ex; + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + + -- Done with Caller locked to make sure that Wakeup is not lost + + if Ex /= Ada.Exceptions.Null_Id then + Transfer_Occurrence + (Caller.Common.Compiler_Data.Current_Excep'Access, + Self_Id.Common.Compiler_Data.Current_Excep); + end if; + + Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority; + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + + STPO.Unlock (Caller); + + if Single_Lock then + Unlock_RTS; + end if; + + Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority); + end if; + end if; + + Initialization.Undefer_Abort (Self_Id); + end Local_Complete_Rendezvous; + + ------------------------------------- + -- Requeue_Protected_To_Task_Entry -- + ------------------------------------- + + procedure Requeue_Protected_To_Task_Entry + (Object : STPE.Protection_Entries_Access; + Acceptor : Task_Id; + E : Task_Entry_Index; + With_Abort : Boolean) + is + Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; + begin + pragma Assert (STPO.Self.Deferral_Level > 0); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Called_Task := Acceptor; + Entry_Call.Called_PO := Null_Address; + Entry_Call.With_Abort := With_Abort; + Object.Call_In_Progress := null; + end Requeue_Protected_To_Task_Entry; + + ------------------------ + -- Requeue_Task_Entry -- + ------------------------ + + procedure Requeue_Task_Entry + (Acceptor : Task_Id; + E : Task_Entry_Index; + With_Abort : Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call; + begin + Initialization.Defer_Abort (Self_Id); + Entry_Call.Needs_Requeue := True; + Entry_Call.With_Abort := With_Abort; + Entry_Call.E := Entry_Index (E); + Entry_Call.Called_Task := Acceptor; + Initialization.Undefer_Abort (Self_Id); + end Requeue_Task_Entry; + + -------------------- + -- Selective_Wait -- + -------------------- + + procedure Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Index : out Select_Index) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + Treatment : Select_Treatment; + Caller : Task_Id; + Selection : Select_Index; + Open_Alternative : Boolean; + + begin + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + -- ??? In some cases abort is deferred more than once. Need to + -- figure out why this happens. + + if Self_Id.Deferral_Level > 1 then + Self_Id.Deferral_Level := 1; + end if; + + Initialization.Undefer_Abort (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + pragma Assert (Open_Accepts /= null); + + Uninterpreted_Data := Null_Address; + + Queuing.Select_Task_Entry_Call + (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); + + -- Determine the kind and disposition of the select + + Treatment := Default_Treatment (Select_Mode); + Self_Id.Chosen_Index := No_Rendezvous; + + if Open_Alternative then + if Entry_Call /= null then + if Open_Accepts (Selection).Null_Body then + Treatment := Accept_Alternative_Completed; + else + Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); + Treatment := Accept_Alternative_Selected; + end if; + + Self_Id.Chosen_Index := Selection; + + elsif Treatment = No_Alternative_Open then + Treatment := Accept_Alternative_Open; + end if; + end if; + + -- Handle the select according to the disposition selected above + + case Treatment is + when Accept_Alternative_Selected => + + -- Ready to rendezvous + + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + -- In this case the accept body is not Null_Body. Defer abort + -- until it gets into the accept body. The compiler has inserted + -- a call to Abort_Undefer as part of the entry expansion. + + pragma Assert (Self_Id.Deferral_Level = 1); + + Initialization.Defer_Abort_Nestable (Self_Id); + STPO.Unlock (Self_Id); + + when Accept_Alternative_Completed => + + -- Accept body is null, so rendezvous is over immediately + + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + when Accept_Alternative_Open => + + -- Wait for caller + + Self_Id.Open_Accepts := Open_Accepts; + pragma Debug + (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R')); + + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + -- Self_Id.Common.Call should already be updated by the Caller if + -- not aborted. It might also be ready to do rendezvous even if + -- this wakes up due to an abort. Therefore, if the call is not + -- empty we need to do the rendezvous if the accept body is not + -- Null_Body. + + -- Aren't the first two conditions below redundant??? + + if Self_Id.Chosen_Index /= No_Rendezvous + and then Self_Id.Common.Call /= null + and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + pragma Assert + (Self_Id.Deferral_Level = 1 + or else + (Self_Id.Deferral_Level = 0 + and then not Restrictions.Abort_Allowed)); + + Initialization.Defer_Abort_Nestable (Self_Id); + + -- Leave abort deferred until the accept body + -- The compiler has inserted a call to Abort_Undefer as part of + -- the entry expansion. + end if; + + STPO.Unlock (Self_Id); + + when Else_Selected => + pragma Assert (Self_Id.Open_Accepts = null); + + STPO.Unlock (Self_Id); + + when Terminate_Selected => + + -- Terminate alternative is open + + Self_Id.Open_Accepts := Open_Accepts; + Self_Id.Common.State := Acceptor_Sleep; + + -- Notify ancestors that this task is on a terminate alternative + + STPO.Unlock (Self_Id); + Utilities.Make_Passive (Self_Id, Task_Completed => False); + STPO.Write_Lock (Self_Id); + + -- Wait for normal entry call or termination + + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + if Self_Id.Terminate_Alternative then + + -- An entry call should have reset this to False, so we must be + -- aborted. We cannot be in an async. select, since that is not + -- legal, so the abort must be of the entire task. Therefore, + -- we do not need to cancel the terminate alternative. The + -- cleanup will be done in Complete_Master. + + pragma Assert (Self_Id.Pending_ATC_Level = 0); + pragma Assert (Self_Id.Awake_Count = 0); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Index := Self_Id.Chosen_Index; + Initialization.Undefer_Abort_Nestable (Self_Id); + + if Self_Id.Pending_Action then + Initialization.Do_Pending_Action (Self_Id); + end if; + + return; + + else + -- Self_Id.Common.Call and Self_Id.Chosen_Index + -- should already be updated by the Caller. + + if Self_Id.Chosen_Index /= No_Rendezvous + and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + pragma Assert (Self_Id.Deferral_Level = 1); + + -- We need an extra defer here, to keep abort + -- deferred until we get into the accept body + -- The compiler has inserted a call to Abort_Undefer as part + -- of the entry expansion. + + Initialization.Defer_Abort_Nestable (Self_Id); + end if; + end if; + + STPO.Unlock (Self_Id); + + when No_Alternative_Open => + + -- In this case, Index will be No_Rendezvous on return, which + -- should cause a Program_Error if it is not a Delay_Mode. + + -- If delay alternative exists (Delay_Mode) we should suspend + -- until the delay expires. + + Self_Id.Open_Accepts := null; + + if Select_Mode = Delay_Mode then + Self_Id.Common.State := Delay_Sleep; + + loop + exit when + Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level; + Sleep (Self_Id, Delay_Sleep); + end loop; + + Self_Id.Common.State := Runnable; + STPO.Unlock (Self_Id); + + else + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + raise Program_Error with + "entry call not a delay mode"; + end if; + end case; + + if Single_Lock then + Unlock_RTS; + end if; + + -- Caller has been chosen + + -- Self_Id.Common.Call should already be updated by the Caller. + + -- Self_Id.Chosen_Index should either be updated by the Caller + -- or by Test_Selective_Wait. + + -- On return, we sill start rendezvous unless the accept body is + -- null. In the latter case, we will have already completed the RV. + + Index := Self_Id.Chosen_Index; + Initialization.Undefer_Abort_Nestable (Self_Id); + end Selective_Wait; + + ------------------------------------ + -- Setup_For_Rendezvous_With_Body -- + ------------------------------------ + + procedure Setup_For_Rendezvous_With_Body + (Entry_Call : Entry_Call_Link; + Acceptor : Task_Id) is + begin + Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call; + Acceptor.Common.Call := Entry_Call; + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + Boost_Priority (Entry_Call, Acceptor); + end Setup_For_Rendezvous_With_Body; + + ---------------- + -- Task_Count -- + ---------------- + + function Task_Count (E : Task_Entry_Index) return Natural is + Self_Id : constant Task_Id := STPO.Self; + Return_Count : Natural; + + begin + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E)); + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + return Return_Count; + end Task_Count; + + ---------------------- + -- Task_Do_Or_Queue -- + ---------------------- + + function Task_Do_Or_Queue + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) return Boolean + is + E : constant Task_Entry_Index := + Task_Entry_Index (Entry_Call.E); + Old_State : constant Entry_Call_State := Entry_Call.State; + Acceptor : constant Task_Id := Entry_Call.Called_Task; + Parent : constant Task_Id := Acceptor.Common.Parent; + Null_Body : Boolean; + + begin + -- Find out whether Entry_Call can be accepted immediately + + -- If the Acceptor is not callable, return False. + -- If the rendezvous can start, initiate it. + -- If the accept-body is trivial, also complete the rendezvous. + -- If the acceptor is not ready, enqueue the call. + + -- This should have a special case for Accept_Call and Accept_Trivial, + -- so that we don't have the loop setup overhead, below. + + -- The call state Done is used here and elsewhere to include both the + -- case of normal successful completion, and the case of an exception + -- being raised. The difference is that if an exception is raised no one + -- will pay attention to the fact that State = Done. Instead the + -- exception will be raised in Undefer_Abort, and control will skip past + -- the place where we normally would resume from an entry call. + + pragma Assert (not Queuing.Onqueue (Entry_Call)); + + -- We rely that the call is off-queue for protection, that the caller + -- will not exit the Entry_Caller_Sleep, and so will not reuse the call + -- record for another call. We rely on the Caller's lock for call State + -- mod's. + + -- If Acceptor.Terminate_Alternative is True, we need to lock Parent and + -- Acceptor, in that order; otherwise, we only need a lock on Acceptor. + -- However, we can't check Acceptor.Terminate_Alternative until Acceptor + -- is locked. Therefore, we need to lock both. Attempts to avoid locking + -- Parent tend to result in race conditions. It would work to unlock + -- Parent immediately upon finding Acceptor.Terminate_Alternative to be + -- False, but that violates the rule of properly nested locking (see + -- System.Tasking). + + STPO.Write_Lock (Parent); + STPO.Write_Lock (Acceptor); + + -- If the acceptor is not callable, abort the call and return False + + if not Acceptor.Callable then + STPO.Unlock (Acceptor); + STPO.Unlock (Parent); + + pragma Assert (Entry_Call.State < Done); + + -- In case we are not the caller, set up the caller + -- to raise Tasking_Error when it wakes up. + + STPO.Write_Lock (Entry_Call.Self); + Entry_Call.Exception_To_Raise := Tasking_Error'Identity; + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + return False; + end if; + + -- Try to serve the call immediately + + if Acceptor.Open_Accepts /= null then + for J in Acceptor.Open_Accepts'Range loop + if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then + + -- Commit acceptor to rendezvous with us + + Acceptor.Chosen_Index := J; + Null_Body := Acceptor.Open_Accepts (J).Null_Body; + Acceptor.Open_Accepts := null; + + -- Prevent abort while call is being served + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + if Acceptor.Terminate_Alternative then + + -- Cancel terminate alternative. See matching code in + -- Selective_Wait and Vulnerable_Complete_Master. + + Acceptor.Terminate_Alternative := False; + Acceptor.Awake_Count := Acceptor.Awake_Count + 1; + + if Acceptor.Awake_Count = 1 then + + -- Notify parent that acceptor is awake + + pragma Assert (Parent.Awake_Count > 0); + + Parent.Awake_Count := Parent.Awake_Count + 1; + + if Parent.Common.State = Master_Completion_Sleep + and then Acceptor.Master_of_Task = Parent.Master_Within + then + Parent.Common.Wait_Count := + Parent.Common.Wait_Count + 1; + end if; + end if; + end if; + + if Null_Body then + + -- Rendezvous is over immediately + + STPO.Wakeup (Acceptor, Acceptor_Sleep); + STPO.Unlock (Acceptor); + STPO.Unlock (Parent); + + STPO.Write_Lock (Entry_Call.Self); + Initialization.Wakeup_Entry_Caller + (Self_ID, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + else + Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor); + + -- For terminate_alternative, acceptor may not be asleep + -- yet, so we skip the wakeup + + if Acceptor.Common.State /= Runnable then + STPO.Wakeup (Acceptor, Acceptor_Sleep); + end if; + + STPO.Unlock (Acceptor); + STPO.Unlock (Parent); + end if; + + return True; + end if; + end loop; + + -- The acceptor is accepting, but not this entry + end if; + + -- If the acceptor was ready to accept this call, + -- we would not have gotten this far, so now we should + -- (re)enqueue the call, if the mode permits that. + + -- If the call is timed, it may have timed out before the requeue, + -- in the unusual case where the current accept has taken longer than + -- the given delay. In that case the requeue is cancelled, and the + -- outer timed call will be aborted. + + if Entry_Call.Mode = Conditional_Call + or else + (Entry_Call.Mode = Timed_Call + and then Entry_Call.With_Abort + and then Entry_Call.Cancellation_Attempted) + then + STPO.Unlock (Acceptor); + STPO.Unlock (Parent); + + STPO.Write_Lock (Entry_Call.Self); + + pragma Assert (Entry_Call.State >= Was_Abortable); + + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); + STPO.Unlock (Entry_Call.Self); + + else + -- Timed_Call, Simple_Call, or Asynchronous_Call + + Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call); + + -- Update abortability of call + + pragma Assert (Old_State < Done); + + Entry_Call.State := + New_State (Entry_Call.With_Abort, Entry_Call.State); + + STPO.Unlock (Acceptor); + STPO.Unlock (Parent); + + if Old_State /= Entry_Call.State + and then Entry_Call.State = Now_Abortable + and then Entry_Call.Mode /= Simple_Call + and then Entry_Call.Self /= Self_ID + + -- Asynchronous_Call or Conditional_Call + + then + -- Because of ATCB lock ordering rule + + STPO.Write_Lock (Entry_Call.Self); + + if Entry_Call.Self.Common.State = Async_Select_Sleep then + + -- Caller may not yet have reached wait-point + + STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); + end if; + + STPO.Unlock (Entry_Call.Self); + end if; + end if; + + return True; + end Task_Do_Or_Queue; + + --------------------- + -- Task_Entry_Call -- + --------------------- + + procedure Task_Entry_Call + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with + "potentially blocking operation"; + end if; + + if Mode = Simple_Call or else Mode = Conditional_Call then + Call_Synchronous + (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful); + + else + -- This is an asynchronous call + + -- Abort must already be deferred by the compiler-generated code. + -- Without this, an abort that occurs between the time that this + -- call is made and the time that the abortable part's cleanup + -- handler is set up might miss the cleanup handler and leave the + -- call pending. + + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_Id, "TEC: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Mode; + Entry_Call.Cancellation_Attempted := False; + Entry_Call.State := Not_Yet_Abortable; + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_Task := Acceptor; + Entry_Call.Called_PO := Null_Address; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + if Single_Lock then + Lock_RTS; + end if; + + if not Task_Do_Or_Queue (Self_Id, Entry_Call) then + STPO.Write_Lock (Self_Id); + Utilities.Exit_One_ATC_Level (Self_Id); + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + raise Tasking_Error; + end if; + + -- The following is special for async. entry calls. If the call was + -- not queued abortably, we need to wait until it is before + -- proceeding with the abortable part. + + -- Wait_Until_Abortable can be called unconditionally here, but it is + -- expensive. + + if Entry_Call.State < Was_Abortable then + Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call); + end if; + + if Single_Lock then + Unlock_RTS; + end if; + + -- Note: following assignment needs to be atomic + + Rendezvous_Successful := Entry_Call.State = Done; + end if; + end Task_Entry_Call; + + ----------------------- + -- Task_Entry_Caller -- + ----------------------- + + function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + + begin + Entry_Call := Self_Id.Common.Call; + + for Depth in 1 .. D loop + Entry_Call := Entry_Call.Acceptor_Prev_Call; + pragma Assert (Entry_Call /= null); + end loop; + + return Entry_Call.Self; + end Task_Entry_Caller; + + -------------------------- + -- Timed_Selective_Wait -- + -------------------------- + + procedure Timed_Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Index : out Select_Index) + is + Self_Id : constant Task_Id := STPO.Self; + Treatment : Select_Treatment; + Entry_Call : Entry_Call_Link; + Caller : Task_Id; + Selection : Select_Index; + Open_Alternative : Boolean; + Timedout : Boolean := False; + Yielded : Boolean := True; + + begin + pragma Assert (Select_Mode = Delay_Mode); + + Initialization.Defer_Abort (Self_Id); + + -- If we are aborted here, the effect will be pending + + if Single_Lock then + Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + Uninterpreted_Data := Null_Address; + + pragma Assert (Open_Accepts /= null); + + Queuing.Select_Task_Entry_Call + (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); + + -- Determine the kind and disposition of the select + + Treatment := Default_Treatment (Select_Mode); + Self_Id.Chosen_Index := No_Rendezvous; + + if Open_Alternative then + if Entry_Call /= null then + if Open_Accepts (Selection).Null_Body then + Treatment := Accept_Alternative_Completed; + + else + Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); + Treatment := Accept_Alternative_Selected; + end if; + + Self_Id.Chosen_Index := Selection; + + elsif Treatment = No_Alternative_Open then + Treatment := Accept_Alternative_Open; + end if; + end if; + + -- Handle the select according to the disposition selected above + + case Treatment is + when Accept_Alternative_Selected => + + -- Ready to rendezvous. In this case the accept body is not + -- Null_Body. Defer abort until it gets into the accept body. + + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + Initialization.Defer_Abort_Nestable (Self_Id); + STPO.Unlock (Self_Id); + + when Accept_Alternative_Completed => + + -- Rendezvous is over + + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + when Accept_Alternative_Open => + + -- Wait for caller + + Self_Id.Open_Accepts := Open_Accepts; + + -- Wait for a normal call and a pending action until the + -- Wakeup_Time is reached. + + Self_Id.Common.State := Acceptor_Delay_Sleep; + + -- Try to remove calls to Sleep in the loop below by letting the + -- caller a chance of getting ready immediately, using Unlock + -- Yield. See similar action in Wait_For_Completion/Wait_For_Call. + + if Single_Lock then + Unlock_RTS; + else + Unlock (Self_Id); + end if; + + if Self_Id.Open_Accepts /= null then + Yield; + end if; + + if Single_Lock then + Lock_RTS; + else + Write_Lock (Self_Id); + end if; + + -- Check if this task has been aborted while the lock was released + + if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then + Self_Id.Open_Accepts := null; + end if; + + loop + exit when Self_Id.Open_Accepts = null; + + if Timedout then + Sleep (Self_Id, Acceptor_Delay_Sleep); + else + STPO.Timed_Sleep (Self_Id, Timeout, Mode, + Acceptor_Delay_Sleep, Timedout, Yielded); + end if; + + if Timedout then + Self_Id.Open_Accepts := null; + end if; + end loop; + + Self_Id.Common.State := Runnable; + + -- Self_Id.Common.Call should already be updated by the Caller if + -- not aborted. It might also be ready to do rendezvous even if + -- this wakes up due to an abort. Therefore, if the call is not + -- empty we need to do the rendezvous if the accept body is not + -- Null_Body. + + if Self_Id.Chosen_Index /= No_Rendezvous + and then Self_Id.Common.Call /= null + and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + pragma Assert (Self_Id.Deferral_Level = 1); + + Initialization.Defer_Abort_Nestable (Self_Id); + + -- Leave abort deferred until the accept body + end if; + + STPO.Unlock (Self_Id); + + when No_Alternative_Open => + + -- In this case, Index will be No_Rendezvous on return. We sleep + -- for the time we need to. + + -- Wait for a signal or timeout. A wakeup can be made + -- for several reasons: + -- 1) Delay is expired + -- 2) Pending_Action needs to be checked + -- (Abort, Priority change) + -- 3) Spurious wakeup + + Self_Id.Open_Accepts := null; + Self_Id.Common.State := Acceptor_Delay_Sleep; + + STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep, + Timedout, Yielded); + + Self_Id.Common.State := Runnable; + + STPO.Unlock (Self_Id); + + when others => + + -- Should never get here + + pragma Assert (False); + null; + end case; + + if Single_Lock then + Unlock_RTS; + end if; + + if not Yielded then + Yield; + end if; + + -- Caller has been chosen + + -- Self_Id.Common.Call should already be updated by the Caller + + -- Self_Id.Chosen_Index should either be updated by the Caller + -- or by Test_Selective_Wait + + Index := Self_Id.Chosen_Index; + Initialization.Undefer_Abort_Nestable (Self_Id); + + -- Start rendezvous, if not already completed + end Timed_Selective_Wait; + + --------------------------- + -- Timed_Task_Entry_Call -- + --------------------------- + + procedure Timed_Task_Entry_Call + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Rendezvous_Successful : out Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Level : ATC_Level; + Entry_Call : Entry_Call_Link; + + Yielded : Boolean; + pragma Unreferenced (Yielded); + + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with + "potentially blocking operation"; + end if; + + Initialization.Defer_Abort (Self_Id); + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + + pragma Debug + (Debug.Trace (Self_Id, "TTEC: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + + Level := Self_Id.ATC_Nesting_Level; + Entry_Call := Self_Id.Entry_Calls (Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Timed_Call; + Entry_Call.Cancellation_Attempted := False; + + -- If this is a call made inside of an abort deferred region, + -- the call should be never abortable. + + Entry_Call.State := + (if Self_Id.Deferral_Level > 1 + then Never_Abortable + else Now_Abortable); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_Task := Acceptor; + Entry_Call.Called_PO := Null_Address; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + -- Note: the caller will undefer abort on return (see WARNING above) + + if Single_Lock then + Lock_RTS; + end if; + + if not Task_Do_Or_Queue (Self_Id, Entry_Call) then + STPO.Write_Lock (Self_Id); + Utilities.Exit_One_ATC_Level (Self_Id); + STPO.Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + raise Tasking_Error; + end if; + + Write_Lock (Self_Id); + Entry_Calls.Wait_For_Completion_With_Timeout + (Entry_Call, Timeout, Mode, Yielded); + Unlock (Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + -- ??? Do we need to yield in case Yielded is False + + Rendezvous_Successful := Entry_Call.State = Done; + Initialization.Undefer_Abort (Self_Id); + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + end Timed_Task_Entry_Call; + + ------------------- + -- Wait_For_Call -- + ------------------- + + procedure Wait_For_Call (Self_Id : Task_Id) is + begin + Self_Id.Common.State := Acceptor_Sleep; + + -- Try to remove calls to Sleep in the loop below by letting the caller + -- a chance of getting ready immediately, using Unlock & Yield. + -- See similar action in Wait_For_Completion & Timed_Selective_Wait. + + if Single_Lock then + Unlock_RTS; + else + Unlock (Self_Id); + end if; + + if Self_Id.Open_Accepts /= null then + Yield; + end if; + + if Single_Lock then + Lock_RTS; + else + Write_Lock (Self_Id); + end if; + + -- Check if this task has been aborted while the lock was released + + if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then + Self_Id.Open_Accepts := null; + end if; + + loop + exit when Self_Id.Open_Accepts = null; + Sleep (Self_Id, Acceptor_Sleep); + end loop; + + Self_Id.Common.State := Runnable; + end Wait_For_Call; + +end System.Tasking.Rendezvous; diff --git a/gcc/ada/libgnarl/s-tasren.ads b/gcc/ada/libgnarl/s-tasren.ads new file mode 100644 index 00000000000..3deb4e5bf6b --- /dev/null +++ b/gcc/ada/libgnarl/s-tasren.ads @@ -0,0 +1,330 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E N D E Z V O U 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +with Ada.Exceptions; + +with System.Tasking.Protected_Objects.Entries; + +package System.Tasking.Rendezvous is + + package STPE renames System.Tasking.Protected_Objects.Entries; + + procedure Task_Entry_Call + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean); + -- General entry call used to implement ATC or conditional entry calls. + -- Compiler interface only. Do not call from within the RTS. + -- Acceptor is the ID of the acceptor task. + -- E is the entry index requested. + -- Uninterpreted_Data represents the parameters of the entry. It is + -- constructed by the compiler for the caller and the callee; therefore, + -- the run time never needs to decode this data. + -- Mode can be either Asynchronous_Call (ATC) or Conditional_Call. + -- Rendezvous_Successful is set to True on return if the call was serviced. + + procedure Timed_Task_Entry_Call + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Rendezvous_Successful : out Boolean); + -- Timed entry call without using ATC. + -- Compiler interface only. Do not call from within the RTS. + -- See Task_Entry_Call for details on Acceptor, E and Uninterpreted_Data. + -- Timeout is the value of the time out. + -- Mode determines whether the delay is relative or absolute. + + procedure Call_Simple + (Acceptor : Task_Id; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address); + -- Simple entry call. + -- Compiler interface only. Do not call from within the RTS. + -- + -- source: + -- T.E1 (Params); + -- + -- expansion: + -- declare + -- P : parms := (parm1, parm2, parm3); + -- X : Task_Entry_Index := 1; + -- begin + -- Call_Simple (t._task_id, X, P'Address); + -- parm1 := P.param1; + -- parm2 := P.param2; + -- ... + -- end; + + procedure Cancel_Task_Entry_Call (Cancelled : out Boolean); + -- Cancel pending asynchronous task entry call. + -- Compiler interface only. Do not call from within the RTS. + -- See Exp_Ch9.Expand_N_Asynchronous_Select for code expansion. + + procedure Requeue_Task_Entry + (Acceptor : Task_Id; + E : Task_Entry_Index; + With_Abort : Boolean); + -- Requeue from a task entry to a task entry. + -- Compiler interface only. Do not call from within the RTS. + -- The code generation for task entry requeues is different from that for + -- protected entry requeues. There is a "goto" that skips around the call + -- to Complete_Rendezvous, so that Requeue_Task_Entry must also do the work + -- of Complete_Rendezvous. The difference is that it does not report that + -- the call's State = Done. + -- + -- source: + -- accept e1 do + -- ...A... + -- requeue e2; + -- ...B... + -- end e1; + -- + -- expansion: + -- A62b : address; + -- L61b : label + -- begin + -- accept_call (1, A62b); + -- ...A... + -- requeue_task_entry (tTV!(t)._task_id, 2, false); + -- goto L61b; + -- ...B... + -- complete_rendezvous; + -- <> + -- exception + -- when others => + -- exceptional_complete_rendezvous (current_exception); + -- end; + + procedure Requeue_Protected_To_Task_Entry + (Object : STPE.Protection_Entries_Access; + Acceptor : Task_Id; + E : Task_Entry_Index; + With_Abort : Boolean); + -- Requeue from a protected entry to a task entry. + -- Compiler interface only. Do not call from within the RTS. + -- + -- source: + -- entry e2 when b is + -- begin + -- b := false; + -- ...A... + -- requeue t.e2; + -- end e2; + -- + -- expansion: + -- procedure rPT__E14b (O : address; P : address; E : + -- protected_entry_index) is + -- type rTVP is access rTV; + -- freeze rTVP [] + -- _object : rTVP := rTVP!(O); + -- begin + -- declare + -- rR : protection renames _object._object; + -- vP : integer renames _object.v; + -- bP : boolean renames _object.b; + -- begin + -- b := false; + -- ...A... + -- requeue_protected_to_task_entry (rR'unchecked_access, tTV!(t). + -- _task_id, 2, false); + -- return; + -- end; + -- complete_entry_body (_object._object'unchecked_access, objectF => + -- 0); + -- return; + -- exception + -- when others => + -- abort_undefer.all; + -- exceptional_complete_entry_body (_object._object' + -- unchecked_access, current_exception, objectF => 0); + -- return; + -- end rPT__E14b; + + procedure Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Index : out Select_Index); + -- Implement select statement. + -- Compiler interface only. Do not call from within the RTS. + -- See comments on Accept_Call. + -- + -- source: + -- select accept e1 do + -- ...A... + -- end e1; + -- ...B... + -- or accept e2; + -- ...C... + -- end select; + -- + -- expansion: + -- A32b : address; + -- declare + -- A37b : T36b; + -- A37b (1) := (null_body => false, s => 1); + -- A37b (2) := (null_body => true, s => 2); + -- S0 : aliased T36b := accept_list'A37b; + -- J1 : select_index := 0; + -- procedure e1A is + -- begin + -- abort_undefer.all; + -- ...A... + -- <> + -- complete_rendezvous; + -- exception + -- when all others => + -- exceptional_complete_rendezvous (get_gnat_exception); + -- end e1A; + -- begin + -- selective_wait (S0'unchecked_access, simple_mode, A32b, J1); + -- case J1 is + -- when 0 => + -- goto L3; + -- when 1 => + -- e1A; + -- goto L1; + -- when 2 => + -- goto L2; + -- when others => + -- goto L3; + -- end case; + -- <> + -- ...B... + -- goto L3; + -- <> + -- ...C... + -- goto L3; + -- <> + -- end; + + procedure Timed_Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Index : out Select_Index); + -- Selective wait with timeout without using ATC. + -- Compiler interface only. Do not call from within the RTS. + + procedure Accept_Call + (E : Task_Entry_Index; + Uninterpreted_Data : out System.Address); + -- Accept an entry call. + -- Compiler interface only. Do not call from within the RTS. + -- + -- source: + -- accept E do ...A... end E; + -- expansion: + -- A27b : address; + -- L26b : label + -- begin + -- accept_call (1, A27b); + -- ...A... + -- complete_rendezvous; + -- <> + -- exception + -- when all others => + -- exceptional_complete_rendezvous (get_gnat_exception); + -- end; + -- + -- The handler for Abort_Signal (*all* others) is to handle the case when + -- the acceptor is aborted between Accept_Call and the corresponding + -- Complete_Rendezvous call. We need to wake up the caller in this case. + -- + -- See also Selective_Wait + + procedure Accept_Trivial (E : Task_Entry_Index); + -- Accept an entry call that has no parameters and no body. + -- Compiler interface only. Do not call from within the RTS. + -- This should only be called when there is no accept body, or the accept + -- body is empty. + -- + -- source: + -- accept E; + -- expansion: + -- accept_trivial (1); + -- + -- The compiler is also able to recognize the following and + -- translate it the same way. + -- + -- accept E do null; end E; + + function Task_Count (E : Task_Entry_Index) return Natural; + -- Return number of tasks waiting on the entry E (of current task) + -- Compiler interface only. Do not call from within the RTS. + + function Callable (T : Task_Id) return Boolean; + -- Return T'Callable + -- Compiler interface. Do not call from within the RTS, except for body of + -- Ada.Task_Identification. + + type Task_Entry_Nesting_Depth is new Task_Entry_Index + range 0 .. Max_Task_Entry; + + function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id; + -- Return E'Caller. This will only work if called from within an + -- accept statement that is handling E, as required by the LRM (C.7.1(14)). + -- Compiler interface only. Do not call from within the RTS. + + procedure Complete_Rendezvous; + -- Called by acceptor to wake up caller + + procedure Exceptional_Complete_Rendezvous + (Ex : Ada.Exceptions.Exception_Id); + pragma No_Return (Exceptional_Complete_Rendezvous); + -- Called by acceptor to mark the end of the current rendezvous and + -- propagate an exception to the caller. + + -- For internal use only: + + function Task_Do_Or_Queue + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) return Boolean; + -- Call this only with abort deferred and holding no locks, except + -- the global RTS lock when Single_Lock is True which must be owned. + -- Returns False iff the call cannot be served or queued, as is the + -- case if the caller is not callable; i.e., a False return value + -- indicates that Tasking_Error should be raised. + -- Either initiate the entry call, such that the accepting task is + -- free to execute the rendezvous, queue the call on the acceptor's + -- queue, or cancel the call. Conditional calls that cannot be + -- accepted immediately are cancelled. + +end System.Tasking.Rendezvous; diff --git a/gcc/ada/libgnarl/s-tasres.ads b/gcc/ada/libgnarl/s-tasres.ads new file mode 100644 index 00000000000..df606455aab --- /dev/null +++ b/gcc/ada/libgnarl/s-tasres.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E S T R I C T E D -- +-- -- +-- 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 parent package of the GNAT restricted tasking run time + +package System.Tasking.Restricted is +end System.Tasking.Restricted; diff --git a/gcc/ada/libgnarl/s-tassta.adb b/gcc/ada/libgnarl/s-tassta.adb new file mode 100644 index 00000000000..346e5bfe142 --- /dev/null +++ b/gcc/ada/libgnarl/s-tassta.adb @@ -0,0 +1,2128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . S T A G E 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. -- +-- -- +------------------------------------------------------------------------------ + +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. + +pragma Partition_Elaboration_Policy (Concurrent); +-- This package only implements the concurrent elaboration policy. This pragma +-- will enforce it (and detect conflicts with user specified policy). + +with Ada.Exceptions; +with Ada.Unchecked_Deallocation; + +with System.Interrupt_Management; +with System.Tasking.Debug; +with System.Address_Image; +with System.Task_Primitives; +with System.Task_Primitives.Operations; +with System.Tasking.Utilities; +with System.Tasking.Queuing; +with System.Tasking.Rendezvous; +with System.OS_Primitives; +with System.Secondary_Stack; +with System.Restrictions; +with System.Standard_Library; +with System.Stack_Usage; +with System.Storage_Elements; + +with System.Soft_Links; +-- These are procedure pointers to non-tasking routines that use task +-- specific data. In the absence of tasking, these routines refer to global +-- data. In the presence of tasking, they must be replaced with pointers to +-- task-specific versions. Also used for Create_TSD, Destroy_TSD, Get_Current +-- _Excep, Finalize_Library_Objects, Task_Termination, Handler. + +with System.Tasking.Initialization; +pragma Elaborate_All (System.Tasking.Initialization); +-- This insures that tasking is initialized if any tasks are created + +package body System.Tasking.Stages is + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + package SSE renames System.Storage_Elements; + package SST renames System.Secondary_Stack; + + use Ada.Exceptions; + + use Parameters; + use Task_Primitives; + use Task_Primitives.Operations; + use Task_Info; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id); + -- This procedure outputs the task specific message for exception + -- tracing purposes. + + procedure Task_Wrapper (Self_ID : Task_Id); + pragma Convention (C, Task_Wrapper); + -- This is the procedure that is called by the GNULL from the new context + -- when a task is created. It waits for activation and then calls the task + -- body procedure. When the task body procedure completes, it terminates + -- the task. + -- + -- The Task_Wrapper's address will be provided to the underlying threads + -- library as the task entry point. Convention C is what makes most sense + -- for that purpose (Export C would make the function globally visible, + -- and affect the link name on which GDB depends). This will in addition + -- trigger an automatic stack alignment suitable for GCC's assumptions if + -- need be. + + -- "Vulnerable_..." in the procedure names below means they must be called + -- with abort deferred. + + procedure Vulnerable_Complete_Task (Self_ID : Task_Id); + -- Complete the calling task. This procedure must be called with + -- abort deferred. It should only be called by Complete_Task and + -- Finalize_Global_Tasks (for the environment task). + + procedure Vulnerable_Complete_Master (Self_ID : Task_Id); + -- Complete the current master of the calling task. This procedure + -- must be called with abort deferred. It should only be called by + -- Vulnerable_Complete_Task and Complete_Master. + + procedure Vulnerable_Complete_Activation (Self_ID : Task_Id); + -- Signal to Self_ID's activator that Self_ID has completed activation. + -- This procedure must be called with abort deferred. + + procedure Abort_Dependents (Self_ID : Task_Id); + -- Abort all the direct dependents of Self at its current master nesting + -- level, plus all of their dependents, transitively. RTS_Lock should be + -- locked by the caller. + + procedure Vulnerable_Free_Task (T : Task_Id); + -- Recover all runtime system storage associated with the task T. This + -- should only be called after T has terminated and will no longer be + -- referenced. + -- + -- For tasks created by an allocator that fails, due to an exception, it is + -- called from Expunge_Unactivated_Tasks. + -- + -- Different code is used at master completion, in Terminate_Dependents, + -- due to a need for tighter synchronization with the master. + + ---------------------- + -- Abort_Dependents -- + ---------------------- + + procedure Abort_Dependents (Self_ID : Task_Id) is + C : Task_Id; + P : Task_Id; + + -- Each task C will take care of its own dependents, so there is no + -- need to worry about them here. In fact, it would be wrong to abort + -- indirect dependents here, because we can't distinguish between + -- duplicate master ids. For example, suppose we have three nested + -- task bodies T1,T2,T3. And suppose T1 also calls P which calls Q (and + -- both P and Q are task masters). Q will have the same master id as + -- Master_of_Task of T3. Previous versions of this would abort T3 when + -- Q calls Complete_Master, which was completely wrong. + + begin + C := All_Tasks_List; + while C /= null loop + P := C.Common.Parent; + + if P = Self_ID then + if C.Master_of_Task = Self_ID.Master_Within then + pragma Debug + (Debug.Trace (Self_ID, "Aborting", 'X', C)); + Utilities.Abort_One_Task (Self_ID, C); + C.Dependents_Aborted := True; + end if; + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Self_ID.Dependents_Aborted := True; + end Abort_Dependents; + + ----------------- + -- Abort_Tasks -- + ----------------- + + procedure Abort_Tasks (Tasks : Task_List) is + begin + Utilities.Abort_Tasks (Tasks); + end Abort_Tasks; + + -------------------- + -- Activate_Tasks -- + -------------------- + + -- Note that locks of activator and activated task are both locked here. + -- This is necessary because C.Common.State and Self.Common.Wait_Count have + -- to be synchronized. This is safe from deadlock because the activator is + -- always created before the activated task. That satisfies our + -- in-order-of-creation ATCB locking policy. + + -- At one point, we may also lock the parent, if the parent is different + -- from the activator. That is also consistent with the lock ordering + -- policy, since the activator cannot be created before the parent. + + -- Since we are holding both the activator's lock, and Task_Wrapper locks + -- that before it does anything more than initialize the low-level ATCB + -- components, it should be safe to wait to update the counts until we see + -- that the thread creation is successful. + + -- If the thread creation fails, we do need to close the entries of the + -- task. The first phase, of dequeuing calls, only requires locking the + -- acceptor's ATCB, but the waking up of the callers requires locking the + -- caller's ATCB. We cannot safely do this while we are holding other + -- locks. Therefore, the queue-clearing operation is done in a separate + -- pass over the activation chain. + + procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is + Self_ID : constant Task_Id := STPO.Self; + P : Task_Id; + C : Task_Id; + Next_C, Last_C : Task_Id; + Activate_Prio : System.Any_Priority; + Success : Boolean; + All_Elaborated : Boolean := True; + + begin + -- If pragma Detect_Blocking is active, then we must check whether this + -- potentially blocking operation is called from a protected action. + + if System.Tasking.Detect_Blocking + and then Self_ID.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + pragma Debug + (Debug.Trace (Self_ID, "Activate_Tasks", 'C')); + + Initialization.Defer_Abort_Nestable (Self_ID); + + pragma Assert (Self_ID.Common.Wait_Count = 0); + + -- Lock RTS_Lock, to prevent activated tasks from racing ahead before + -- we finish activating the chain. + + Lock_RTS; + + -- Check that all task bodies have been elaborated + + C := Chain_Access.T_ID; + Last_C := null; + while C /= null loop + if C.Common.Elaborated /= null + and then not C.Common.Elaborated.all + then + All_Elaborated := False; + end if; + + -- Reverse the activation chain so that tasks are activated in the + -- same order they're declared. + + Next_C := C.Common.Activation_Link; + C.Common.Activation_Link := Last_C; + Last_C := C; + C := Next_C; + end loop; + + Chain_Access.T_ID := Last_C; + + if not All_Elaborated then + Unlock_RTS; + Initialization.Undefer_Abort_Nestable (Self_ID); + raise Program_Error with "Some tasks have not been elaborated"; + end if; + + -- Activate all the tasks in the chain. Creation of the thread of + -- control was deferred until activation. So create it now. + + C := Chain_Access.T_ID; + while C /= null loop + if C.Common.State /= Terminated then + pragma Assert (C.Common.State = Unactivated); + + P := C.Common.Parent; + Write_Lock (P); + Write_Lock (C); + + Activate_Prio := + (if C.Common.Base_Priority < Get_Priority (Self_ID) + then Get_Priority (Self_ID) + else C.Common.Base_Priority); + + System.Task_Primitives.Operations.Create_Task + (C, Task_Wrapper'Address, + Parameters.Size_Type + (C.Common.Compiler_Data.Pri_Stack_Info.Size), + Activate_Prio, Success); + + -- There would be a race between the created task and the creator + -- to do the following initialization, if we did not have a + -- Lock/Unlock_RTS pair in the task wrapper to prevent it from + -- racing ahead. + + if Success then + C.Common.State := Activating; + C.Awake_Count := 1; + C.Alive_Count := 1; + P.Awake_Count := P.Awake_Count + 1; + P.Alive_Count := P.Alive_Count + 1; + + if P.Common.State = Master_Completion_Sleep and then + C.Master_of_Task = P.Master_Within + then + pragma Assert (Self_ID /= P); + P.Common.Wait_Count := P.Common.Wait_Count + 1; + end if; + + for J in System.Tasking.Debug.Known_Tasks'Range loop + if System.Tasking.Debug.Known_Tasks (J) = null then + System.Tasking.Debug.Known_Tasks (J) := C; + C.Known_Tasks_Index := J; + exit; + end if; + end loop; + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Activating, C); + end if; + + C.Common.State := Runnable; + + Unlock (C); + Unlock (P); + + else + -- No need to set Awake_Count, State, etc. here since the loop + -- below will do that for any Unactivated tasks. + + Unlock (C); + Unlock (P); + Self_ID.Common.Activation_Failed := True; + end if; + end if; + + C := C.Common.Activation_Link; + end loop; + + if not Single_Lock then + Unlock_RTS; + end if; + + -- Close the entries of any tasks that failed thread creation, and count + -- those that have not finished activation. + + Write_Lock (Self_ID); + Self_ID.Common.State := Activator_Sleep; + + C := Chain_Access.T_ID; + while C /= null loop + Write_Lock (C); + + if C.Common.State = Unactivated then + C.Common.Activator := null; + C.Common.State := Terminated; + C.Callable := False; + Utilities.Cancel_Queued_Entry_Calls (C); + + elsif C.Common.Activator /= null then + Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; + end if; + + Unlock (C); + P := C.Common.Activation_Link; + C.Common.Activation_Link := null; + C := P; + end loop; + + -- Wait for the activated tasks to complete activation. It is + -- unsafe to abort any of these tasks until the count goes to zero. + + loop + exit when Self_ID.Common.Wait_Count = 0; + Sleep (Self_ID, Activator_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Remove the tasks from the chain + + Chain_Access.T_ID := null; + Initialization.Undefer_Abort_Nestable (Self_ID); + + if Self_ID.Common.Activation_Failed then + Self_ID.Common.Activation_Failed := False; + raise Tasking_Error with "Failure during activation"; + end if; + end Activate_Tasks; + + ------------------------- + -- Complete_Activation -- + ------------------------- + + procedure Complete_Activation is + Self_ID : constant Task_Id := STPO.Self; + + begin + Initialization.Defer_Abort_Nestable (Self_ID); + + if Single_Lock then + Lock_RTS; + end if; + + Vulnerable_Complete_Activation (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort_Nestable (Self_ID); + + -- ??? Why do we need to allow for nested deferral here? + + end Complete_Activation; + + --------------------- + -- Complete_Master -- + --------------------- + + procedure Complete_Master is + Self_ID : constant Task_Id := STPO.Self; + begin + pragma Assert + (Self_ID.Deferral_Level > 0 + or else not System.Restrictions.Abort_Allowed); + Vulnerable_Complete_Master (Self_ID); + end Complete_Master; + + ------------------- + -- Complete_Task -- + ------------------- + + -- See comments on Vulnerable_Complete_Task for details + + procedure Complete_Task is + Self_ID : constant Task_Id := STPO.Self; + + begin + pragma Assert + (Self_ID.Deferral_Level > 0 + or else not System.Restrictions.Abort_Allowed); + + Vulnerable_Complete_Task (Self_ID); + + -- All of our dependents have terminated, never undefer abort again + + end Complete_Task; + + ----------------- + -- Create_Task -- + ----------------- + + -- Compiler interface only. Do not call from within the RTS. This must be + -- called to create a new task. + + procedure Create_Task + (Priority : Integer; + Size : System.Parameters.Size_Type; + Secondary_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + Relative_Deadline : Ada.Real_Time.Time_Span; + Domain : Dispatching_Domain_Access; + Num_Entries : Task_Entry_Index; + Master : Master_Level; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : String; + Created_Task : out Task_Id) + is + T, P : Task_Id; + Self_ID : constant Task_Id := STPO.Self; + Success : Boolean; + Base_Priority : System.Any_Priority; + Len : Natural; + Base_CPU : System.Multiprocessors.CPU_Range; + + use type System.Multiprocessors.CPU_Range; + + pragma Unreferenced (Relative_Deadline); + -- EDF scheduling is not supported by any of the target platforms so + -- this parameter is not passed any further. + + begin + -- If Master is greater than the current master, it means that Master + -- has already awaited its dependent tasks. This raises Program_Error, + -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads. + + if Self_ID.Master_of_Task /= Foreign_Task_Level + and then Master > Self_ID.Master_Within + then + raise Program_Error with + "create task after awaiting termination"; + end if; + + -- If pragma Detect_Blocking is active must be checked whether this + -- potentially blocking operation is called from a protected action. + + if System.Tasking.Detect_Blocking + and then Self_ID.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + pragma Debug (Debug.Trace (Self_ID, "Create_Task", 'C')); + + Base_Priority := + (if Priority = Unspecified_Priority + then Self_ID.Common.Base_Priority + else System.Any_Priority (Priority)); + + -- Legal values of CPU are the special Unspecified_CPU value which is + -- inserted by the compiler for tasks without CPU aspect, and those in + -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise + -- the task is defined to have failed, and it becomes a completed task + -- (RM D.16(14/3)). + + if CPU /= Unspecified_CPU + and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) + or else + CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) + then + raise Tasking_Error with "CPU not in range"; + + -- Normal CPU affinity + + else + -- When the application code says nothing about the task affinity + -- (task without CPU aspect) then the compiler inserts the value + -- Unspecified_CPU which indicates to the run-time library that + -- the task will activate and execute on the same processor as its + -- activating task if the activating task is assigned a processor + -- (RM D.16(14/3)). + + Base_CPU := + (if CPU = Unspecified_CPU + then Self_ID.Common.Base_CPU + else System.Multiprocessors.CPU_Range (CPU)); + end if; + + -- Find parent P of new Task, via master level number. Independent + -- tasks should have Parent = Environment_Task, and all tasks created + -- by independent tasks are also independent. See, for example, + -- s-interr.adb, where Interrupt_Manager does "new Server_Task". The + -- access type is at library level, so the parent of the Server_Task + -- is Environment_Task. + + P := Self_ID; + + if P.Master_of_Task <= Independent_Task_Level then + P := Environment_Task; + else + while P /= null and then P.Master_of_Task >= Master loop + P := P.Common.Parent; + end loop; + end if; + + Initialization.Defer_Abort_Nestable (Self_ID); + + begin + T := New_ATCB (Num_Entries); + exception + when others => + Initialization.Undefer_Abort_Nestable (Self_ID); + raise Storage_Error with "Cannot allocate task"; + end; + + -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. Up to this + -- point, it is possible that we may be part of a family of tasks that + -- is being aborted. + + Lock_RTS; + Write_Lock (Self_ID); + + -- Now, we must check that we have not been aborted. If so, we should + -- give up on creating this task, and simply return. + + if not Self_ID.Callable then + pragma Assert (Self_ID.Pending_ATC_Level = 0); + pragma Assert (Self_ID.Pending_Action); + pragma Assert + (Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated); + + Unlock (Self_ID); + Unlock_RTS; + Initialization.Undefer_Abort_Nestable (Self_ID); + + -- ??? Should never get here + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated, + Base_Priority, Base_CPU, Domain, Task_Info, Size, + Secondary_Stack_Size, T, Success); + + if not Success then + Free (T); + Unlock (Self_ID); + Unlock_RTS; + Initialization.Undefer_Abort_Nestable (Self_ID); + raise Storage_Error with "Failed to initialize task"; + end if; + + if Master = Foreign_Task_Level + 2 then + + -- This should not happen, except when a foreign task creates non + -- library-level Ada tasks. In this case, we pretend the master is + -- a regular library level task, otherwise the run-time will get + -- confused when waiting for these tasks to terminate. + + T.Master_of_Task := Library_Task_Level; + + else + T.Master_of_Task := Master; + end if; + + T.Master_Within := T.Master_of_Task + 1; + + for L in T.Entry_Calls'Range loop + T.Entry_Calls (L).Self := T; + T.Entry_Calls (L).Level := L; + end loop; + + if Task_Image'Length = 0 then + T.Common.Task_Image_Len := 0; + else + Len := 1; + T.Common.Task_Image (1) := Task_Image (Task_Image'First); + + -- Remove unwanted blank space generated by 'Image + + for J in Task_Image'First + 1 .. Task_Image'Last loop + if Task_Image (J) /= ' ' + or else Task_Image (J - 1) /= '(' + then + Len := Len + 1; + T.Common.Task_Image (Len) := Task_Image (J); + exit when Len = T.Common.Task_Image'Last; + end if; + end loop; + + T.Common.Task_Image_Len := Len; + end if; + + -- Note: we used to have code here to initialize T.Commmon.Domain, but + -- that is not needed, since this is initialized in System.Tasking. + + Unlock (Self_ID); + Unlock_RTS; + + -- The CPU associated to the task (if any) must belong to the + -- dispatching domain. + + if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU + and then + (Base_CPU not in T.Common.Domain'Range + or else not T.Common.Domain (Base_CPU)) + then + Initialization.Undefer_Abort_Nestable (Self_ID); + raise Tasking_Error with "CPU not in dispatching domain"; + end if; + + -- To handle the interaction between pragma CPU and dispatching domains + -- we need to signal that this task is being allocated to a processor. + -- This is needed only for tasks belonging to the system domain (the + -- creation of new dispatching domains can only take processors from the + -- system domain) and only before the environment task calls the main + -- procedure (dispatching domains cannot be created after this). + + if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU + and then T.Common.Domain = System.Tasking.System_Domain + and then not System.Tasking.Dispatching_Domains_Frozen + then + -- Increase the number of tasks attached to the CPU to which this + -- task is being moved. + + Dispatching_Domain_Tasks (Base_CPU) := + Dispatching_Domain_Tasks (Base_CPU) + 1; + end if; + + -- Create TSD as early as possible in the creation of a task, since it + -- may be used by the operation of Ada code within the task. + + SSL.Create_TSD (T.Common.Compiler_Data); + T.Common.Activation_Link := Chain.T_ID; + Chain.T_ID := T; + Created_Task := T; + Initialization.Undefer_Abort_Nestable (Self_ID); + + pragma Debug + (Debug.Trace + (Self_ID, "Created task in " & T.Master_of_Task'Img, 'C', T)); + end Create_Task; + + -------------------- + -- Current_Master -- + -------------------- + + function Current_Master return Master_Level is + begin + return STPO.Self.Master_Within; + end Current_Master; + + ------------------ + -- Enter_Master -- + ------------------ + + procedure Enter_Master is + Self_ID : constant Task_Id := STPO.Self; + begin + Self_ID.Master_Within := Self_ID.Master_Within + 1; + pragma Debug + (Debug.Trace + (Self_ID, "Enter_Master ->" & Self_ID.Master_Within'Img, 'M')); + end Enter_Master; + + ------------------------------- + -- Expunge_Unactivated_Tasks -- + ------------------------------- + + -- See procedure Close_Entries for the general case + + procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is + Self_ID : constant Task_Id := STPO.Self; + C : Task_Id; + Call : Entry_Call_Link; + Temp : Task_Id; + + begin + pragma Debug + (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C')); + + Initialization.Defer_Abort_Nestable (Self_ID); + + -- ??? + -- Experimentation has shown that abort is sometimes (but not always) + -- already deferred when this is called. + + -- That may indicate an error. Find out what is going on + + C := Chain.T_ID; + while C /= null loop + pragma Assert (C.Common.State = Unactivated); + + Temp := C.Common.Activation_Link; + + if C.Common.State = Unactivated then + Lock_RTS; + Write_Lock (C); + + for J in 1 .. C.Entry_Num loop + Queuing.Dequeue_Head (C.Entry_Queues (J), Call); + pragma Assert (Call = null); + end loop; + + Unlock (C); + + Initialization.Remove_From_All_Tasks_List (C); + Unlock_RTS; + + Vulnerable_Free_Task (C); + C := Temp; + end if; + end loop; + + Chain.T_ID := null; + Initialization.Undefer_Abort_Nestable (Self_ID); + end Expunge_Unactivated_Tasks; + + --------------------------- + -- Finalize_Global_Tasks -- + --------------------------- + + -- ??? + -- We have a potential problem here if finalization of global objects does + -- anything with signals or the timer server, since by that time those + -- servers have terminated. + + -- It is hard to see how that would occur + + -- However, a better solution might be to do all this finalization + -- using the global finalization chain. + + procedure Finalize_Global_Tasks is + Self_ID : constant Task_Id := STPO.Self; + + Ignore_1 : Boolean; + Ignore_2 : Boolean; + + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state for interrupt number Int. Defined in init.c + + Default : constant Character := 's'; + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + + begin + if Self_ID.Deferral_Level = 0 then + -- ??? + -- In principle, we should be able to predict whether abort is + -- already deferred here (and it should not be deferred yet but in + -- practice it seems Finalize_Global_Tasks is being called sometimes, + -- from RTS code for exceptions, with abort already deferred. + + Initialization.Defer_Abort_Nestable (Self_ID); + + -- Never undefer again + end if; + + -- This code is only executed by the environment task + + pragma Assert (Self_ID = Environment_Task); + + -- Set Environment_Task'Callable to false to notify library-level tasks + -- that it is waiting for them. + + Self_ID.Callable := False; + + -- Exit level 2 master, for normal tasks in library-level packages + + Complete_Master; + + -- Force termination of "independent" library-level server tasks + + Lock_RTS; + + Abort_Dependents (Self_ID); + + if not Single_Lock then + Unlock_RTS; + end if; + + -- We need to explicitly wait for the task to be terminated here + -- because on true concurrent system, we may end this procedure before + -- the tasks are really terminated. + + Write_Lock (Self_ID); + + -- If the Abort_Task signal is set to system, it means that we may + -- not have been able to abort all independent tasks (in particular, + -- Server_Task may be blocked, waiting for a signal), in which case, do + -- not wait for Independent_Task_Count to go down to 0. We arbitrarily + -- limit the number of loop iterations; if an independent task does not + -- terminate, we do not want to hang here. In that case, the thread will + -- be terminated when the process exits. + + if State (System.Interrupt_Management.Abort_Task_Interrupt) /= Default + then + for J in 1 .. 10 loop + exit when Utilities.Independent_Task_Count = 0; + + -- We used to yield here, but this did not take into account low + -- priority tasks that would cause dead lock in some cases (true + -- FIFO scheduling). + + Timed_Sleep + (Self_ID, 0.01, System.OS_Primitives.Relative, + Self_ID.Common.State, Ignore_1, Ignore_2); + end loop; + end if; + + -- ??? On multi-processor environments, it seems that the above loop + -- isn't sufficient, so we need to add an additional delay. + + Timed_Sleep + (Self_ID, 0.01, System.OS_Primitives.Relative, + Self_ID.Common.State, Ignore_1, Ignore_2); + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Complete the environment task + + Vulnerable_Complete_Task (Self_ID); + + -- Handle normal task termination by the environment task, but only + -- for the normal task termination. In the case of Abnormal and + -- Unhandled_Exception they must have been handled before, and the + -- task termination soft link must have been changed so the task + -- termination routine is not executed twice. + + SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence); + + -- Finalize all library-level controlled objects + + if not SSL."=" (SSL.Finalize_Library_Objects, null) then + SSL.Finalize_Library_Objects.all; + end if; + + -- Reset the soft links to non-tasking + + SSL.Abort_Defer := SSL.Abort_Defer_NT'Access; + SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access; + SSL.Lock_Task := SSL.Task_Lock_NT'Access; + SSL.Unlock_Task := SSL.Task_Unlock_NT'Access; + SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access; + SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access; + SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access; + SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access; + SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access; + SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access; + + -- Don't bother trying to finalize Initialization.Global_Task_Lock + -- and System.Task_Primitives.RTS_Lock. + + end Finalize_Global_Tasks; + + --------------- + -- Free_Task -- + --------------- + + procedure Free_Task (T : Task_Id) is + Self_Id : constant Task_Id := Self; + + begin + if T.Common.State = Terminated then + + -- It is not safe to call Abort_Defer or Write_Lock at this stage + + Initialization.Task_Lock (Self_Id); + + Lock_RTS; + Initialization.Finalize_Attributes (T); + Initialization.Remove_From_All_Tasks_List (T); + Unlock_RTS; + + Initialization.Task_Unlock (Self_Id); + + System.Task_Primitives.Operations.Finalize_TCB (T); + + else + -- If the task is not terminated, then mark the task as to be freed + -- upon termination. + + T.Free_On_Termination := True; + end if; + end Free_Task; + + --------------------------- + -- Move_Activation_Chain -- + --------------------------- + + procedure Move_Activation_Chain + (From, To : Activation_Chain_Access; + New_Master : Master_ID) + is + Self_ID : constant Task_Id := STPO.Self; + C : Task_Id; + + begin + pragma Debug + (Debug.Trace (Self_ID, "Move_Activation_Chain", 'C')); + + -- Nothing to do if From is empty, and we can check that without + -- deferring aborts. + + C := From.all.T_ID; + + if C = null then + return; + end if; + + Initialization.Defer_Abort_Nestable (Self_ID); + + -- Loop through the From chain, changing their Master_of_Task fields, + -- and to find the end of the chain. + + loop + C.Master_of_Task := New_Master; + exit when C.Common.Activation_Link = null; + C := C.Common.Activation_Link; + end loop; + + -- Hook From in at the start of To + + C.Common.Activation_Link := To.all.T_ID; + To.all.T_ID := From.all.T_ID; + + -- Set From to empty + + From.all.T_ID := null; + + Initialization.Undefer_Abort_Nestable (Self_ID); + end Move_Activation_Chain; + + ------------------ + -- Task_Wrapper -- + ------------------ + + -- The task wrapper is a procedure that is called first for each task body + -- and which in turn calls the compiler-generated task body procedure. + -- The wrapper's main job is to do initialization for the task. It also + -- has some locally declared objects that serve as per-task local data. + -- Task finalization is done by Complete_Task, which is called from an + -- at-end handler that the compiler generates. + + procedure Task_Wrapper (Self_ID : Task_Id) is + use type SSE.Storage_Offset; + use System.Standard_Library; + use System.Stack_Usage; + + Bottom_Of_Stack : aliased Integer; + + Task_Alternate_Stack : + aliased SSE.Storage_Array (1 .. Alternate_Stack_Size); + -- The alternate signal stack for this task, if any + + Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; + -- Whether to use above alternate signal stack for stack overflows + + function Secondary_Stack_Size return Storage_Elements.Storage_Offset; + -- Returns the size of the secondary stack for the task. For fixed + -- secondary stacks, the function will return the ATCB field + -- Secondary_Stack_Size if it is not set to Unspecified_Size, + -- otherwise a percentage of the stack is reserved using the + -- System.Parameters.Sec_Stack_Percentage property. + + -- Dynamic secondary stacks are allocated in System.Soft_Links. + -- Create_TSD and thus the function returns 0 to suppress the + -- creation of the fixed secondary stack in the primary stack. + + -------------------------- + -- Secondary_Stack_Size -- + -------------------------- + + function Secondary_Stack_Size return Storage_Elements.Storage_Offset is + use System.Storage_Elements; + use System.Secondary_Stack; + + begin + if Parameters.Sec_Stack_Dynamic then + return 0; + + elsif Self_ID.Common.Secondary_Stack_Size = Unspecified_Size then + return (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size + * SSE.Storage_Offset (Sec_Stack_Percentage) / 100); + else + -- Use the size specified by aspect Secondary_Stack_Size padded + -- by the amount of space used by the stack data structure. + + return Storage_Offset (Self_ID.Common.Secondary_Stack_Size) + + Storage_Offset (SST.Minimum_Secondary_Stack_Size); + end if; + end Secondary_Stack_Size; + + Secondary_Stack : aliased Storage_Elements.Storage_Array + (1 .. Secondary_Stack_Size); + for Secondary_Stack'Alignment use Standard'Maximum_Alignment; + -- Actual area allocated for secondary stack. Note that it is critical + -- that this have maximum alignment, since any kind of data can be + -- allocated here. + + Secondary_Stack_Address : System.Address := Secondary_Stack'Address; + -- Address of secondary stack. In the fixed secondary stack case, this + -- value is not modified, causing a warning, hence the bracketing with + -- Warnings (Off/On). But why is so much *more* bracketed??? + + SEH_Table : aliased SSE.Storage_Array (1 .. 8); + -- Structured Exception Registration table (2 words) + + procedure Install_SEH_Handler (Addr : System.Address); + pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler"); + -- Install the SEH (Structured Exception Handling) handler + + Cause : Cause_Of_Termination := Normal; + -- Indicates the reason why this task terminates. Normal corresponds to + -- a task terminating due to completing the last statement of its body, + -- or as a result of waiting on a terminate alternative. If the task + -- terminates because it is being aborted then Cause will be set + -- to Abnormal. If the task terminates because of an exception + -- raised by the execution of its task body, then Cause is set + -- to Unhandled_Exception. + + EO : Exception_Occurrence; + -- If the task terminates because of an exception raised by the + -- execution of its task body, then EO will contain the associated + -- exception occurrence. Otherwise, it will contain Null_Occurrence. + + TH : Termination_Handler := null; + -- Pointer to the protected procedure to be executed upon task + -- termination. + + procedure Search_Fall_Back_Handler (ID : Task_Id); + -- Procedure that searches recursively a fall-back handler through the + -- master relationship. If the handler is found, its pointer is stored + -- in TH. It stops when the handler is found or when the ID is null. + + ------------------------------ + -- Search_Fall_Back_Handler -- + ------------------------------ + + procedure Search_Fall_Back_Handler (ID : Task_Id) is + begin + -- A null Task_Id indicates that we have reached the root of the + -- task hierarchy and no handler has been found. + + if ID = null then + return; + + -- If there is a fall back handler, store its pointer for later + -- execution. + + elsif ID.Common.Fall_Back_Handler /= null then + TH := ID.Common.Fall_Back_Handler; + + -- Otherwise look for a fall back handler in the parent + + else + Search_Fall_Back_Handler (ID.Common.Parent); + end if; + end Search_Fall_Back_Handler; + + -- Start of processing for Task_Wrapper + + begin + pragma Assert (Self_ID.Deferral_Level = 1); + + Debug.Master_Hook + (Self_ID, Self_ID.Common.Parent, Self_ID.Master_of_Task); + + -- Assume a size of the stack taken at this stage + + if not Parameters.Sec_Stack_Dynamic then + Self_ID.Common.Compiler_Data.Sec_Stack_Addr := + Secondary_Stack'Address; + SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last)); + end if; + + if Use_Alternate_Stack then + Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address; + end if; + + -- Set the guard page at the bottom of the stack. The call to unprotect + -- the page is done in Terminate_Task + + Stack_Guard (Self_ID, True); + + -- Initialize low-level TCB components, that cannot be initialized by + -- the creator. Enter_Task sets Self_ID.LL.Thread. + + Enter_Task (Self_ID); + + -- Initialize dynamic stack usage + + if System.Stack_Usage.Is_Enabled then + declare + Guard_Page_Size : constant := 16 * 1024; + -- Part of the stack used as a guard page. This is an OS dependent + -- value, so we need to use the maximum. This value is only used + -- when the stack address is known, that is currently Windows. + + Small_Overflow_Guard : constant := 12 * 1024; + -- Note: this used to be 4K, but was changed to 12K, since + -- smaller values resulted in segmentation faults from dynamic + -- stack analysis. + + Big_Overflow_Guard : constant := 64 * 1024 + 8 * 1024; + Small_Stack_Limit : constant := 64 * 1024; + -- ??? These three values are experimental, and seem to work on + -- most platforms. They still need to be analyzed further. They + -- also need documentation, what are they and why does the logic + -- differ depending on whether the stack is large or small??? + + Pattern_Size : Natural := + Natural (Self_ID.Common. + Compiler_Data.Pri_Stack_Info.Size); + -- Size of the pattern + + Stack_Base : Address; + -- Address of the base of the stack + + begin + Stack_Base := Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base; + + if Stack_Base = Null_Address then + + -- On many platforms, we don't know the real stack base + -- address. Estimate it using an address in the frame. + + Stack_Base := Bottom_Of_Stack'Address; + + -- Also reduce the size of the stack to take into account the + -- secondary stack array declared in this frame. This is for + -- sure very conservative. + + if not Parameters.Sec_Stack_Dynamic then + Pattern_Size := + Pattern_Size - Natural (Secondary_Stack_Size); + end if; + + -- Adjustments for inner frames + + Pattern_Size := Pattern_Size - + (if Pattern_Size < Small_Stack_Limit + then Small_Overflow_Guard + else Big_Overflow_Guard); + else + -- Reduce by the size of the final guard page + + Pattern_Size := Pattern_Size - Guard_Page_Size; + end if; + + STPO.Lock_RTS; + Initialize_Analyzer + (Self_ID.Common.Analyzer, + Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len), + Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size), + SSE.To_Integer (Stack_Base), + Pattern_Size); + STPO.Unlock_RTS; + Fill_Stack (Self_ID.Common.Analyzer); + end; + end if; + + -- We setup the SEH (Structured Exception Handling) handler if supported + -- on the target. + + Install_SEH_Handler (SEH_Table'Address); + + -- Initialize exception occurrence + + Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); + + -- We lock RTS_Lock to wait for activator to finish activating the rest + -- of the chain, so that everyone in the chain comes out in priority + -- order. + + -- This also protects the value of + -- Self_ID.Common.Activator.Common.Wait_Count. + + Lock_RTS; + Unlock_RTS; + + if not System.Restrictions.Abort_Allowed then + + -- If Abort is not allowed, reset the deferral level since it will + -- not get changed by the generated code. Keeping a default value + -- of one would prevent some operations (e.g. select or delay) to + -- proceed successfully. + + Self_ID.Deferral_Level := 0; + end if; + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event (Debug.Debug_Event_Run, Self_ID); + end if; + + begin + -- We are separating the following portion of the code in order to + -- place the exception handlers in a different block. In this way, + -- we do not call Set_Jmpbuf_Address (which needs Self) before we + -- set Self in Enter_Task + + -- Call the task body procedure + + -- The task body is called with abort still deferred. That + -- eliminates a dangerous window, for which we had to patch-up in + -- Terminate_Task. + + -- During the expansion of the task body, we insert an RTS-call + -- to Abort_Undefer, at the first point where abort should be + -- allowed. + + Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg); + Initialization.Defer_Abort_Nestable (Self_ID); + + exception + -- We can't call Terminate_Task in the exception handlers below, + -- since there may be (e.g. in the case of GCC exception handling) + -- clean ups associated with the exception handler that need to + -- access task specific data. + + -- Defer abort so that this task can't be aborted while exiting + + when Standard'Abort_Signal => + Initialization.Defer_Abort_Nestable (Self_ID); + + -- Update the cause that motivated the task termination so that + -- the appropriate information is passed to the task termination + -- procedure. Task termination as a result of waiting on a + -- terminate alternative is a normal termination, although it is + -- implemented using the abort mechanisms. + + if Self_ID.Terminate_Alternative then + Cause := Normal; + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Terminated, Self_ID); + end if; + else + Cause := Abnormal; + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Abort_Terminated, Self_ID); + end if; + end if; + + when others => + -- ??? Using an E : others here causes CD2C11A to fail on Tru64 + + Initialization.Defer_Abort_Nestable (Self_ID); + + -- Perform the task specific exception tracing duty. We handle + -- these outputs here and not in the common notification routine + -- because we need access to tasking related data and we don't + -- want to drag dependencies against tasking related units in the + -- the common notification units. Additionally, no trace is ever + -- triggered from the common routine for the Unhandled_Raise case + -- in tasks, since an exception never appears unhandled in this + -- context because of this handler. + + if Exception_Trace = Unhandled_Raise then + Trace_Unhandled_Exception_In_Task (Self_ID); + end if; + + -- Update the cause that motivated the task termination so that + -- the appropriate information is passed to the task termination + -- procedure, as well as the associated Exception_Occurrence. + + Cause := Unhandled_Exception; + + Save_Occurrence (EO, SSL.Get_Current_Excep.all.all); + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Exception_Terminated, Self_ID); + end if; + end; + + -- Look for a task termination handler. This code is for all tasks but + -- the environment task. The task termination code for the environment + -- task is executed by SSL.Task_Termination_Handler. + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + if Self_ID.Common.Specific_Handler /= null then + TH := Self_ID.Common.Specific_Handler; + + -- Independent tasks should not call the Fall_Back_Handler (of the + -- environment task), because they are implementation artifacts that + -- should be invisible to Ada programs. + + elsif Self_ID.Master_of_Task /= Independent_Task_Level then + + -- Look for a fall-back handler following the master relationship + -- for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back + -- handler applies only to the dependent tasks of the task". Hence, + -- if the terminating tasks (Self_ID) had a fall-back handler, it + -- would not apply to itself, so we start the search with the parent. + + Search_Fall_Back_Handler (Self_ID.Common.Parent); + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + -- Execute the task termination handler if we found it + + if TH /= null then + begin + TH.all (Cause, Self_ID, EO); + + exception + + -- RM-C.7.3 requires all exceptions raised here to be ignored + + when others => + null; + end; + end if; + + if System.Stack_Usage.Is_Enabled then + Compute_Result (Self_ID.Common.Analyzer); + Report_Result (Self_ID.Common.Analyzer); + end if; + + Terminate_Task (Self_ID); + end Task_Wrapper; + + -------------------- + -- Terminate_Task -- + -------------------- + + -- Before we allow the thread to exit, we must clean up. This is a delicate + -- job. We must wake up the task's master, who may immediately try to + -- deallocate the ATCB from the current task WHILE IT IS STILL EXECUTING. + + -- To avoid this, the parent task must be blocked up to the latest + -- statement executed. The trouble is that we have another step that we + -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD. + -- We have to postpone that until the end because compiler-generated code + -- is likely to try to access that data at just about any point. + + -- We can't call Destroy_TSD while we are holding any other locks, because + -- it locks Global_Task_Lock, and our deadlock prevention rules require + -- that to be the outermost lock. Our first "solution" was to just lock + -- Global_Task_Lock in addition to the other locks, and force the parent to + -- also lock this lock between its wakeup and its freeing of the ATCB. See + -- Complete_Task for the parent-side of the code that has the matching + -- calls to Task_Lock and Task_Unlock. That was not really a solution, + -- since the operation Task_Unlock continued to access the ATCB after + -- unlocking, after which the parent was observed to race ahead, deallocate + -- the ATCB, and then reallocate it to another task. The call to + -- Undefer_Abort in Task_Unlock by the "terminated" task was overwriting + -- the data of the new task that reused the ATCB. To solve this problem, we + -- introduced the new operation Final_Task_Unlock. + + procedure Terminate_Task (Self_ID : Task_Id) is + Environment_Task : constant Task_Id := STPO.Environment_Task; + Master_of_Task : Integer; + Deallocate : Boolean; + + begin + Debug.Task_Termination_Hook; + + -- Since GCC cannot allocate stack chunks efficiently without reordering + -- some of the allocations, we have to handle this unexpected situation + -- here. Normally we never have to call Vulnerable_Complete_Task here. + + if Self_ID.Common.Activator /= null then + Vulnerable_Complete_Task (Self_ID); + end if; + + Initialization.Task_Lock (Self_ID); + + if Single_Lock then + Lock_RTS; + end if; + + Master_of_Task := Self_ID.Master_of_Task; + + -- Check if the current task is an independent task If so, decrement + -- the Independent_Task_Count value. + + if Master_of_Task = Independent_Task_Level then + if Single_Lock then + Utilities.Independent_Task_Count := + Utilities.Independent_Task_Count - 1; + + else + Write_Lock (Environment_Task); + Utilities.Independent_Task_Count := + Utilities.Independent_Task_Count - 1; + Unlock (Environment_Task); + end if; + end if; + + -- Unprotect the guard page if needed + + Stack_Guard (Self_ID, False); + + Utilities.Make_Passive (Self_ID, Task_Completed => True); + Deallocate := Self_ID.Free_On_Termination; + + if Single_Lock then + Unlock_RTS; + end if; + + pragma Assert (Check_Exit (Self_ID)); + + SSL.Destroy_TSD (Self_ID.Common.Compiler_Data); + Initialization.Final_Task_Unlock (Self_ID); + + -- WARNING: past this point, this thread must assume that the ATCB has + -- been deallocated, and can't access it anymore (which is why we have + -- saved the Free_On_Termination flag in a temporary variable). + + if Deallocate then + Free_Task (Self_ID); + end if; + + if Master_of_Task > 0 then + STPO.Exit_Task; + end if; + end Terminate_Task; + + ---------------- + -- Terminated -- + ---------------- + + function Terminated (T : Task_Id) return Boolean is + Self_ID : constant Task_Id := STPO.Self; + Result : Boolean; + + begin + Initialization.Defer_Abort_Nestable (Self_ID); + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (T); + Result := T.Common.State = Terminated; + Unlock (T); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort_Nestable (Self_ID); + return Result; + end Terminated; + + ---------------------------------------- + -- Trace_Unhandled_Exception_In_Task -- + ---------------------------------------- + + procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is + procedure To_Stderr (S : String); + pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); + + use System.Soft_Links; + use System.Standard_Library; + + function To_Address is new + Ada.Unchecked_Conversion + (Task_Id, System.Task_Primitives.Task_Address); + + Excep : constant Exception_Occurrence_Access := + SSL.Get_Current_Excep.all; + + begin + -- This procedure is called by the task outermost handler in + -- Task_Wrapper below, so only once the task stack has been fully + -- unwound. The common notification routine has been called at the + -- raise point already. + + -- Lock to prevent unsynchronized output + + Initialization.Task_Lock (Self_Id); + To_Stderr ("task "); + + if Self_Id.Common.Task_Image_Len /= 0 then + To_Stderr + (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len)); + To_Stderr ("_"); + end if; + + To_Stderr (System.Address_Image (To_Address (Self_Id))); + To_Stderr (" terminated by unhandled exception"); + To_Stderr ((1 => ASCII.LF)); + To_Stderr (Exception_Information (Excep.all)); + Initialization.Task_Unlock (Self_Id); + end Trace_Unhandled_Exception_In_Task; + + ------------------------------------ + -- Vulnerable_Complete_Activation -- + ------------------------------------ + + -- As in several other places, the locks of the activator and activated + -- task are both locked here. This follows our deadlock prevention lock + -- ordering policy, since the activated task must be created after the + -- activator. + + procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is + Activator : constant Task_Id := Self_ID.Common.Activator; + + begin + pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C')); + + Write_Lock (Activator); + Write_Lock (Self_ID); + + pragma Assert (Self_ID.Common.Activator /= null); + + -- Remove dangling reference to Activator, since a task may outlive its + -- activator. + + Self_ID.Common.Activator := null; + + -- Wake up the activator, if it is waiting for a chain of tasks to + -- activate, and we are the last in the chain to complete activation. + + if Activator.Common.State = Activator_Sleep then + Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1; + + if Activator.Common.Wait_Count = 0 then + Wakeup (Activator, Activator_Sleep); + end if; + end if; + + -- The activator raises a Tasking_Error if any task it is activating + -- is completed before the activation is done. However, if the reason + -- for the task completion is an abort, we do not raise an exception. + -- See RM 9.2(5). + + if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then + Activator.Common.Activation_Failed := True; + end if; + + Unlock (Self_ID); + Unlock (Activator); + + -- After the activation, active priority should be the same as base + -- priority. We must unlock the Activator first, though, since it + -- should not wait if we have lower priority. + + if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then + Write_Lock (Self_ID); + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + Unlock (Self_ID); + end if; + end Vulnerable_Complete_Activation; + + -------------------------------- + -- Vulnerable_Complete_Master -- + -------------------------------- + + procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is + C : Task_Id; + P : Task_Id; + CM : constant Master_Level := Self_ID.Master_Within; + T : aliased Task_Id; + + To_Be_Freed : Task_Id; + -- This is a list of ATCBs to be freed, after we have released all RTS + -- locks. This is necessary because of the locking order rules, since + -- the storage manager uses Global_Task_Lock. + + pragma Warnings (Off); + function Check_Unactivated_Tasks return Boolean; + pragma Warnings (On); + -- Temporary error-checking code below. This is part of the checks + -- added in the new run time. Call it only inside a pragma Assert. + + ----------------------------- + -- Check_Unactivated_Tasks -- + ----------------------------- + + function Check_Unactivated_Tasks return Boolean is + begin + if not Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + C := All_Tasks_List; + while C /= null loop + if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then + return False; + end if; + + if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then + Write_Lock (C); + + if C.Common.State = Unactivated then + return False; + end if; + + Unlock (C); + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Unlock (Self_ID); + + if not Single_Lock then + Unlock_RTS; + end if; + + return True; + end Check_Unactivated_Tasks; + + -- Start of processing for Vulnerable_Complete_Master + + begin + pragma Debug + (Debug.Trace (Self_ID, "V_Complete_Master(" & CM'Img & ")", 'C')); + + pragma Assert (Self_ID.Common.Wait_Count = 0); + pragma Assert + (Self_ID.Deferral_Level > 0 + or else not System.Restrictions.Abort_Allowed); + + -- Count how many active dependent tasks this master currently has, and + -- record this in Wait_Count. + + -- This count should start at zero, since it is initialized to zero for + -- new tasks, and the task should not exit the sleep-loops that use this + -- count until the count reaches zero. + + -- While we're counting, if we run across any unactivated tasks that + -- belong to this master, we summarily terminate them as required by + -- RM-9.2(6). + + Lock_RTS; + Write_Lock (Self_ID); + + C := All_Tasks_List; + while C /= null loop + + -- Terminate unactivated (never-to-be activated) tasks + + if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then + + -- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task + -- = CM. The only case where C is pending activation by this + -- task, but the master of C is not CM is in Ada 2005, when C is + -- part of a return object of a build-in-place function. + + pragma Assert (C.Common.State = Unactivated); + + Write_Lock (C); + C.Common.Activator := null; + C.Common.State := Terminated; + C.Callable := False; + Utilities.Cancel_Queued_Entry_Calls (C); + Unlock (C); + end if; + + -- Count it if directly dependent on this master + + if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then + Write_Lock (C); + + if C.Awake_Count /= 0 then + Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; + end if; + + Unlock (C); + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Self_ID.Common.State := Master_Completion_Sleep; + Unlock (Self_ID); + + if not Single_Lock then + Unlock_RTS; + end if; + + -- Wait until dependent tasks are all terminated or ready to terminate. + -- While waiting, the task may be awakened if the task's priority needs + -- changing, or this master is aborted. In the latter case, we abort the + -- dependents, and resume waiting until Wait_Count goes to zero. + + Write_Lock (Self_ID); + + loop + exit when Self_ID.Common.Wait_Count = 0; + + -- Here is a difference as compared to Complete_Master + + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + and then not Self_ID.Dependents_Aborted + then + if Single_Lock then + Abort_Dependents (Self_ID); + else + Unlock (Self_ID); + Lock_RTS; + Abort_Dependents (Self_ID); + Unlock_RTS; + Write_Lock (Self_ID); + end if; + else + pragma Debug + (Debug.Trace (Self_ID, "master_completion_sleep", 'C')); + Sleep (Self_ID, Master_Completion_Sleep); + end if; + end loop; + + Self_ID.Common.State := Runnable; + Unlock (Self_ID); + + -- Dependents are all terminated or on terminate alternatives. Now, + -- force those on terminate alternatives to terminate, by aborting them. + + pragma Assert (Check_Unactivated_Tasks); + + if Self_ID.Alive_Count > 1 then + -- ??? + -- Consider finding a way to skip the following extra steps if there + -- are no dependents with terminate alternatives. This could be done + -- by adding another count to the ATCB, similar to Awake_Count, but + -- keeping track of tasks that are on terminate alternatives. + + pragma Assert (Self_ID.Common.Wait_Count = 0); + + -- Force any remaining dependents to terminate by aborting them + + if not Single_Lock then + Lock_RTS; + end if; + + Abort_Dependents (Self_ID); + + -- Above, when we "abort" the dependents we are simply using this + -- operation for convenience. We are not required to support the full + -- abort-statement semantics; in particular, we are not required to + -- immediately cancel any queued or in-service entry calls. That is + -- good, because if we tried to cancel a call we would need to lock + -- the caller, in order to wake the caller up. Our anti-deadlock + -- rules prevent us from doing that without releasing the locks on C + -- and Self_ID. Releasing and retaking those locks would be wasteful + -- at best, and should not be considered further without more + -- detailed analysis of potential concurrent accesses to the ATCBs + -- of C and Self_ID. + + -- Count how many "alive" dependent tasks this master currently has, + -- and record this in Wait_Count. This count should start at zero, + -- since it is initialized to zero for new tasks, and the task should + -- not exit the sleep-loops that use this count until the count + -- reaches zero. + + pragma Assert (Self_ID.Common.Wait_Count = 0); + + Write_Lock (Self_ID); + + C := All_Tasks_List; + while C /= null loop + if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then + Write_Lock (C); + + pragma Assert (C.Awake_Count = 0); + + if C.Alive_Count > 0 then + pragma Assert (C.Terminate_Alternative); + Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; + end if; + + Unlock (C); + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Self_ID.Common.State := Master_Phase_2_Sleep; + Unlock (Self_ID); + + if not Single_Lock then + Unlock_RTS; + end if; + + -- Wait for all counted tasks to finish terminating themselves + + Write_Lock (Self_ID); + + loop + exit when Self_ID.Common.Wait_Count = 0; + Sleep (Self_ID, Master_Phase_2_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + Unlock (Self_ID); + end if; + + -- We don't wake up for abort here. We are already terminating just as + -- fast as we can, so there is no point. + + -- Remove terminated tasks from the list of Self_ID's dependents, but + -- don't free their ATCBs yet, because of lock order restrictions, which + -- don't allow us to call "free" or "malloc" while holding any other + -- locks. Instead, we put those ATCBs to be freed onto a temporary list, + -- called To_Be_Freed. + + if not Single_Lock then + Lock_RTS; + end if; + + C := All_Tasks_List; + P := null; + while C /= null loop + + -- If Free_On_Termination is set, do nothing here, and let the + -- task free itself if not already done, otherwise we risk a race + -- condition where Vulnerable_Free_Task is called in the loop below, + -- while the task calls Free_Task itself, in Terminate_Task. + + if C.Common.Parent = Self_ID + and then C.Master_of_Task >= CM + and then not C.Free_On_Termination + then + if P /= null then + P.Common.All_Tasks_Link := C.Common.All_Tasks_Link; + else + All_Tasks_List := C.Common.All_Tasks_Link; + end if; + + T := C.Common.All_Tasks_Link; + C.Common.All_Tasks_Link := To_Be_Freed; + To_Be_Freed := C; + C := T; + + else + P := C; + C := C.Common.All_Tasks_Link; + end if; + end loop; + + Unlock_RTS; + + -- Free all the ATCBs on the list To_Be_Freed + + -- The ATCBs in the list are no longer in All_Tasks_List, and after + -- any interrupt entries are detached from them they should no longer + -- be referenced. + + -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to + -- avoid a race between a terminating task and its parent. The parent + -- might try to deallocate the ACTB out from underneath the exiting + -- task. Note that Free will also lock Global_Task_Lock, but that is + -- OK, since this is the *one* lock for which we have a mechanism to + -- support nested locking. See Task_Wrapper and its finalizer for more + -- explanation. + + -- ??? + -- The check "T.Common.Parent /= null ..." below is to prevent dangling + -- references to terminated library-level tasks, which could otherwise + -- occur during finalization of library-level objects. A better solution + -- might be to hook task objects into the finalization chain and + -- deallocate the ATCB when the task object is deallocated. However, + -- this change is not likely to gain anything significant, since all + -- this storage should be recovered en-masse when the process exits. + + while To_Be_Freed /= null loop + T := To_Be_Freed; + To_Be_Freed := T.Common.All_Tasks_Link; + + -- ??? On SGI there is currently no Interrupt_Manager, that's why we + -- need to check if the Interrupt_Manager_ID is null. + + if T.Interrupt_Entry and then Interrupt_Manager_ID /= null then + declare + Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1; + -- Corresponds to the entry index of System.Interrupts. + -- Interrupt_Manager.Detach_Interrupt_Entries. Be sure + -- to update this value when changing Interrupt_Manager specs. + + type Param_Type is access all Task_Id; + + Param : aliased Param_Type := T'Access; + + begin + System.Tasking.Rendezvous.Call_Simple + (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index, + Param'Address); + end; + end if; + + if (T.Common.Parent /= null + and then T.Common.Parent.Common.Parent /= null) + or else T.Master_of_Task > Library_Task_Level + then + Initialization.Task_Lock (Self_ID); + + -- If Sec_Stack_Addr is not null, it means that Destroy_TSD + -- has not been called yet (case of an unactivated task). + + if T.Common.Compiler_Data.Sec_Stack_Addr /= Null_Address then + SSL.Destroy_TSD (T.Common.Compiler_Data); + end if; + + Vulnerable_Free_Task (T); + Initialization.Task_Unlock (Self_ID); + end if; + end loop; + + -- It might seem nice to let the terminated task deallocate its own + -- ATCB. That would not cover the case of unactivated tasks. It also + -- would force us to keep the underlying thread around past termination, + -- since references to the ATCB are possible past termination. + + -- Currently, we get rid of the thread as soon as the task terminates, + -- and let the parent recover the ATCB later. + + -- Some day, if we want to recover the ATCB earlier, at task + -- termination, we could consider using "fat task IDs", that include the + -- serial number with the ATCB pointer, to catch references to tasks + -- that no longer have ATCBs. It is not clear how much this would gain, + -- since the user-level task object would still be occupying storage. + + -- Make next master level up active. We don't need to lock the ATCB, + -- since the value is only updated by each task for itself. + + Self_ID.Master_Within := CM - 1; + + Debug.Master_Completed_Hook (Self_ID, CM); + end Vulnerable_Complete_Master; + + ------------------------------ + -- Vulnerable_Complete_Task -- + ------------------------------ + + -- Complete the calling task + + -- This procedure must be called with abort deferred. It should only be + -- called by Complete_Task and Finalize_Global_Tasks (for the environment + -- task). + + -- The effect is similar to that of Complete_Master. Differences include + -- the closing of entries here, and computation of the number of active + -- dependent tasks in Complete_Master. + + -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation, + -- because that does its own locking, and because we do not need the lock + -- to test Self_ID.Common.Activator. That value should only be read and + -- modified by Self. + + procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is + begin + pragma Assert + (Self_ID.Deferral_Level > 0 + or else not System.Restrictions.Abort_Allowed); + pragma Assert (Self_ID = Self); + pragma Assert + (Self_ID.Master_Within in + Self_ID.Master_of_Task + 1 .. Self_ID.Master_of_Task + 3); + pragma Assert (Self_ID.Common.Wait_Count = 0); + pragma Assert (Self_ID.Open_Accepts = null); + pragma Assert (Self_ID.ATC_Nesting_Level = 1); + + pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C')); + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + Self_ID.Callable := False; + + -- In theory, Self should have no pending entry calls left on its + -- call-stack. Each async. select statement should clean its own call, + -- and blocking entry calls should defer abort until the calls are + -- cancelled, then clean up. + + Utilities.Cancel_Queued_Entry_Calls (Self_ID); + Unlock (Self_ID); + + if Self_ID.Common.Activator /= null then + Vulnerable_Complete_Activation (Self_ID); + end if; + + if Single_Lock then + Unlock_RTS; + end if; + + -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 we may have + -- dependent tasks for which we need to wait. Otherwise we just exit. + + if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then + Vulnerable_Complete_Master (Self_ID); + end if; + end Vulnerable_Complete_Task; + + -------------------------- + -- Vulnerable_Free_Task -- + -------------------------- + + -- Recover all runtime system storage associated with the task T. This + -- should only be called after T has terminated and will no longer be + -- referenced. + + -- For tasks created by an allocator that fails, due to an exception, it + -- is called from Expunge_Unactivated_Tasks. + + -- For tasks created by elaboration of task object declarations it is + -- called from the finalization code of the Task_Wrapper procedure. + + procedure Vulnerable_Free_Task (T : Task_Id) is + begin + pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T)); + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (T); + Initialization.Finalize_Attributes (T); + Unlock (T); + + if Single_Lock then + Unlock_RTS; + end if; + + System.Task_Primitives.Operations.Finalize_TCB (T); + end Vulnerable_Free_Task; + +-- Package elaboration code + +begin + -- Establish the Adafinal softlink + + -- This is not done inside the central RTS initialization routine + -- to avoid with'ing this package from System.Tasking.Initialization. + + SSL.Adafinal := Finalize_Global_Tasks'Access; + + -- Establish soft links for subprograms that manipulate master_id's. + -- This cannot be done when the RTS is initialized, because of various + -- elaboration constraints. + + SSL.Current_Master := Stages.Current_Master'Access; + SSL.Enter_Master := Stages.Enter_Master'Access; + SSL.Complete_Master := Stages.Complete_Master'Access; +end System.Tasking.Stages; diff --git a/gcc/ada/libgnarl/s-tassta.ads b/gcc/ada/libgnarl/s-tassta.ads new file mode 100644 index 00000000000..bc837fc9af8 --- /dev/null +++ b/gcc/ada/libgnarl/s-tassta.ads @@ -0,0 +1,305 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . S T A G 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 package represents the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls +-- (aka GNARLI, GNU Ada Run-time Library Interface) + +-- Note: Only the compiler is allowed to use this interface, by generating +-- direct calls to it, via Rtsfind. + +-- Any changes to this interface may require corresponding compiler changes +-- in exp_ch9.adb and possibly exp_ch7.adb + +with System.Task_Info; +with System.Parameters; + +with Ada.Real_Time; + +package System.Tasking.Stages is + pragma Elaborate_Body; + + -- The compiler will expand in the GNAT tree the following construct: + + -- task type T (Discr : Integer); + + -- task body T is + -- ...declarations, possibly some controlled... + -- begin + -- ...B...; + -- end T; + + -- T1 : T (1); + + -- as follows: + + -- enter_master.all; + + -- _chain : aliased activation_chain; + -- activation_chainIP (_chain); + + -- task type t (discr : integer); + -- tE : aliased boolean := false; + -- tZ : size_type := unspecified_size; + -- type tV (discr : integer) is limited record + -- _task_id : task_id; + -- end record; + -- procedure tB (_task : access tV); + -- freeze tV [ + -- procedure tVIP (_init : in out tV; _master : master_id; + -- _chain : in out activation_chain; _task_id : in task_image_type; + -- discr : integer) is + -- begin + -- _init.discr := discr; + -- _init._task_id := null; + -- create_task (unspecified_priority, tZ, + -- unspecified_task_info, unspecified_cpu, + -- ada__real_time__time_span_zero, 0, _master, + -- task_procedure_access!(tB'address), _init'address, + -- tE'unchecked_access, _chain, _task_id, _init._task_id); + -- return; + -- end tVIP; + -- ] + + -- procedure tB (_task : access tV) is + -- discr : integer renames _task.discr; + + -- procedure _clean is + -- begin + -- abort_defer.all; + -- complete_task; + -- finalize_list (F14b); + -- abort_undefer.all; + -- return; + -- end _clean; + -- begin + -- abort_undefer.all; + -- ...declarations... + -- complete_activation; + -- ...B...; + -- return; + -- at end + -- _clean; + -- end tB; + + -- tE := true; + -- t1 : t (1); + -- _master : constant master_id := current_master.all; + -- t1S : task_image_type := new string'"t1"; + -- task_image_typeIP (t1, _master, _chain, t1S, 1); + + -- activate_tasks (_chain'unchecked_access); + + procedure Abort_Tasks (Tasks : Task_List); + -- Compiler interface only. Do not call from within the RTS. Initiate + -- abort, however, the actual abort is done by abortee by means of + -- Abort_Handler and Abort_Undefer + -- + -- source code: + -- Abort T1, T2; + -- code expansion: + -- abort_tasks (task_list'(t1._task_id, t2._task_id)); + + procedure Activate_Tasks (Chain_Access : Activation_Chain_Access); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called by the creator of a chain of one or more new tasks, + -- to activate them. The chain is a linked list that up to this point is + -- only known to the task that created them, though the individual tasks + -- are already in the All_Tasks_List. + -- + -- The compiler builds the chain in LIFO order (as a stack). Another + -- version of this procedure had code to reverse the chain, so as to + -- activate the tasks in the order of declaration. This might be nice, but + -- it is not needed if priority-based scheduling is supported, since all + -- the activated tasks synchronize on the activators lock before they + -- start activating and so they should start activating in priority order. + -- ??? Actually, the body of this package DOES reverse the chain, so I + -- don't understand the above comment. + + procedure Complete_Activation; + -- Compiler interface only. Do not call from within the RTS. + -- This should be called from the task body at the end of + -- the elaboration code for its declarative part. + -- Decrement the count of tasks to be activated by the activator and + -- wake it up so it can check to see if all tasks have been activated. + -- Except for the environment task, which should never call this procedure, + -- T.Activator should only be null iff T has completed activation. + + procedure Complete_Master; + -- Compiler interface only. Do not call from within the RTS. This must + -- be called on exit from any master where Enter_Master was called. + -- Assume abort is deferred at this point. + + procedure Complete_Task; + -- Compiler interface only. Do not call from within the RTS. + -- This should be called from an implicit at-end handler + -- associated with the task body, when it completes. + -- From this point, the current task will become not callable. + -- If the current task have not completed activation, this should be done + -- now in order to wake up the activator (the environment task). + + procedure Create_Task + (Priority : Integer; + Size : System.Parameters.Size_Type; + Secondary_Stack_Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + CPU : Integer; + Relative_Deadline : Ada.Real_Time.Time_Span; + Domain : Dispatching_Domain_Access; + Num_Entries : Task_Entry_Index; + Master : Master_Level; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : String; + Created_Task : out Task_Id); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called to create a new task. + -- + -- Priority is the task's priority (assumed to be in range of type + -- System.Any_Priority) + -- Size is the stack size of the task to create + -- Secondary_Stack_Size is the secondary stack size of the task to create + -- Task_Info is the task info associated with the created task, or + -- Unspecified_Task_Info if none. + -- CPU is the task affinity. Passed as an Integer because the undefined + -- value is not in the range of CPU_Range. Static range checks are + -- performed when analyzing the pragma, and dynamic ones are performed + -- before setting the affinity at run time. + -- Relative_Deadline is the relative deadline associated with the created + -- task by means of a pragma Relative_Deadline, or 0.0 if none. + -- Domain is the dispatching domain associated with the created task by + -- means of a Dispatching_Domain pragma or aspect, or null if none. + -- State is the compiler generated task's procedure body + -- Discriminants is a pointer to a limited record whose discriminants + -- are those of the task to create. This parameter should be passed as + -- the single argument to State. + -- Elaborated is a pointer to a Boolean that must be set to true on exit + -- if the task could be successfully elaborated. + -- Chain is a linked list of task that needs to be created. On exit, + -- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID + -- will be Created_Task (e.g the created task will be linked at the front + -- of Chain). + -- Task_Image is a string created by the compiler that the + -- run time can store to ease the debugging and the + -- Ada.Task_Identification facility. + -- Created_Task is the resulting task. + -- + -- This procedure can raise Storage_Error if the task creation failed. + + function Current_Master return Master_Level; + -- Compiler interface only. + -- This is called to obtain the current master nesting level. + + procedure Enter_Master; + -- Compiler interface only. Do not call from within the RTS. + -- This must be called on entry to any "master" where a task, + -- or access type designating objects containing tasks, may be + -- declared. + + procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called by the compiler-generated code for an allocator if + -- the allocated object contains tasks, if the allocator exits without + -- calling Activate_Tasks for a given activation chains, as can happen if + -- an exception occurs during initialization of the object. + -- + -- This should be called ONLY for tasks created via an allocator. Recovery + -- of storage for unactivated local task declarations is done by + -- Complete_Master and Complete_Task. + -- + -- We remove each task from Chain and All_Tasks_List before we free the + -- storage of its ATCB. + -- + -- In other places where we recover the storage of unactivated tasks, we + -- need to clean out the entry queues, but here that should not be + -- necessary, since these tasks should not have been visible to any other + -- tasks, and so no task should be able to queue a call on their entries. + -- + -- Just in case somebody misuses this subprogram, there is a check to + -- verify this condition. + + procedure Finalize_Global_Tasks; + -- This should be called to complete the execution of the environment task + -- and shut down the tasking runtime system. It is the equivalent of + -- Complete_Task, but for the environment task. + -- + -- The environment task must first call Complete_Master, to wait for user + -- tasks that depend on library-level packages to terminate. It then calls + -- Abort_Dependents to abort the "independent" library-level server tasks + -- that are created implicitly by the RTS packages (signal and timer server + -- tasks), and then waits for them to terminate. Then, it calls + -- Vulnerable_Complete_Task. + -- + -- It currently also executes the global finalization list, and then resets + -- the "soft links". + + procedure Free_Task (T : Task_Id); + -- Recover all runtime system storage associated with the task T, but only + -- if T has terminated. Do nothing in the other case. It is called from + -- Unchecked_Deallocation, for objects that are or contain tasks. + + procedure Move_Activation_Chain + (From, To : Activation_Chain_Access; + New_Master : Master_ID); + -- Compiler interface only. Do not call from within the RTS. + -- Move all tasks on From list to To list, and change their Master_of_Task + -- to be New_Master. This is used to implement build-in-place function + -- returns. Tasks that are part of the return object are initially placed + -- on an activation chain local to the return statement, and their master + -- is the return statement, in case the return statement is left + -- prematurely (due to raising an exception, being aborted, or a goto or + -- exit statement). Once the return statement has completed successfully, + -- Move_Activation_Chain is called to move them to the caller's activation + -- chain, and change their master to the one passed in by the caller. If + -- that doesn't happen, they will never be activated, and will become + -- terminated on leaving the return statement. + + function Terminated (T : Task_Id) return Boolean; + -- This is called by the compiler to implement the 'Terminated attribute. + -- Though is not required to be so by the ARM, we choose to synchronize + -- with the task's ATCB, so that this is more useful for polling the state + -- of a task, and so that it becomes an abort completion point for the + -- calling task (via Undefer_Abort). + -- + -- source code: + -- T1'Terminated + -- + -- code expansion: + -- terminated (t1._task_id) + + procedure Terminate_Task (Self_ID : Task_Id); + -- Terminate the calling task. + -- This should only be called by the Task_Wrapper procedure, and to + -- deallocate storage associate with foreign tasks. + +end System.Tasking.Stages; diff --git a/gcc/ada/libgnarl/s-tasuti.adb b/gcc/ada/libgnarl/s-tasuti.adb new file mode 100644 index 00000000000..1a7e8cf9f10 --- /dev/null +++ b/gcc/ada/libgnarl/s-tasuti.adb @@ -0,0 +1,491 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . U T I L I T I E 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 package provides RTS Internal Declarations + +-- These declarations are not part of the GNARLI + +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.Tasking.Debug; +with System.Task_Primitives.Operations; +with System.Tasking.Initialization; +with System.Tasking.Queuing; +with System.Parameters; + +package body System.Tasking.Utilities is + + package STPO renames System.Task_Primitives.Operations; + + use Parameters; + use Tasking.Debug; + use Task_Primitives; + use Task_Primitives.Operations; + + -------------------- + -- Abort_One_Task -- + -------------------- + + -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but: + -- (1) caller should be holding no locks except RTS_Lock when Single_Lock + -- (2) may be called for tasks that have not yet been activated + -- (3) always aborts whole task + + procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id) is + begin + Write_Lock (T); + + if T.Common.State = Unactivated then + T.Common.Activator := null; + T.Common.State := Terminated; + T.Callable := False; + Cancel_Queued_Entry_Calls (T); + + elsif T.Common.State /= Terminated then + Initialization.Locked_Abort_To_Level (Self_ID, T, 0); + end if; + + Unlock (T); + end Abort_One_Task; + + ----------------- + -- Abort_Tasks -- + ----------------- + + -- This must be called to implement the abort statement. + -- Much of the actual work of the abort is done by the abortee, + -- via the Abort_Handler signal handler, and propagation of the + -- Abort_Signal special exception. + + procedure Abort_Tasks (Tasks : Task_List) is + Self_Id : constant Task_Id := STPO.Self; + C : Task_Id; + P : Task_Id; + + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + Initialization.Defer_Abort_Nestable (Self_Id); + + -- ????? + -- Really should not be nested deferral here. + -- Patch for code generation error that defers abort before + -- evaluating parameters of an entry call (at least, timed entry + -- calls), and so may propagate an exception that causes abort + -- to remain undeferred indefinitely. See C97404B. When all + -- such bugs are fixed, this patch can be removed. + + Lock_RTS; + + for J in Tasks'Range loop + C := Tasks (J); + Abort_One_Task (Self_Id, C); + end loop; + + C := All_Tasks_List; + + while C /= null loop + if C.Pending_ATC_Level > 0 then + P := C.Common.Parent; + + while P /= null loop + if P.Pending_ATC_Level = 0 then + Abort_One_Task (Self_Id, C); + exit; + end if; + + P := P.Common.Parent; + end loop; + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Unlock_RTS; + Initialization.Undefer_Abort_Nestable (Self_Id); + end Abort_Tasks; + + ------------------------------- + -- Cancel_Queued_Entry_Calls -- + ------------------------------- + + -- This should only be called by T, unless T is a terminated previously + -- unactivated task. + + procedure Cancel_Queued_Entry_Calls (T : Task_Id) is + Next_Entry_Call : Entry_Call_Link; + Entry_Call : Entry_Call_Link; + Self_Id : constant Task_Id := STPO.Self; + + Caller : Task_Id; + pragma Unreferenced (Caller); + -- Should this be removed ??? + + Level : Integer; + pragma Unreferenced (Level); + -- Should this be removed ??? + + begin + pragma Assert (T = Self or else T.Common.State = Terminated); + + for J in 1 .. T.Entry_Num loop + Queuing.Dequeue_Head (T.Entry_Queues (J), Entry_Call); + + while Entry_Call /= null loop + + -- Leave Entry_Call.Done = False, since this is cancelled + + Caller := Entry_Call.Self; + Entry_Call.Exception_To_Raise := Tasking_Error'Identity; + Queuing.Dequeue_Head (T.Entry_Queues (J), Next_Entry_Call); + Level := Entry_Call.Level - 1; + Unlock (T); + Write_Lock (Entry_Call.Self); + Initialization.Wakeup_Entry_Caller + (Self_Id, Entry_Call, Cancelled); + Unlock (Entry_Call.Self); + Write_Lock (T); + Entry_Call.State := Done; + Entry_Call := Next_Entry_Call; + end loop; + end loop; + end Cancel_Queued_Entry_Calls; + + ------------------------ + -- Exit_One_ATC_Level -- + ------------------------ + + -- Call only with abort deferred and holding lock of Self_Id. + -- This is a bit of common code for all entry calls. + -- The effect is to exit one level of ATC nesting. + + -- If we have reached the desired ATC nesting level, reset the + -- requested level to effective infinity, to allow further calls. + -- In any case, reset Self_Id.Aborting, to allow re-raising of + -- Abort_Signal. + + procedure Exit_One_ATC_Level (Self_ID : Task_Id) is + begin + Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1; + + pragma Debug + (Debug.Trace (Self_ID, "EOAL: exited to ATC level: " & + ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); + + pragma Assert (Self_ID.ATC_Nesting_Level >= 1); + + if Self_ID.Pending_ATC_Level < ATC_Level_Infinity then + if Self_ID.Pending_ATC_Level = Self_ID.ATC_Nesting_Level then + Self_ID.Pending_ATC_Level := ATC_Level_Infinity; + Self_ID.Aborting := False; + else + -- Force the next Undefer_Abort to re-raise Abort_Signal + + pragma Assert + (Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level); + + if Self_ID.Aborting then + Self_ID.ATC_Hack := True; + Self_ID.Pending_Action := True; + end if; + end if; + end if; + end Exit_One_ATC_Level; + + ---------------------- + -- Make_Independent -- + ---------------------- + + function Make_Independent return Boolean is + Self_Id : constant Task_Id := STPO.Self; + Environment_Task : constant Task_Id := STPO.Environment_Task; + Parent : constant Task_Id := Self_Id.Common.Parent; + + begin + if Self_Id.Known_Tasks_Index /= -1 then + Known_Tasks (Self_Id.Known_Tasks_Index) := null; + end if; + + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Environment_Task); + Write_Lock (Self_Id); + + -- The run time assumes that the parent of an independent task is the + -- environment task. + + pragma Assert (Parent = Environment_Task); + + Self_Id.Master_of_Task := Independent_Task_Level; + + -- Update Independent_Task_Count that is needed for the GLADE + -- termination rule. See also pending update in + -- System.Tasking.Stages.Check_Independent + + Independent_Task_Count := Independent_Task_Count + 1; + + -- This should be called before the task reaches its "begin" (see spec), + -- which ensures that the environment task cannot race ahead and be + -- already waiting for children to complete. + + Unlock (Self_Id); + pragma Assert (Environment_Task.Common.State /= Master_Completion_Sleep); + + Unlock (Environment_Task); + + if Single_Lock then + Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + -- Return True. Actually the return value is junk, since we expect it + -- always to be ignored (see spec), but we have to return something! + + return True; + end Make_Independent; + + ------------------ + -- Make_Passive -- + ------------------ + + procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean) is + C : Task_Id := Self_ID; + P : Task_Id := C.Common.Parent; + + Master_Completion_Phase : Integer; + + begin + if P /= null then + Write_Lock (P); + end if; + + Write_Lock (C); + + if Task_Completed then + Self_ID.Common.State := Terminated; + + if Self_ID.Awake_Count = 0 then + + -- We are completing via a terminate alternative. + -- Our parent should wait in Phase 2 of Complete_Master. + + Master_Completion_Phase := 2; + + pragma Assert (Task_Completed); + pragma Assert (Self_ID.Terminate_Alternative); + pragma Assert (Self_ID.Alive_Count = 1); + + else + -- We are NOT on a terminate alternative. + -- Our parent should wait in Phase 1 of Complete_Master. + + Master_Completion_Phase := 1; + pragma Assert (Self_ID.Awake_Count >= 1); + end if; + + -- We are accepting with a terminate alternative + + else + if Self_ID.Open_Accepts = null then + + -- Somebody started a rendezvous while we had our lock open. + -- Skip the terminate alternative. + + Unlock (C); + + if P /= null then + Unlock (P); + end if; + + return; + end if; + + Self_ID.Terminate_Alternative := True; + Master_Completion_Phase := 0; + + pragma Assert (Self_ID.Terminate_Alternative); + pragma Assert (Self_ID.Awake_Count >= 1); + end if; + + if Master_Completion_Phase = 2 then + + -- Since our Awake_Count is zero but our Alive_Count + -- is nonzero, we have been accepting with a terminate + -- alternative, and we now have been told to terminate + -- by a completed master (in some ancestor task) that + -- is waiting (with zero Awake_Count) in Phase 2 of + -- Complete_Master. + + pragma Debug (Debug.Trace (Self_ID, "Make_Passive: Phase 2", 'M')); + + pragma Assert (P /= null); + + C.Alive_Count := C.Alive_Count - 1; + + if C.Alive_Count > 0 then + Unlock (C); + Unlock (P); + return; + end if; + + -- C's count just went to zero, indicating that + -- all of C's dependents are terminated. + -- C has a parent, P. + + loop + -- C's count just went to zero, indicating that all of C's + -- dependents are terminated. C has a parent, P. Notify P that + -- C and its dependents have all terminated. + + P.Alive_Count := P.Alive_Count - 1; + exit when P.Alive_Count > 0; + Unlock (C); + Unlock (P); + C := P; + P := C.Common.Parent; + + -- Environment task cannot have terminated yet + + pragma Assert (P /= null); + + Write_Lock (P); + Write_Lock (C); + end loop; + + if P.Common.State = Master_Phase_2_Sleep + and then C.Master_of_Task = P.Master_Within + then + pragma Assert (P.Common.Wait_Count > 0); + P.Common.Wait_Count := P.Common.Wait_Count - 1; + + if P.Common.Wait_Count = 0 then + Wakeup (P, Master_Phase_2_Sleep); + end if; + end if; + + Unlock (C); + Unlock (P); + return; + end if; + + -- We are terminating in Phase 1 or Complete_Master, + -- or are accepting on a terminate alternative. + + C.Awake_Count := C.Awake_Count - 1; + + if Task_Completed then + C.Alive_Count := C.Alive_Count - 1; + end if; + + if C.Awake_Count > 0 or else P = null then + Unlock (C); + + if P /= null then + Unlock (P); + end if; + + return; + end if; + + -- C's count just went to zero, indicating that all of C's + -- dependents are terminated or accepting with terminate alt. + -- C has a parent, P. + + loop + -- Notify P that C has gone passive + + if P.Awake_Count > 0 then + P.Awake_Count := P.Awake_Count - 1; + end if; + + if Task_Completed and then C.Alive_Count = 0 then + P.Alive_Count := P.Alive_Count - 1; + end if; + + exit when P.Awake_Count > 0; + Unlock (C); + Unlock (P); + C := P; + P := C.Common.Parent; + + if P = null then + return; + end if; + + Write_Lock (P); + Write_Lock (C); + end loop; + + -- P has non-passive dependents + + if P.Common.State = Master_Completion_Sleep + and then C.Master_of_Task = P.Master_Within + then + pragma Debug + (Debug.Trace + (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M')); + + -- If parent is in Master_Completion_Sleep, it cannot be on a + -- terminate alternative, hence it cannot have Wait_Count of zero. + + pragma Assert (P.Common.Wait_Count > 0); + P.Common.Wait_Count := P.Common.Wait_Count - 1; + + if P.Common.Wait_Count = 0 then + Wakeup (P, Master_Completion_Sleep); + end if; + + else + pragma Debug + (Debug.Trace (Self_ID, "Make_Passive: Phase 1, parent awake", 'M')); + null; + end if; + + Unlock (C); + Unlock (P); + end Make_Passive; + +end System.Tasking.Utilities; diff --git a/gcc/ada/libgnarl/s-tasuti.ads b/gcc/ada/libgnarl/s-tasuti.ads new file mode 100644 index 00000000000..351666645fb --- /dev/null +++ b/gcc/ada/libgnarl/s-tasuti.ads @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . U T I L I T I 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 package provides RTS Internal Declarations. +-- These declarations are not part of the GNARLI + +with Ada.Unchecked_Conversion; +with System.Task_Primitives; + +package System.Tasking.Utilities is + + function ATCB_To_Address is new + Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address); + + --------------------------------- + -- Task_Stage Related routines -- + --------------------------------- + + function Make_Independent return Boolean; + -- Move the current task to the outermost level (level 2) of the master + -- hierarchy of the environment task. That is one level further out + -- than normal tasks defined in library-level packages (level 3). The + -- environment task will wait for level 3 tasks to terminate normally, + -- then it will abort all the level 2 tasks. See Finalize_Global_Tasks + -- procedure for more information. + -- + -- This is a dangerous operation, and should never be used on nested tasks + -- or tasks that depend on any objects that might be finalized earlier than + -- the termination of the environment task. It is for internal use by the + -- GNARL, to prevent such internal server tasks from preventing a partition + -- from terminating. + -- + -- Also note that the run time assumes that the parent of an independent + -- task is the environment task. If this is not the case, Make_Independent + -- will change the task's parent. This assumption is particularly + -- important for master level completion and for the computation of + -- Independent_Task_Count. + -- + -- NOTE WELL: Make_Independent should be called before the task reaches its + -- "begin", like this: + -- + -- task body Some_Independent_Task is + -- ... + -- Ignore : constant Boolean := Make_Independent; + -- ... + -- begin + -- + -- The return value is meaningless; the only reason this is a function is + -- to get around the Ada limitation that makes a procedure call + -- syntactically illegal before the "begin". + -- + -- Calling it before "begin" ensures that the call completes before the + -- activating task can proceed. This is important for preventing race + -- conditions. For example, if the environment task reaches + -- Finalize_Global_Tasks before some task has finished Make_Independent, + -- the program can hang. + -- + -- Note also that if a package declares independent tasks, it should not + -- initialize its package-body data after "begin" of the package, because + -- that's where the tasks are activated. Initializing such data before the + -- task activation helps prevent the tasks from accessing uninitialized + -- data. + + Independent_Task_Count : Natural := 0; + -- Number of independent tasks. This counter is incremented each time + -- Make_Independent is called. Note that if a server task terminates, + -- this counter will not be decremented. Since Make_Independent locks + -- the environment task (because every independent task depends on it), + -- this counter is protected by the environment task's lock. + + --------------------------------- + -- Task Abort Related Routines -- + --------------------------------- + + procedure Cancel_Queued_Entry_Calls (T : Task_Id); + -- Cancel any entry calls queued on target task. + -- Call this while holding T's lock (or RTS_Lock in Single_Lock mode). + + procedure Exit_One_ATC_Level (Self_ID : Task_Id); + pragma Inline (Exit_One_ATC_Level); + -- Call only with abort deferred and holding lock of Self_ID. + -- This is a bit of common code for all entry calls. + -- The effect is to exit one level of ATC nesting. + + procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id); + -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but: + -- (1) caller should be holding no locks + -- (2) may be called for tasks that have not yet been activated + -- (3) always aborts whole task + + procedure Abort_Tasks (Tasks : Task_List); + -- Abort_Tasks is called to initiate abort, however, the actual + -- aborting is done by aborted task by means of Abort_Handler + + procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean); + -- Update counts to indicate current task is either terminated or + -- accepting on a terminate alternative. Call holding no locks except + -- Global_Task_Lock when calling from Terminate_Task, and RTS_Lock when + -- Single_Lock is True. + +end System.Tasking.Utilities; diff --git a/gcc/ada/libgnarl/s-tataat.adb b/gcc/ada/libgnarl/s-tataat.adb new file mode 100644 index 00000000000..b2d01f87168 --- /dev/null +++ b/gcc/ada/libgnarl/s-tataat.adb @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . T A S K _ A T T R I B U T E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2014-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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Parameters; use System.Parameters; +with System.Tasking.Initialization; use System.Tasking.Initialization; +with System.Task_Primitives.Operations; + +package body System.Tasking.Task_Attributes is + + package STPO renames System.Task_Primitives.Operations; + + type Index_Info is record + Used : Boolean; + -- Used is True if a given index is used by an instantiation of + -- Ada.Task_Attributes, False otherwise. + + Require_Finalization : Boolean; + -- Require_Finalization is True if the attribute requires finalization + end record; + + Index_Array : array (1 .. Max_Attribute_Count) of Index_Info := + (others => (False, False)); + + -- Note that this package will use an efficient implementation with no + -- locks and no extra dynamic memory allocation if Attribute can fit in a + -- System.Address type and Initial_Value is 0 (or null for an access type). + + function Next_Index (Require_Finalization : Boolean) return Integer is + Self_Id : constant Task_Id := STPO.Self; + + begin + Task_Lock (Self_Id); + + for J in Index_Array'Range loop + if not Index_Array (J).Used then + Index_Array (J).Used := True; + Index_Array (J).Require_Finalization := Require_Finalization; + Task_Unlock (Self_Id); + return J; + end if; + end loop; + + Task_Unlock (Self_Id); + raise Storage_Error with "Out of task attributes"; + end Next_Index; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Index : Integer) is + Self_Id : constant Task_Id := STPO.Self; + begin + pragma Assert (Index in Index_Array'Range); + Task_Lock (Self_Id); + Index_Array (Index).Used := False; + Task_Unlock (Self_Id); + end Finalize; + + -------------------------- + -- Require_Finalization -- + -------------------------- + + function Require_Finalization (Index : Integer) return Boolean is + begin + pragma Assert (Index in Index_Array'Range); + return Index_Array (Index).Require_Finalization; + end Require_Finalization; + +end System.Tasking.Task_Attributes; diff --git a/gcc/ada/libgnarl/s-tataat.ads b/gcc/ada/libgnarl/s-tataat.ads new file mode 100644 index 00000000000..92e81d0a64d --- /dev/null +++ b/gcc/ada/libgnarl/s-tataat.ads @@ -0,0 +1,70 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . T A S K _ A T T R I B U T E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2014-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 package provides support for the body of Ada.Task_Attributes + +with Ada.Unchecked_Conversion; + +package System.Tasking.Task_Attributes is + + type Deallocator is access procedure (Ptr : Atomic_Address); + + type Attribute_Record is record + Free : Deallocator; + end record; + -- The real type is declared in Ada.Task_Attributes body: Real_Attribute. + -- As long as the first field is the deallocator we are good. + + type Attribute_Access is access all Attribute_Record; + pragma No_Strict_Aliasing (Attribute_Access); + + function To_Attribute is new + Ada.Unchecked_Conversion (Atomic_Address, Attribute_Access); + + function Next_Index (Require_Finalization : Boolean) return Integer; + -- Return the next attribute index available. Require_Finalization is True + -- if the attribute requires finalization and in particular its deallocator + -- (Free field in Attribute_Record) should be called. Raise Storage_Error + -- if no index is available. + + function Require_Finalization (Index : Integer) return Boolean; + -- Return True if a given attribute index requires call to Free. This call + -- is not protected against concurrent access, should only be called during + -- finalization of the corresponding instantiation of Ada.Task_Attributes, + -- or during finalization of a task. + + procedure Finalize (Index : Integer); + -- Finalize given Index, possibly allowing future reuse + +private + pragma Inline (Finalize); + pragma Inline (Require_Finalization); +end System.Tasking.Task_Attributes; diff --git a/gcc/ada/libgnarl/s-tpinop.adb b/gcc/ada/libgnarl/s-tpinop.adb new file mode 100644 index 00000000000..9fad3764c70 --- /dev/null +++ b/gcc/ada/libgnarl/s-tpinop.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.INTERRUPT_OPERATIONS -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Task_Primitives.Interrupt_Operations is + + -- ??? The VxWorks version of System.Interrupt_Management needs to access + -- this array, but due to elaboration problems, it can't with this + -- package directly, so we export this variable for now. + + Interrupt_ID_Map : array (IM.Interrupt_ID) of ST.Task_Id; + pragma Export (Ada, Interrupt_ID_Map, + "system__task_primitives__interrupt_operations__interrupt_id_map"); + + ---------------------- + -- Get_Interrupt_ID -- + ---------------------- + + function Get_Interrupt_ID (T : ST.Task_Id) return IM.Interrupt_ID is + use type ST.Task_Id; + + begin + for Interrupt in IM.Interrupt_ID loop + if Interrupt_ID_Map (Interrupt) = T then + return Interrupt; + end if; + end loop; + + raise Program_Error; + end Get_Interrupt_ID; + + ----------------- + -- Get_Task_Id -- + ----------------- + + function Get_Task_Id (Interrupt : IM.Interrupt_ID) return ST.Task_Id is + begin + return Interrupt_ID_Map (Interrupt); + end Get_Task_Id; + + ---------------------- + -- Set_Interrupt_ID -- + ---------------------- + + procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_Id) is + begin + Interrupt_ID_Map (Interrupt) := T; + end Set_Interrupt_ID; + +end System.Task_Primitives.Interrupt_Operations; diff --git a/gcc/ada/libgnarl/s-tpinop.ads b/gcc/ada/libgnarl/s-tpinop.ads new file mode 100644 index 00000000000..3638543b3fa --- /dev/null +++ b/gcc/ada/libgnarl/s-tpinop.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.INTERRUPT_OPERATIONS -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Interrupt_Management; +with System.Tasking; + +package System.Task_Primitives.Interrupt_Operations is + pragma Preelaborate; + + package IM renames System.Interrupt_Management; + package ST renames System.Tasking; + + procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_Id); + -- Associate an Interrupt_ID with a task + + function Get_Interrupt_ID (T : ST.Task_Id) return IM.Interrupt_ID; + -- Return the Interrupt_ID associated with a task + + function Get_Task_Id (Interrupt : IM.Interrupt_ID) return ST.Task_Id; + -- Return the Task_Id associated with an Interrupt + +end System.Task_Primitives.Interrupt_Operations; diff --git a/gcc/ada/libgnarl/s-tpoaal.adb b/gcc/ada/libgnarl/s-tpoaal.adb new file mode 100644 index 00000000000..981270324a0 --- /dev/null +++ b/gcc/ada/libgnarl/s-tpoaal.adb @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.ATCB_ALLOCATION -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +separate (System.Task_Primitives.Operations) +package body ATCB_Allocation is + + --------------- + -- Free_ATCB -- + --------------- + + procedure Free_ATCB (T : Task_Id) is + Tmp : Task_Id := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + begin + if Is_Self then + declare + Local_ATCB : aliased Ada_Task_Control_Block (0); + -- Create a dummy ATCB and initialize it minimally so that "Free" + -- can still call Self and Defer/Undefer_Abort after Tmp is freed + -- by the underlying memory management library. + + begin + Local_ATCB.Common.LL.Thread := T.Common.LL.Thread; + Local_ATCB.Common.Current_Priority := T.Common.Current_Priority; + + Specific.Set (Local_ATCB'Unchecked_Access); + Free (Tmp); + + -- Note: it is assumed here that for all platforms, Specific.Set + -- deletes the task specific information if passed a null value. + + Specific.Set (null); + end; + + else + Free (Tmp); + end if; + end Free_ATCB; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + +end ATCB_Allocation; diff --git a/gcc/ada/libgnarl/s-tpoben.adb b/gcc/ada/libgnarl/s-tpoben.adb new file mode 100644 index 00000000000..ff17a729ed5 --- /dev/null +++ b/gcc/ada/libgnarl/s-tpoben.adb @@ -0,0 +1,427 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES -- +-- -- +-- 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 package contains all the simple primitives related to protected +-- objects with entries (i.e init, lock, unlock). + +-- The handling of protected objects with no entries is done in +-- System.Tasking.Protected_Objects, the complex routines for protected +-- objects with entries in System.Tasking.Protected_Objects.Operations. + +-- The split between Entries and Operations is needed to break circular +-- dependencies inside the run time. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind + +with System.Task_Primitives.Operations; +with System.Restrictions; +with System.Parameters; + +with System.Tasking.Initialization; +pragma Elaborate_All (System.Tasking.Initialization); +-- To insure that tasking is initialized if any protected objects are created + +package body System.Tasking.Protected_Objects.Entries is + + package STPO renames System.Task_Primitives.Operations; + + use Parameters; + use Task_Primitives.Operations; + + ---------------- + -- Local Data -- + ---------------- + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Object : in out Protection_Entries) is + Entry_Call : Entry_Call_Link; + Caller : Task_Id; + Ceiling_Violation : Boolean; + Self_ID : constant Task_Id := STPO.Self; + Old_Base_Priority : System.Any_Priority; + + begin + if Object.Finalized then + return; + end if; + + STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); + + if Single_Lock then + Lock_RTS; + end if; + + if Ceiling_Violation then + + -- Dip our own priority down to ceiling of lock. See similar code in + -- Tasking.Entry_Calls.Lock_Server. + + STPO.Write_Lock (Self_ID); + Old_Base_Priority := Self_ID.Common.Base_Priority; + Self_ID.New_Base_Priority := Object.Ceiling; + Initialization.Change_Base_Priority (Self_ID); + STPO.Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error with "ceiling violation"; + end if; + + if Single_Lock then + Lock_RTS; + end if; + + Object.Old_Base_Priority := Old_Base_Priority; + Object.Pending_Action := True; + end if; + + -- Send program_error to all tasks still queued on this object + + for E in Object.Entry_Queues'Range loop + Entry_Call := Object.Entry_Queues (E).Head; + + while Entry_Call /= null loop + Caller := Entry_Call.Self; + Entry_Call.Exception_To_Raise := Program_Error'Identity; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Caller); + + exit when Entry_Call = Object.Entry_Queues (E).Tail; + Entry_Call := Entry_Call.Next; + end loop; + end loop; + + Object.Finalized := True; + + if Single_Lock then + Unlock_RTS; + end if; + + STPO.Unlock (Object.L'Unrestricted_Access); + + STPO.Finalize_Lock (Object.L'Unrestricted_Access); + end Finalize; + + ----------------- + -- Get_Ceiling -- + ----------------- + + function Get_Ceiling + (Object : Protection_Entries_Access) return System.Any_Priority is + begin + return Object.New_Ceiling; + end Get_Ceiling; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : Protection_Entries_Access) + return Boolean + is + pragma Warnings (Off, Object); + begin + return False; + end Has_Interrupt_Or_Attach_Handler; + + ----------------------------------- + -- Initialize_Protection_Entries -- + ----------------------------------- + + procedure Initialize_Protection_Entries + (Object : Protection_Entries_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Queue_Maxes : Protected_Entry_Queue_Max_Access; + Entry_Bodies : Protected_Entry_Body_Access; + Find_Body_Index : Find_Body_Index_Access) + is + Init_Priority : Integer := Ceiling_Priority; + Self_ID : constant Task_Id := STPO.Self; + + begin + if Init_Priority = Unspecified_Priority then + Init_Priority := System.Priority'Last; + end if; + + if Locking_Policy = 'C' + and then Has_Interrupt_Or_Attach_Handler (Object) + and then Init_Priority not in System.Interrupt_Priority + then + -- Required by C.3.1(11) + + raise Program_Error; + end if; + + -- If a PO is created from a controlled operation, abort is already + -- deferred at this point, so we need to use Defer_Abort_Nestable. In + -- some cases, the following assertion can help to spot inconsistencies, + -- outside the above scenario involving controlled types. + + -- pragma Assert (Self_Id.Deferral_Level = 0); + + Initialization.Defer_Abort_Nestable (Self_ID); + Initialize_Lock (Init_Priority, Object.L'Access); + Initialization.Undefer_Abort_Nestable (Self_ID); + + Object.Ceiling := System.Any_Priority (Init_Priority); + Object.New_Ceiling := System.Any_Priority (Init_Priority); + Object.Owner := Null_Task; + Object.Compiler_Info := Compiler_Info; + Object.Pending_Action := False; + Object.Call_In_Progress := null; + Object.Entry_Queue_Maxes := Entry_Queue_Maxes; + Object.Entry_Bodies := Entry_Bodies; + Object.Find_Body_Index := Find_Body_Index; + + for E in Object.Entry_Queues'Range loop + Object.Entry_Queues (E).Head := null; + Object.Entry_Queues (E).Tail := null; + end loop; + end Initialize_Protection_Entries; + + ------------------ + -- Lock_Entries -- + ------------------ + + procedure Lock_Entries (Object : Protection_Entries_Access) is + Ceiling_Violation : Boolean; + + begin + Lock_Entries_With_Status (Object, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error with "ceiling violation"; + end if; + end Lock_Entries; + + ------------------------------ + -- Lock_Entries_With_Status -- + ------------------------------ + + procedure Lock_Entries_With_Status + (Object : Protection_Entries_Access; + Ceiling_Violation : out Boolean) + is + begin + if Object.Finalized then + raise Program_Error with "protected object is finalized"; + end if; + + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on a + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. + + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; + end if; + + -- The lock is made without deferring abort + + -- Therefore the abort has to be deferred before calling this routine. + -- This means that the compiler has to generate a Defer_Abort call + -- before the call to Lock. + + -- The caller is responsible for undeferring abort, and compiler + -- generated calls must be protected with cleanup handlers to ensure + -- that abort is undeferred in all cases. + + pragma Assert + (STPO.Self.Deferral_Level > 0 + or else not Restrictions.Abort_Allowed); + + Write_Lock (Object.L'Access, Ceiling_Violation); + + -- We are entering in a protected action, so that we increase the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and update the protected object's owner. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + + begin + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end; + end if; + end Lock_Entries_With_Status; + + ---------------------------- + -- Lock_Read_Only_Entries -- + ---------------------------- + + procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is + Ceiling_Violation : Boolean; + + begin + if Object.Finalized then + raise Program_Error with "protected object is finalized"; + end if; + + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on a + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. + + -- Note that in this case (getting read access), several tasks may + -- have read ownership of the protected object, so that this method of + -- storing the (single) protected object's owner does not work + -- reliably for read locks. However, this is the approach taken for two + -- major reasons: first, this function is not currently being used (it + -- is provided for possible future use), and second, it largely + -- simplifies the implementation. + + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; + end if; + + Read_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error with "ceiling violation"; + end if; + + -- We are entering in a protected action, so that we increase the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and update the protected object's owner. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + + begin + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end; + end if; + end Lock_Read_Only_Entries; + + ----------------------- + -- Number_Of_Entries -- + ----------------------- + + function Number_Of_Entries + (Object : Protection_Entries_Access) return Entry_Index + is + begin + return Entry_Index (Object.Num_Entries); + end Number_Of_Entries; + + ----------------- + -- Set_Ceiling -- + ----------------- + + procedure Set_Ceiling + (Object : Protection_Entries_Access; + Prio : System.Any_Priority) is + begin + Object.New_Ceiling := Prio; + end Set_Ceiling; + + -------------------- + -- Unlock_Entries -- + -------------------- + + procedure Unlock_Entries (Object : Protection_Entries_Access) is + begin + -- We are exiting from a protected action, so that we decrease the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and remove ownership of the protected object. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + + begin + -- Calls to this procedure can only take place when being within + -- a protected action and when the caller is the protected + -- object's owner. + + pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 + and then Object.Owner = Self_Id); + + -- Remove ownership of the protected object + + Object.Owner := Null_Task; + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting - 1; + end; + end if; + + -- Before releasing the mutex we must actually update its ceiling + -- priority if it has been changed. + + if Object.New_Ceiling /= Object.Ceiling then + if Locking_Policy = 'C' then + System.Task_Primitives.Operations.Set_Ceiling + (Object.L'Access, Object.New_Ceiling); + end if; + + Object.Ceiling := Object.New_Ceiling; + end if; + + Unlock (Object.L'Access); + end Unlock_Entries; + +end System.Tasking.Protected_Objects.Entries; diff --git a/gcc/ada/libgnarl/s-tpoben.ads b/gcc/ada/libgnarl/s-tpoben.ads new file mode 100644 index 00000000000..d7e9e4d490f --- /dev/null +++ b/gcc/ada/libgnarl/s-tpoben.ads @@ -0,0 +1,236 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES -- +-- -- +-- 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 package contains all simple primitives related to Protected_Objects +-- with entries (i.e init, lock, unlock). + +-- The handling of protected objects with no entries is done in +-- System.Tasking.Protected_Objects, the complex routines for protected +-- objects with entries in System.Tasking.Protected_Objects.Operations. + +-- The split between Entries and Operations is needed to break circular +-- dependencies inside the run time. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +with Ada.Finalization; +with Ada.Unchecked_Conversion; + +package System.Tasking.Protected_Objects.Entries is + pragma Elaborate_Body; + + subtype Positive_Protected_Entry_Index is + Protected_Entry_Index range 1 .. Protected_Entry_Index'Last; + -- Index of the entry (and in some cases of the queue) + + type Find_Body_Index_Access is access + function + (O : System.Address; + E : Protected_Entry_Index) + return Protected_Entry_Index; + -- Convert a queue index to an entry index (an entry family has one entry + -- index for several queue indexes). + + type Protected_Entry_Body_Array is + array (Positive_Protected_Entry_Index range <>) of Entry_Body; + -- Contains executable code for all entry bodies of a protected type + + type Protected_Entry_Body_Access is + access constant Protected_Entry_Body_Array; + + type Protected_Entry_Queue_Array is + array (Protected_Entry_Index range <>) of Entry_Queue; + + type Protected_Entry_Queue_Max_Array is + array (Positive_Protected_Entry_Index range <>) of Natural; + + type Protected_Entry_Queue_Max_Access is + access constant Protected_Entry_Queue_Max_Array; + + -- The following type contains the GNARL state of a protected object. + -- The application-defined portion of the state (i.e. private objects) + -- is maintained by the compiler-generated code. Note that there is a + -- simplified version of this type declared in System.Tasking.PO_Simple + -- that handle the simple case (no entries). + + type Protection_Entries (Num_Entries : Protected_Entry_Index) is new + Ada.Finalization.Limited_Controlled + with record + L : aliased Task_Primitives.Lock; + -- The underlying lock associated with a Protection_Entries. Note + -- that you should never (un)lock Object.L directly, but instead + -- use Lock_Entries/Unlock_Entries. + + Compiler_Info : System.Address; + -- Pointer to compiler-generated record representing protected object + + Call_In_Progress : Entry_Call_Link; + -- Pointer to the entry call being executed (if any) + + Ceiling : System.Any_Priority; + -- Ceiling priority associated with the protected object + + New_Ceiling : System.Any_Priority; + -- New ceiling priority associated to the protected object. In case + -- of assignment of a new ceiling priority to the protected object the + -- frontend generates a call to set_ceiling to save the new value in + -- this field. After such assignment this value can be read by means + -- of the 'Priority attribute, which generates a call to get_ceiling. + -- However, the ceiling of the protected object will not be changed + -- until completion of the protected action in which the assignment + -- has been executed (AARM D.5.2 (10/2)). + + Owner : Task_Id; + -- This field contains the protected object's owner. Null_Task + -- indicates that the protected object is not currently being used. + -- This information is used for detecting the type of potentially + -- blocking operations described in the ARM 9.5.1, par. 15 (external + -- calls on a protected subprogram with the same target object as that + -- of the protected action). + + Old_Base_Priority : System.Any_Priority; + -- Task's base priority when the protected operation was called + + Pending_Action : Boolean; + -- Flag indicating that priority has been dipped temporarily in order + -- to avoid violating the priority ceiling of the lock associated with + -- this protected object, in Lock_Server. The flag tells Unlock_Server + -- or Unlock_And_Update_Server to restore the old priority to + -- Old_Base_Priority. This is needed because of situations (bad + -- language design?) where one needs to lock a PO but to do so would + -- violate the priority ceiling. For example, this can happen when an + -- entry call has been requeued to a lower-priority object, and the + -- caller then tries to cancel the call while its own priority is + -- higher than the ceiling of the new PO. + + Finalized : Boolean := False; + -- Set to True by Finalize to make this routine idempotent + + Entry_Bodies : Protected_Entry_Body_Access; + -- Pointer to an array containing the executable code for all entry + -- bodies of a protected type. + + Find_Body_Index : Find_Body_Index_Access; + -- A function which maps the entry index in a call (which denotes the + -- queue of the proper entry) into the body of the entry. + + Entry_Queue_Maxes : Protected_Entry_Queue_Max_Access; + -- Access to an array of naturals representing the max value for each + -- entry's queue length. A value of 0 signifies no max. + + Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries); + -- Action and barrier subprograms for the protected type. + end record; + + -- No default initial values for this type, since call records will need to + -- be re-initialized before every use. + + type Protection_Entries_Access is access all Protection_Entries'Class; + -- See comments in s-tassta.adb about the implicit call to Current_Master + -- generated by this declaration. + + function To_Address is + new Ada.Unchecked_Conversion (Protection_Entries_Access, System.Address); + function To_Protection is + new Ada.Unchecked_Conversion (System.Address, Protection_Entries_Access); + + function Get_Ceiling + (Object : Protection_Entries_Access) return System.Any_Priority; + -- Returns the new ceiling priority of the protected object + + function Has_Interrupt_Or_Attach_Handler + (Object : Protection_Entries_Access) return Boolean; + -- Returns True if an Interrupt_Handler or Attach_Handler pragma applies + -- to the protected object. That is to say this primitive returns False for + -- Protection, but is overridden to return True when interrupt handlers are + -- declared so the check required by C.3.1(11) can be implemented in + -- System.Tasking.Protected_Objects.Initialize_Protection. + + procedure Initialize_Protection_Entries + (Object : Protection_Entries_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Queue_Maxes : Protected_Entry_Queue_Max_Access; + Entry_Bodies : Protected_Entry_Body_Access; + Find_Body_Index : Find_Body_Index_Access); + -- Initialize the Object parameter so that it can be used by the runtime + -- to keep track of the runtime state of a protected object. + + procedure Lock_Entries (Object : Protection_Entries_Access); + -- Lock a protected object for write access. Upon return, the caller owns + -- the lock to this object, and no other call to Lock or Lock_Read_Only + -- with the same argument will return until the corresponding call to + -- Unlock has been made by the caller. Program_Error is raised in case of + -- ceiling violation. + + procedure Lock_Entries_With_Status + (Object : Protection_Entries_Access; + Ceiling_Violation : out Boolean); + -- Same as above, but return the ceiling violation status instead of + -- raising Program_Error. + + procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access); + -- Lock a protected object for read access. Upon return, the caller owns + -- the lock for read access, and no other calls to Lock with the same + -- argument will return until the corresponding call to Unlock has been + -- made by the caller. Other calls to Lock_Read_Only may (but need not) + -- return before the call to Unlock, and the corresponding callers will + -- also own the lock for read access. + -- + -- Note: we are not currently using this interface, it is provided for + -- possible future use. At the current time, everyone uses Lock for both + -- read and write locks. + + function Number_Of_Entries + (Object : Protection_Entries_Access) return Entry_Index; + -- Return the number of entries of a protected object + + procedure Set_Ceiling + (Object : Protection_Entries_Access; + Prio : System.Any_Priority); + -- Sets the new ceiling priority of the protected object + + procedure Unlock_Entries (Object : Protection_Entries_Access); + -- Relinquish ownership of the lock for the object represented by the + -- Object parameter. If this ownership was for write access, or if it was + -- for read access where there are no other read access locks outstanding, + -- one (or more, in the case of Lock_Read_Only) of the tasks waiting on + -- this lock (if any) will be given the lock and allowed to return from + -- the Lock or Lock_Read_Only call. + +private + + overriding procedure Finalize (Object : in out Protection_Entries); + -- Clean up a Protection object; in particular, finalize the associated + -- Lock object. + +end System.Tasking.Protected_Objects.Entries; diff --git a/gcc/ada/libgnarl/s-tpobmu.adb b/gcc/ada/libgnarl/s-tpobmu.adb new file mode 100644 index 00000000000..412bc96b2a4 --- /dev/null +++ b/gcc/ada/libgnarl/s-tpobmu.adb @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- +-- M U L T I P R O C E S S O R S -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 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. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Tasking.Protected_Objects.Multiprocessors is + + ------------ + -- Served -- + ------------ + + procedure Served (Entry_Call : Entry_Call_Link) is + pragma Unreferenced (Entry_Call); + begin + pragma Assert (False, "Invalid operation"); + end Served; + + ------------------------- + -- Wakeup_Served_Entry -- + ------------------------- + + procedure Wakeup_Served_Entry is + begin + pragma Assert (False, "Invalid operation"); + end Wakeup_Served_Entry; + +end System.Tasking.Protected_Objects.Multiprocessors; diff --git a/gcc/ada/libgnarl/s-tpobmu.ads b/gcc/ada/libgnarl/s-tpobmu.ads new file mode 100644 index 00000000000..de65279e339 --- /dev/null +++ b/gcc/ada/libgnarl/s-tpobmu.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- +-- M U L T I P R O C E S S O R S -- +-- S p e c -- +-- -- +-- Copyright (C) 2010-2017, AdaCore -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 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. -- +-- -- +------------------------------------------------------------------------------ + +package System.Tasking.Protected_Objects.Multiprocessors is + + procedure Served (Entry_Call : Entry_Call_Link); + -- This procedure is called at the end of a call to an entry or to a + -- protected procedure. It adds Entry_Call to a per-CPU list, and pokes + -- the CPU (the one from the task waiting on the entry). + + procedure Wakeup_Served_Entry; + -- Called when the CPU is poked to awake all the tasks of the current CPU + -- waiting on entries. + +end System.Tasking.Protected_Objects.Multiprocessors; diff --git a/gcc/ada/libgnarl/s-tpobop.adb b/gcc/ada/libgnarl/s-tpobop.adb new file mode 100644 index 00000000000..242fe45f97e --- /dev/null +++ b/gcc/ada/libgnarl/s-tpobop.adb @@ -0,0 +1,1103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS -- +-- -- +-- 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 package contains all extended primitives related to Protected_Objects +-- with entries. + +-- The handling of protected objects with no entries is done in +-- System.Tasking.Protected_Objects, the simple routines for protected +-- objects with entries in System.Tasking.Protected_Objects.Entries. + +-- The split between Entries and Operations is needed to break circular +-- dependencies inside the run time. + +-- This package contains all primitives related to Protected_Objects. +-- Note: the compiler generates direct calls to this interface, via Rtsfind. + +with System.Task_Primitives.Operations; +with System.Tasking.Entry_Calls; +with System.Tasking.Queuing; +with System.Tasking.Rendezvous; +with System.Tasking.Utilities; +with System.Tasking.Debug; +with System.Parameters; +with System.Restrictions; + +with System.Tasking.Initialization; +pragma Elaborate_All (System.Tasking.Initialization); +-- Insures that tasking is initialized if any protected objects are created + +package body System.Tasking.Protected_Objects.Operations is + + package STPO renames System.Task_Primitives.Operations; + + use Parameters; + use Task_Primitives; + use Ada.Exceptions; + use Entries; + + use System.Restrictions; + use System.Restrictions.Rident; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Update_For_Queue_To_PO + (Entry_Call : Entry_Call_Link; + With_Abort : Boolean); + pragma Inline (Update_For_Queue_To_PO); + -- Update the state of an existing entry call to reflect the fact that it + -- is being enqueued, based on whether the current queuing action is with + -- or without abort. Call this only while holding the PO's lock. It returns + -- with the PO's lock still held. + + procedure Requeue_Call + (Self_Id : Task_Id; + Object : Protection_Entries_Access; + Entry_Call : Entry_Call_Link); + -- Handle requeue of Entry_Call. + -- In particular, queue the call if needed, or service it immediately + -- if possible. + + --------------------------------- + -- Cancel_Protected_Entry_Call -- + --------------------------------- + + -- Compiler interface only (do not call from within the RTS) + + -- This should have analogous effect to Cancel_Task_Entry_Call, setting + -- the value of Block.Cancelled instead of returning the parameter value + -- Cancelled. + + -- The effect should be idempotent, since the call may already have been + -- dequeued. + + -- Source code: + + -- select r.e; + -- ...A... + -- then abort + -- ...B... + -- end select; + + -- Expanded code: + + -- declare + -- X : protected_entry_index := 1; + -- B80b : communication_block; + -- communication_blockIP (B80b); + + -- begin + -- begin + -- A79b : label + -- A79b : declare + -- procedure _clean is + -- begin + -- if enqueued (B80b) then + -- cancel_protected_entry_call (B80b); + -- end if; + -- return; + -- end _clean; + + -- begin + -- protected_entry_call (rTV!(r)._object'unchecked_access, X, + -- null_address, asynchronous_call, B80b, objectF => 0); + -- if enqueued (B80b) then + -- ...B... + -- end if; + -- at end + -- _clean; + -- end A79b; + + -- exception + -- when _abort_signal => + -- abort_undefer.all; + -- null; + -- end; + + -- if not cancelled (B80b) then + -- x := ...A... + -- end if; + -- end; + + -- If the entry call completes after we get into the abortable part, + -- Abort_Signal should be raised and ATC will take us to the at-end + -- handler, which will call _clean. + + -- If the entry call returns with the call already completed, we can skip + -- this, and use the "if enqueued()" to go past the at-end handler, but we + -- will still call _clean. + + -- If the abortable part completes before the entry call is Done, it will + -- call _clean. + + -- If the entry call or the abortable part raises an exception, + -- we will still call _clean, but the value of Cancelled should not matter. + + -- Whoever calls _clean first gets to decide whether the call + -- has been "cancelled". + + -- Enqueued should be true if there is any chance that the call is still on + -- a queue. It seems to be safe to make it True if the call was Onqueue at + -- some point before return from Protected_Entry_Call. + + -- Cancelled should be true iff the abortable part completed + -- and succeeded in cancelling the entry call before it completed. + + -- ????? + -- The need for Enqueued is less obvious. The "if enqueued ()" tests are + -- not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call + -- must do the same test internally, with locking. The one that makes + -- cancellation conditional may be a useful heuristic since at least 1/2 + -- the time the call should be off-queue by that point. The other one seems + -- totally useless, since Protected_Entry_Call must do the same check and + -- then possibly wait for the call to be abortable, internally. + + -- We can check Call.State here without locking the caller's mutex, + -- since the call must be over after returning from Wait_For_Completion. + -- No other task can access the call record at this point. + + procedure Cancel_Protected_Entry_Call + (Block : in out Communication_Block) is + begin + Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled); + end Cancel_Protected_Entry_Call; + + --------------- + -- Cancelled -- + --------------- + + function Cancelled (Block : Communication_Block) return Boolean is + begin + return Block.Cancelled; + end Cancelled; + + ------------------------- + -- Complete_Entry_Body -- + ------------------------- + + procedure Complete_Entry_Body (Object : Protection_Entries_Access) is + begin + Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id); + end Complete_Entry_Body; + + -------------- + -- Enqueued -- + -------------- + + function Enqueued (Block : Communication_Block) return Boolean is + begin + return Block.Enqueued; + end Enqueued; + + ------------------------------------- + -- Exceptional_Complete_Entry_Body -- + ------------------------------------- + + procedure Exceptional_Complete_Entry_Body + (Object : Protection_Entries_Access; + Ex : Ada.Exceptions.Exception_Id) + is + procedure Transfer_Occurrence + (Target : Ada.Exceptions.Exception_Occurrence_Access; + Source : Ada.Exceptions.Exception_Occurrence); + pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); + + Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; + Self_Id : Task_Id; + + begin + pragma Debug + (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P')); + + -- We must have abort deferred, since we are inside a protected + -- operation. + + if Entry_Call /= null then + + -- The call was not requeued + + Entry_Call.Exception_To_Raise := Ex; + + if Ex /= Ada.Exceptions.Null_Id then + + -- An exception was raised and abort was deferred, so adjust + -- before propagating, otherwise the task will stay with deferral + -- enabled for its remaining life. + + Self_Id := STPO.Self; + + if not ZCX_By_Default then + Initialization.Undefer_Abort_Nestable (Self_Id); + end if; + + Transfer_Occurrence + (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access, + Self_Id.Common.Compiler_Data.Current_Excep); + end if; + + -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or + -- PO_Service_Entries on return. + + end if; + end Exceptional_Complete_Entry_Body; + + -------------------- + -- PO_Do_Or_Queue -- + -------------------- + + procedure PO_Do_Or_Queue + (Self_ID : Task_Id; + Object : Protection_Entries_Access; + Entry_Call : Entry_Call_Link) + is + E : constant Protected_Entry_Index := + Protected_Entry_Index (Entry_Call.E); + Index : constant Protected_Entry_Index := + Object.Find_Body_Index (Object.Compiler_Info, E); + Barrier_Value : Boolean; + Queue_Length : Natural; + begin + -- When the Action procedure for an entry body returns, it is either + -- completed (having called [Exceptional_]Complete_Entry_Body) or it + -- is queued, having executed a requeue statement. + + Barrier_Value := + Object.Entry_Bodies (Index).Barrier (Object.Compiler_Info, E); + + if Barrier_Value then + + -- Not abortable while service is in progress + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + Object.Call_In_Progress := Entry_Call; + + pragma Debug + (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P')); + Object.Entry_Bodies (Index).Action ( + Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); + + if Object.Call_In_Progress /= null then + + -- Body of current entry served call to completion + + Object.Call_In_Progress := null; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + else + Requeue_Call (Self_ID, Object, Entry_Call); + end if; + + elsif Entry_Call.Mode /= Conditional_Call + or else not Entry_Call.With_Abort + then + if Run_Time_Restrictions.Set (Max_Entry_Queue_Length) + or else Object.Entry_Queue_Maxes /= null + then + -- Need to check the queue length. Computing the length is an + -- unusual case and is slow (need to walk the queue). + + Queue_Length := Queuing.Count_Waiting (Object.Entry_Queues (E)); + + if (Run_Time_Restrictions.Set (Max_Entry_Queue_Length) + and then Queue_Length >= + Run_Time_Restrictions.Value (Max_Entry_Queue_Length)) + or else + (Object.Entry_Queue_Maxes /= null + and then Object.Entry_Queue_Maxes (Index) /= 0 + and then Queue_Length >= Object.Entry_Queue_Maxes (Index)) + then + -- This violates the Max_Entry_Queue_Length restriction or the + -- Max_Queue_Length bound, raise Program_Error. + + Entry_Call.Exception_To_Raise := Program_Error'Identity; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + return; + end if; + end if; + + -- Do the work: queue the call + + Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call); + Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort); + + return; + else + -- Conditional_Call and With_Abort + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + pragma Assert (Entry_Call.State /= Not_Yet_Abortable); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + + exception + when others => + Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call); + end PO_Do_Or_Queue; + + ------------------------ + -- PO_Service_Entries -- + ------------------------ + + procedure PO_Service_Entries + (Self_ID : Task_Id; + Object : Entries.Protection_Entries_Access; + Unlock_Object : Boolean := True) + is + E : Protected_Entry_Index; + Caller : Task_Id; + Entry_Call : Entry_Call_Link; + + begin + loop + Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call); + + exit when Entry_Call = null; + + E := Protected_Entry_Index (Entry_Call.E); + + -- Not abortable while service is in progress + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + Object.Call_In_Progress := Entry_Call; + + begin + pragma Debug + (Debug.Trace (Self_ID, "POSE: start entry body", 'P')); + + Object.Entry_Bodies + (Object.Find_Body_Index (Object.Compiler_Info, E)).Action + (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); + + exception + when others => + Queuing.Broadcast_Program_Error + (Self_ID, Object, Entry_Call); + end; + + if Object.Call_In_Progress = null then + Requeue_Call (Self_ID, Object, Entry_Call); + exit when Entry_Call.State = Cancelled; + + else + Object.Call_In_Progress := null; + Caller := Entry_Call.Self; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + end loop; + + if Unlock_Object then + Unlock_Entries (Object); + end if; + end PO_Service_Entries; + + --------------------- + -- Protected_Count -- + --------------------- + + function Protected_Count + (Object : Protection_Entries'Class; + E : Protected_Entry_Index) return Natural + is + begin + return Queuing.Count_Waiting (Object.Entry_Queues (E)); + end Protected_Count; + + -------------------------- + -- Protected_Entry_Call -- + -------------------------- + + -- Compiler interface only (do not call from within the RTS) + + -- select r.e; + -- ...A... + -- else + -- ...B... + -- end select; + + -- declare + -- X : protected_entry_index := 1; + -- B85b : communication_block; + -- communication_blockIP (B85b); + + -- begin + -- protected_entry_call (rTV!(r)._object'unchecked_access, X, + -- null_address, conditional_call, B85b, objectF => 0); + + -- if cancelled (B85b) then + -- ...B... + -- else + -- ...A... + -- end if; + -- end; + + -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous + -- entry call. + + -- The initial part of this procedure does not need to lock the calling + -- task's ATCB, up to the point where the call record first may be queued + -- (PO_Do_Or_Queue), since before that no other task will have access to + -- the record. + + -- If this is a call made inside of an abort deferred region, the call + -- should be never abortable. + + -- If the call was not queued abortably, we need to wait until it is before + -- proceeding with the abortable part. + + -- There are some heuristics here, just to save time for frequently + -- occurring cases. For example, we check Initially_Abortable to try to + -- avoid calling the procedure Wait_Until_Abortable, since the normal case + -- for async. entry calls is to be queued abortably. + + -- Another heuristic uses the Block.Enqueued to try to avoid calling + -- Cancel_Protected_Entry_Call if the call can be served immediately. + + procedure Protected_Entry_Call + (Object : Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Block : out Communication_Block) + is + Self_ID : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + Initially_Abortable : Boolean; + Ceiling_Violation : Boolean; + + begin + pragma Debug + (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P')); + + if Self_ID.ATC_Nesting_Level = ATC_Level'Last then + raise Storage_Error with "not enough ATC nesting levels"; + end if; + + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if Detect_Blocking + and then Self_ID.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + -- Self_ID.Deferral_Level should be 0, except when called from Finalize, + -- where abort is already deferred. + + Initialization.Defer_Abort_Nestable (Self_ID); + Lock_Entries_With_Status (Object, Ceiling_Violation); + + if Ceiling_Violation then + + -- Failed ceiling check + + Initialization.Undefer_Abort_Nestable (Self_ID); + raise Program_Error; + end if; + + Block.Self := Self_ID; + Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_ID, "PEC: entered ATC level: " & + ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); + Entry_Call := + Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Mode; + Entry_Call.Cancellation_Attempted := False; + + Entry_Call.State := + (if Self_ID.Deferral_Level > 1 + then Never_Abortable else Now_Abortable); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := STPO.Get_Priority (Self_ID); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_PO := To_Address (Object); + Entry_Call.Called_Task := null; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + PO_Do_Or_Queue (Self_ID, Object, Entry_Call); + Initially_Abortable := Entry_Call.State = Now_Abortable; + PO_Service_Entries (Self_ID, Object); + + -- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call) + -- for completed or cancelled calls. (This is a heuristic, only.) + + if Entry_Call.State >= Done then + + -- Once State >= Done it will not change any more + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Self_ID); + Utilities.Exit_One_ATC_Level (Self_ID); + STPO.Unlock (Self_ID); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + Block.Enqueued := False; + Block.Cancelled := Entry_Call.State = Cancelled; + Initialization.Undefer_Abort_Nestable (Self_ID); + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + return; + + else + -- In this case we cannot conclude anything, since State can change + -- concurrently. + + null; + end if; + + -- Now for the general case + + if Mode = Asynchronous_Call then + + -- Try to avoid an expensive call + + if not Initially_Abortable then + if Single_Lock then + STPO.Lock_RTS; + Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); + STPO.Unlock_RTS; + else + Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); + end if; + end if; + + else + case Mode is + when Conditional_Call + | Simple_Call + => + if Single_Lock then + STPO.Lock_RTS; + Entry_Calls.Wait_For_Completion (Entry_Call); + STPO.Unlock_RTS; + + else + STPO.Write_Lock (Self_ID); + Entry_Calls.Wait_For_Completion (Entry_Call); + STPO.Unlock (Self_ID); + end if; + + Block.Cancelled := Entry_Call.State = Cancelled; + + when Asynchronous_Call + | Timed_Call + => + pragma Assert (False); + null; + end case; + end if; + + Initialization.Undefer_Abort_Nestable (Self_ID); + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + end Protected_Entry_Call; + + ------------------ + -- Requeue_Call -- + ------------------ + + procedure Requeue_Call + (Self_Id : Task_Id; + Object : Protection_Entries_Access; + Entry_Call : Entry_Call_Link) + is + New_Object : Protection_Entries_Access; + Ceiling_Violation : Boolean; + Result : Boolean; + E : Protected_Entry_Index; + + begin + New_Object := To_Protection (Entry_Call.Called_PO); + + if New_Object = null then + + -- Call is to be requeued to a task entry + + if Single_Lock then + STPO.Lock_RTS; + end if; + + Result := Rendezvous.Task_Do_Or_Queue (Self_Id, Entry_Call); + + if not Result then + Queuing.Broadcast_Program_Error + (Self_Id, Object, Entry_Call, RTS_Locked => True); + end if; + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + else + -- Call should be requeued to a PO + + if Object /= New_Object then + + -- Requeue is to different PO + + Lock_Entries_With_Status (New_Object, Ceiling_Violation); + + if Ceiling_Violation then + Object.Call_In_Progress := null; + Queuing.Broadcast_Program_Error (Self_Id, Object, Entry_Call); + + else + PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call); + PO_Service_Entries (Self_Id, New_Object); + end if; + + else + -- Requeue is to same protected object + + -- ??? Try to compensate apparent failure of the scheduler on some + -- OS (e.g VxWorks) to give higher priority tasks a chance to run + -- (see CXD6002). + + STPO.Yield (Do_Yield => False); + + if Entry_Call.With_Abort + and then Entry_Call.Cancellation_Attempted + then + -- If this is a requeue with abort and someone tried to cancel + -- this call, cancel it at this point. + + Entry_Call.State := Cancelled; + return; + end if; + + if not Entry_Call.With_Abort + or else Entry_Call.Mode /= Conditional_Call + then + E := Protected_Entry_Index (Entry_Call.E); + + if Run_Time_Restrictions.Set (Max_Entry_Queue_Length) + and then + Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <= + Queuing.Count_Waiting (Object.Entry_Queues (E)) + then + -- This violates the Max_Entry_Queue_Length restriction, + -- raise Program_Error. + + Entry_Call.Exception_To_Raise := Program_Error'Identity; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + Initialization.Wakeup_Entry_Caller + (Self_Id, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + else + Queuing.Enqueue + (New_Object.Entry_Queues (E), Entry_Call); + Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort); + end if; + + else + PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call); + end if; + end if; + end if; + end Requeue_Call; + + ---------------------------- + -- Protected_Entry_Caller -- + ---------------------------- + + function Protected_Entry_Caller + (Object : Protection_Entries'Class) return Task_Id is + begin + return Object.Call_In_Progress.Self; + end Protected_Entry_Caller; + + ----------------------------- + -- Requeue_Protected_Entry -- + ----------------------------- + + -- Compiler interface only (do not call from within the RTS) + + -- entry e when b is + -- begin + -- b := false; + -- ...A... + -- requeue e2; + -- end e; + + -- procedure rPT__E10b (O : address; P : address; E : + -- protected_entry_index) is + -- type rTVP is access rTV; + -- freeze rTVP [] + -- _object : rTVP := rTVP!(O); + -- begin + -- declare + -- rR : protection renames _object._object; + -- vP : integer renames _object.v; + -- bP : boolean renames _object.b; + -- begin + -- b := false; + -- ...A... + -- requeue_protected_entry (rR'unchecked_access, rR' + -- unchecked_access, 2, false, objectF => 0, new_objectF => + -- 0); + -- return; + -- end; + -- complete_entry_body (_object._object'unchecked_access, objectF => + -- 0); + -- return; + -- exception + -- when others => + -- abort_undefer.all; + -- exceptional_complete_entry_body (_object._object' + -- unchecked_access, current_exception, objectF => 0); + -- return; + -- end rPT__E10b; + + procedure Requeue_Protected_Entry + (Object : Protection_Entries_Access; + New_Object : Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean) + is + Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; + + begin + pragma Debug + (Debug.Trace (STPO.Self, "Requeue_Protected_Entry", 'P')); + pragma Assert (STPO.Self.Deferral_Level > 0); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Called_PO := To_Address (New_Object); + Entry_Call.Called_Task := null; + Entry_Call.With_Abort := With_Abort; + Object.Call_In_Progress := null; + end Requeue_Protected_Entry; + + ------------------------------------- + -- Requeue_Task_To_Protected_Entry -- + ------------------------------------- + + -- Compiler interface only (do not call from within the RTS) + + -- accept e1 do + -- ...A... + -- requeue r.e2; + -- end e1; + + -- A79b : address; + -- L78b : label + + -- begin + -- accept_call (1, A79b); + -- ...A... + -- requeue_task_to_protected_entry (rTV!(r)._object' + -- unchecked_access, 2, false, new_objectF => 0); + -- goto L78b; + -- <> + -- complete_rendezvous; + + -- exception + -- when all others => + -- exceptional_complete_rendezvous (get_gnat_exception); + -- end; + + procedure Requeue_Task_To_Protected_Entry + (New_Object : Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean) + is + Self_ID : constant Task_Id := STPO.Self; + Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call; + + begin + Initialization.Defer_Abort (Self_ID); + + -- We do not need to lock Self_ID here since the call is not abortable + -- at this point, and therefore, the caller cannot cancel the call. + + Entry_Call.Needs_Requeue := True; + Entry_Call.With_Abort := With_Abort; + Entry_Call.Called_PO := To_Address (New_Object); + Entry_Call.Called_Task := null; + Entry_Call.E := Entry_Index (E); + Initialization.Undefer_Abort (Self_ID); + end Requeue_Task_To_Protected_Entry; + + --------------------- + -- Service_Entries -- + --------------------- + + procedure Service_Entries (Object : Protection_Entries_Access) is + Self_ID : constant Task_Id := STPO.Self; + begin + PO_Service_Entries (Self_ID, Object); + end Service_Entries; + + -------------------------------- + -- Timed_Protected_Entry_Call -- + -------------------------------- + + -- Compiler interface only (do not call from within the RTS) + + procedure Timed_Protected_Entry_Call + (Object : Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Entry_Call_Successful : out Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + Ceiling_Violation : Boolean; + + Yielded : Boolean; + pragma Unreferenced (Yielded); + + begin + if Self_Id.ATC_Nesting_Level = ATC_Level'Last then + raise Storage_Error with "not enough ATC nesting levels"; + end if; + + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + Initialization.Defer_Abort_Nestable (Self_Id); + Lock_Entries_With_Status (Object, Ceiling_Violation); + + if Ceiling_Violation then + Initialization.Undefer_Abort (Self_Id); + raise Program_Error; + end if; + + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Timed_Call; + Entry_Call.Cancellation_Attempted := False; + + Entry_Call.State := + (if Self_Id.Deferral_Level > 1 + then Never_Abortable + else Now_Abortable); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := STPO.Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_PO := To_Address (Object); + Entry_Call.Called_Task := null; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + PO_Do_Or_Queue (Self_Id, Object, Entry_Call); + PO_Service_Entries (Self_Id, Object); + + if Single_Lock then + STPO.Lock_RTS; + else + STPO.Write_Lock (Self_Id); + end if; + + -- Try to avoid waiting for completed or cancelled calls + + if Entry_Call.State >= Done then + Utilities.Exit_One_ATC_Level (Self_Id); + + if Single_Lock then + STPO.Unlock_RTS; + else + STPO.Unlock (Self_Id); + end if; + + Entry_Call_Successful := Entry_Call.State = Done; + Initialization.Undefer_Abort_Nestable (Self_Id); + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + return; + end if; + + Entry_Calls.Wait_For_Completion_With_Timeout + (Entry_Call, Timeout, Mode, Yielded); + + if Single_Lock then + STPO.Unlock_RTS; + else + STPO.Unlock (Self_Id); + end if; + + -- ??? Do we need to yield in case Yielded is False + + Initialization.Undefer_Abort_Nestable (Self_Id); + Entry_Call_Successful := Entry_Call.State = Done; + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + end Timed_Protected_Entry_Call; + + ---------------------------- + -- Update_For_Queue_To_PO -- + ---------------------------- + + -- Update the state of an existing entry call, based on + -- whether the current queuing action is with or without abort. + -- Call this only while holding the server's lock. + -- It returns with the server's lock released. + + New_State : constant array (Boolean, Entry_Call_State) + of Entry_Call_State := + (True => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Now_Abortable, + Was_Abortable => Now_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled), + False => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Not_Yet_Abortable, + Was_Abortable => Was_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled) + ); + + procedure Update_For_Queue_To_PO + (Entry_Call : Entry_Call_Link; + With_Abort : Boolean) + is + Old : constant Entry_Call_State := Entry_Call.State; + + begin + pragma Assert (Old < Done); + + Entry_Call.State := New_State (With_Abort, Entry_Call.State); + + if Entry_Call.Mode = Asynchronous_Call then + if Old < Was_Abortable and then + Entry_Call.State = Now_Abortable + then + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + + if Entry_Call.Self.Common.State = Async_Select_Sleep then + STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); + end if; + + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + end if; + + elsif Entry_Call.Mode = Conditional_Call then + pragma Assert (Entry_Call.State < Was_Abortable); + null; + end if; + end Update_For_Queue_To_PO; + +end System.Tasking.Protected_Objects.Operations; diff --git a/gcc/ada/libgnarl/s-tpobop.ads b/gcc/ada/libgnarl/s-tpobop.ads new file mode 100644 index 00000000000..400053c9308 --- /dev/null +++ b/gcc/ada/libgnarl/s-tpobop.ads @@ -0,0 +1,213 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS -- +-- -- +-- 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 package contains all the extended primitives related to protected +-- objects with entries. + +-- The handling of protected objects with no entries is done in +-- System.Tasking.Protected_Objects, the simple routines for protected +-- objects with entries in System.Tasking.Protected_Objects.Entries. The +-- split between Entries and Operations is needed to break circular +-- dependencies inside the run time. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +with Ada.Exceptions; + +with System.Tasking.Protected_Objects.Entries; + +package System.Tasking.Protected_Objects.Operations is + pragma Elaborate_Body; + + type Communication_Block is private; + -- Objects of this type are passed between GNARL calls to allow RTS + -- information to be preserved. + + procedure Protected_Entry_Call + (Object : Entries.Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Block : out Communication_Block); + -- Make a protected entry call to the specified object. + -- Pend a protected entry call on the protected object represented + -- by Object. A pended call is not queued; it may be executed immediately + -- or queued, depending on the state of the entry barrier. + -- + -- E + -- The index representing the entry to be called. + -- + -- Uninterpreted_Data + -- This will be returned by Next_Entry_Call when this call is serviced. + -- It can be used by the compiler to pass information between the + -- caller and the server, in particular entry parameters. + -- + -- Mode + -- The kind of call to be pended + -- + -- Block + -- Information passed between runtime calls by the compiler + + procedure Timed_Protected_Entry_Call + (Object : Entries.Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Entry_Call_Successful : out Boolean); + -- Same as the Protected_Entry_Call but with time-out specified. + -- This routines is used when we do not use ATC mechanism to implement + -- timed entry calls. + + procedure Service_Entries (Object : Entries.Protection_Entries_Access); + pragma Inline (Service_Entries); + + procedure PO_Service_Entries + (Self_ID : Task_Id; + Object : Entries.Protection_Entries_Access; + Unlock_Object : Boolean := True); + -- Service all entry queues of the specified object, executing the + -- corresponding bodies of any queued entry calls that are waiting + -- on True barriers. This is used when the state of a protected + -- object may have changed, in particular after the execution of + -- the statement sequence of a protected procedure. + -- + -- Note that servicing an entry may change the value of one or more + -- barriers, so this routine keeps checking barriers until all of + -- them are closed. + -- + -- This must be called with abort deferred and with the corresponding + -- object locked. + -- + -- If Unlock_Object is set True, then Object is unlocked on return, + -- otherwise Object remains locked and the caller is responsible for + -- the required unlock. + + procedure Complete_Entry_Body (Object : Entries.Protection_Entries_Access); + -- Called from within an entry body procedure, indicates that the + -- corresponding entry call has been serviced. + + procedure Exceptional_Complete_Entry_Body + (Object : Entries.Protection_Entries_Access; + Ex : Ada.Exceptions.Exception_Id); + -- Perform all of the functions of Complete_Entry_Body. In addition, + -- report in Ex the exception whose propagation terminated the entry + -- body to the runtime system. + + procedure Cancel_Protected_Entry_Call (Block : in out Communication_Block); + -- Attempt to cancel the most recent protected entry call. If the call is + -- not queued abortably, wait until it is or until it has completed. + -- If the call is actually cancelled, the called object will be + -- locked on return from this call. Get_Cancelled (Block) can be + -- used to determine if the cancellation took place; there + -- may be entries needing service in this case. + -- + -- Block passes information between this and other runtime calls. + + function Enqueued (Block : Communication_Block) return Boolean; + -- Returns True if the Protected_Entry_Call which returned the + -- specified Block object was queued; False otherwise. + + function Cancelled (Block : Communication_Block) return Boolean; + -- Returns True if the Protected_Entry_Call which returned the + -- specified Block object was cancelled, False otherwise. + + procedure Requeue_Protected_Entry + (Object : Entries.Protection_Entries_Access; + New_Object : Entries.Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean); + -- If Object = New_Object, queue the protected entry call on Object + -- currently being serviced on the queue corresponding to the entry + -- represented by E. + -- + -- If Object /= New_Object, transfer the call to New_Object.E, + -- executing or queuing it as appropriate. + -- + -- With_Abort---True if the call is to be queued abortably, false + -- otherwise. + + procedure Requeue_Task_To_Protected_Entry + (New_Object : Entries.Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean); + -- Transfer task entry call currently being serviced to entry E + -- on New_Object. + -- + -- With_Abort---True if the call is to be queued abortably, false + -- otherwise. + + function Protected_Count + (Object : Entries.Protection_Entries'Class; + E : Protected_Entry_Index) + return Natural; + -- Return the number of entry calls to E on Object + + function Protected_Entry_Caller + (Object : Entries.Protection_Entries'Class) return Task_Id; + -- Return value of E'Caller, where E is the protected entry currently + -- being handled. This will only work if called from within an entry + -- body, as required by the LRM (C.7.1(14)). + + -- For internal use only + + procedure PO_Do_Or_Queue + (Self_ID : Task_Id; + Object : Entries.Protection_Entries_Access; + Entry_Call : Entry_Call_Link); + -- This procedure either executes or queues an entry call, depending + -- on the status of the corresponding barrier. It assumes that abort + -- is deferred and that the specified object is locked. + +private + type Communication_Block is record + Self : Task_Id; + Enqueued : Boolean := True; + Cancelled : Boolean := False; + end record; + pragma Volatile (Communication_Block); + + -- When a program contains limited interfaces, the compiler generates the + -- predefined primitives associated with dispatching selects. One of the + -- parameters of these routines is of type Communication_Block. Even if + -- the program lacks implementing concurrent types, the tasking runtime is + -- dragged in unconditionally because of Communication_Block. To avoid this + -- case, the compiler uses type Dummy_Communication_Block which defined in + -- System.Soft_Links. If the structure of Communication_Block is changed, + -- the corresponding dummy type must be changed as well. + + -- The Communication_Block seems to be a relic. At the moment, the + -- compiler seems to be generating unnecessary conditional code based on + -- this block. See the code generated for async. select with task entry + -- call for another way of solving this ??? + +end System.Tasking.Protected_Objects.Operations; 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-tporft.adb b/gcc/ada/libgnarl/s-tporft.adb new file mode 100644 index 00000000000..7b8a59276f8 --- /dev/null +++ b/gcc/ada/libgnarl/s-tporft.adb @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.REGISTER_FOREIGN_THREAD -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-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. -- +-- -- +------------------------------------------------------------------------------ + +with System.Task_Info; +-- Use for Unspecified_Task_Info + +with System.Soft_Links; +-- used to initialize TSD for a C thread, in function Self + +with System.Multiprocessors; + +separate (System.Task_Primitives.Operations) +function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id is + Local_ATCB : aliased Ada_Task_Control_Block (0); + Self_Id : Task_Id; + Succeeded : Boolean; + +begin + -- This section is tricky. We must not call anything that might require + -- an ATCB, until the new ATCB is in place. In order to get an ATCB + -- immediately, we fake one, so that it is then possible to e.g allocate + -- memory (which might require accessing self). + + -- Record this as the Task_Id for the thread + + Local_ATCB.Common.LL.Thread := Thread; + Local_ATCB.Common.Current_Priority := System.Priority'First; + Specific.Set (Local_ATCB'Unchecked_Access); + + -- It is now safe to use an allocator + + Self_Id := new Ada_Task_Control_Block (0); + + -- Finish initialization + + Lock_RTS; + System.Tasking.Initialize_ATCB + (Self_Id, null, Null_Address, Null_Task, + Foreign_Task_Elaborated'Access, + System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU, null, + Task_Info.Unspecified_Task_Info, 0, 0, Self_Id, Succeeded); + Unlock_RTS; + pragma Assert (Succeeded); + + Self_Id.Master_of_Task := 0; + Self_Id.Master_Within := Self_Id.Master_of_Task + 1; + + for L in Self_Id.Entry_Calls'Range loop + Self_Id.Entry_Calls (L).Self := Self_Id; + Self_Id.Entry_Calls (L).Level := L; + end loop; + + Self_Id.Common.State := Runnable; + Self_Id.Awake_Count := 1; + + Self_Id.Common.Task_Image (1 .. 14) := "foreign thread"; + Self_Id.Common.Task_Image_Len := 14; + + -- Since this is not an ordinary Ada task, we will start out undeferred + + Self_Id.Deferral_Level := 0; + + -- We do not provide an alternate stack for foreign threads + + Self_Id.Common.Task_Alternate_Stack := Null_Address; + + System.Soft_Links.Create_TSD (Self_Id.Common.Compiler_Data); + + Enter_Task (Self_Id); + + return Self_Id; +end Register_Foreign_Thread; diff --git a/gcc/ada/libgnarl/s-tposen.adb b/gcc/ada/libgnarl/s-tposen.adb new file mode 100644 index 00000000000..c87caac7edd --- /dev/null +++ b/gcc/ada/libgnarl/s-tposen.adb @@ -0,0 +1,462 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram ordering check, since restricted GNARLI subprograms are +-- gathered together at end. + +-- This package provides an optimized version of Protected_Objects.Operations +-- and Protected_Objects.Entries making the following assumptions: + +-- PO has only one entry +-- There is only one caller at a time (No_Entry_Queue) +-- There is no dynamic priority support (No_Dynamic_Priorities) +-- No Abort Statements +-- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) +-- PO are at library level +-- No Requeue +-- None of the tasks will terminate (no need for finalization) + +-- This interface is intended to be used in the ravenscar and restricted +-- profiles, the compiler is responsible for ensuring that the conditions +-- mentioned above are respected, except for the No_Entry_Queue restriction +-- that is checked dynamically in this package, since the check cannot be +-- performed at compile time, and is relatively cheap (see PO_Do_Or_Queue, +-- Service_Entry). + +pragma Polling (Off); +-- Turn off polling, we do not want polling to take place during tasking +-- operations. It can cause infinite loops and other problems. + +pragma Suppress (All_Checks); +-- Why is this required ??? + +with Ada.Exceptions; + +with System.Task_Primitives.Operations; +with System.Parameters; + +package body System.Tasking.Protected_Objects.Single_Entry is + + package STPO renames System.Task_Primitives.Operations; + + use Parameters; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Send_Program_Error (Entry_Call : Entry_Call_Link); + pragma Inline (Send_Program_Error); + -- Raise Program_Error in the caller of the specified entry call + + -------------------------- + -- Entry Calls Handling -- + -------------------------- + + procedure Wakeup_Entry_Caller (Entry_Call : Entry_Call_Link); + pragma Inline (Wakeup_Entry_Caller); + -- This is called at the end of service of an entry call, to abort the + -- caller if he is in an abortable part, and to wake up the caller if he + -- is on Entry_Caller_Sleep. Call it holding the lock of Entry_Call.Self. + + procedure Wait_For_Completion (Entry_Call : Entry_Call_Link); + pragma Inline (Wait_For_Completion); + -- This procedure suspends the calling task until the specified entry call + -- has either been completed or cancelled. On exit, the call will not be + -- queued. This waits for calls on protected entries. + -- Call this only when holding Self_ID locked. + + procedure Check_Exception + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + pragma Inline (Check_Exception); + -- Raise any pending exception from the Entry_Call. This should be called + -- at the end of every compiler interface procedure that implements an + -- entry call. The caller should not be holding any locks, or there will + -- be deadlock. + + procedure PO_Do_Or_Queue + (Object : Protection_Entry_Access; + Entry_Call : Entry_Call_Link); + -- This procedure executes or queues an entry call, depending on the status + -- of the corresponding barrier. The specified object is assumed locked. + + --------------------- + -- Check_Exception -- + --------------------- + + procedure Check_Exception + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + pragma Warnings (Off, Self_ID); + + procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); + pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); + + use type Ada.Exceptions.Exception_Id; + + E : constant Ada.Exceptions.Exception_Id := + Entry_Call.Exception_To_Raise; + + begin + if E /= Ada.Exceptions.Null_Id then + Internal_Raise (E); + end if; + end Check_Exception; + + ------------------------ + -- Send_Program_Error -- + ------------------------ + + procedure Send_Program_Error (Entry_Call : Entry_Call_Link) is + Caller : constant Task_Id := Entry_Call.Self; + + begin + Entry_Call.Exception_To_Raise := Program_Error'Identity; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Wakeup_Entry_Caller (Entry_Call); + STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end Send_Program_Error; + + ------------------------- + -- Wait_For_Completion -- + ------------------------- + + procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is + Self_Id : constant Task_Id := Entry_Call.Self; + begin + Self_Id.Common.State := Entry_Caller_Sleep; + STPO.Sleep (Self_Id, Entry_Caller_Sleep); + Self_Id.Common.State := Runnable; + end Wait_For_Completion; + + ------------------------- + -- Wakeup_Entry_Caller -- + ------------------------- + + -- This is called at the end of service of an entry call, to abort the + -- caller if he is in an abortable part, and to wake up the caller if it + -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue. + + -- (This enforces the rule that a task must be off-queue if its state is + -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self. + + -- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion. + + procedure Wakeup_Entry_Caller + (Entry_Call : Entry_Call_Link) + is + Caller : constant Task_Id := Entry_Call.Self; + begin + pragma Assert + (Caller.Common.State /= Terminated and then + Caller.Common.State /= Unactivated); + Entry_Call.State := Done; + STPO.Wakeup (Caller, Entry_Caller_Sleep); + end Wakeup_Entry_Caller; + + ----------------------- + -- Restricted GNARLI -- + ----------------------- + + -------------------------------------------- + -- Exceptional_Complete_Single_Entry_Body -- + -------------------------------------------- + + procedure Exceptional_Complete_Single_Entry_Body + (Object : Protection_Entry_Access; + Ex : Ada.Exceptions.Exception_Id) + is + begin + Object.Call_In_Progress.Exception_To_Raise := Ex; + end Exceptional_Complete_Single_Entry_Body; + + --------------------------------- + -- Initialize_Protection_Entry -- + --------------------------------- + + procedure Initialize_Protection_Entry + (Object : Protection_Entry_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Body : Entry_Body_Access) + is + begin + Initialize_Protection (Object.Common'Access, Ceiling_Priority); + + Object.Compiler_Info := Compiler_Info; + Object.Call_In_Progress := null; + Object.Entry_Body := Entry_Body; + Object.Entry_Queue := null; + end Initialize_Protection_Entry; + + ---------------- + -- Lock_Entry -- + ---------------- + + -- Compiler interface only + + -- Do not call this procedure from within the run-time system. + + procedure Lock_Entry (Object : Protection_Entry_Access) is + begin + Lock (Object.Common'Access); + end Lock_Entry; + + -------------------------- + -- Lock_Read_Only_Entry -- + -------------------------- + + -- Compiler interface only + + -- Do not call this procedure from within the runtime system + + procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is + begin + Lock_Read_Only (Object.Common'Access); + end Lock_Read_Only_Entry; + + -------------------- + -- PO_Do_Or_Queue -- + -------------------- + + procedure PO_Do_Or_Queue + (Object : Protection_Entry_Access; + Entry_Call : Entry_Call_Link) + is + Barrier_Value : Boolean; + + begin + -- When the Action procedure for an entry body returns, it must be + -- completed (having called [Exceptional_]Complete_Entry_Body). + + Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1); + + if Barrier_Value then + if Object.Call_In_Progress /= null then + + -- This violates the No_Entry_Queue restriction, send + -- Program_Error to the caller. + + Send_Program_Error (Entry_Call); + return; + end if; + + Object.Call_In_Progress := Entry_Call; + Object.Entry_Body.Action + (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); + Object.Call_In_Progress := null; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + Wakeup_Entry_Caller (Entry_Call); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + else + pragma Assert (Entry_Call.Mode = Simple_Call); + + if Object.Entry_Queue /= null then + + -- This violates the No_Entry_Queue restriction, send + -- Program_Error to the caller. + + Send_Program_Error (Entry_Call); + return; + else + Object.Entry_Queue := Entry_Call; + end if; + + end if; + + exception + when others => + Send_Program_Error (Entry_Call); + end PO_Do_Or_Queue; + + ---------------------------- + -- Protected_Single_Count -- + ---------------------------- + + function Protected_Count_Entry (Object : Protection_Entry) return Natural is + begin + if Object.Entry_Queue /= null then + return 1; + else + return 0; + end if; + end Protected_Count_Entry; + + --------------------------------- + -- Protected_Single_Entry_Call -- + --------------------------------- + + procedure Protected_Single_Entry_Call + (Object : Protection_Entry_Access; + Uninterpreted_Data : System.Address) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); + begin + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + Lock_Entry (Object); + + Entry_Call.Mode := Simple_Call; + Entry_Call.State := Now_Abortable; + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + + PO_Do_Or_Queue (Object, Entry_Call'Access); + Unlock_Entry (Object); + + -- The call is either `Done' or not. It cannot be cancelled since there + -- is no ATC construct. + + pragma Assert (Entry_Call.State /= Cancelled); + + if Entry_Call.State /= Done then + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + Wait_For_Completion (Entry_Call'Access); + STPO.Unlock (Self_Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + + Check_Exception (Self_Id, Entry_Call'Access); + end Protected_Single_Entry_Call; + + ----------------------------------- + -- Protected_Single_Entry_Caller -- + ----------------------------------- + + function Protected_Single_Entry_Caller + (Object : Protection_Entry) return Task_Id + is + begin + return Object.Call_In_Progress.Self; + end Protected_Single_Entry_Caller; + + ------------------- + -- Service_Entry -- + ------------------- + + procedure Service_Entry (Object : Protection_Entry_Access) is + Entry_Call : constant Entry_Call_Link := Object.Entry_Queue; + Caller : Task_Id; + + begin + if Entry_Call /= null + and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1) + then + Object.Entry_Queue := null; + + if Object.Call_In_Progress /= null then + + -- Violation of No_Entry_Queue restriction, raise exception + + Send_Program_Error (Entry_Call); + Unlock_Entry (Object); + return; + end if; + + Object.Call_In_Progress := Entry_Call; + Object.Entry_Body.Action + (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); + Object.Call_In_Progress := null; + Caller := Entry_Call.Self; + Unlock_Entry (Object); + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Wakeup_Entry_Caller (Entry_Call); + STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + else + -- Just unlock the entry + + Unlock_Entry (Object); + end if; + + exception + when others => + Send_Program_Error (Entry_Call); + Unlock_Entry (Object); + end Service_Entry; + + ------------------ + -- Unlock_Entry -- + ------------------ + + procedure Unlock_Entry (Object : Protection_Entry_Access) is + begin + Unlock (Object.Common'Access); + end Unlock_Entry; + +end System.Tasking.Protected_Objects.Single_Entry; diff --git a/gcc/ada/libgnarl/s-tposen.ads b/gcc/ada/libgnarl/s-tposen.ads new file mode 100644 index 00000000000..625cdfc30de --- /dev/null +++ b/gcc/ada/libgnarl/s-tposen.ads @@ -0,0 +1,278 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- +-- -- +-- 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an optimized version of Protected_Objects.Operations +-- and Protected_Objects.Entries making the following assumptions: + +-- PO have only one entry +-- There is only one caller at a time (No_Entry_Queue) +-- There is no dynamic priority support (No_Dynamic_Priorities) +-- No Abort Statements +-- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) +-- PO are at library level +-- None of the tasks will terminate (no need for finalization) + +-- This interface is intended to be used in the Ravenscar profile, the +-- compiler is responsible for ensuring that the conditions mentioned above +-- are respected, except for the No_Entry_Queue restriction that is checked +-- dynamically in this package, since the check cannot be performed at compile +-- time, and is relatively cheap (see body). + +-- This package is part of the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls +-- (aka GNARLI, GNU Ada Run-time Library Interface) + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes +-- in exp_ch9.adb and possibly exp_ch7.adb + +package System.Tasking.Protected_Objects.Single_Entry is + pragma Elaborate_Body; + + --------------------------------- + -- Compiler Interface (GNARLI) -- + --------------------------------- + + -- The compiler will expand in the GNAT tree the following construct: + + -- protected PO is + -- entry E; + -- procedure P; + -- private + -- Open : Boolean := False; + -- end PO; + + -- protected body PO is + -- entry E when Open is + -- ...variable declarations... + -- begin + -- ...B... + -- end E; + + -- procedure P is + -- ...variable declarations... + -- begin + -- ...C... + -- end P; + -- end PO; + + -- as follows: + + -- protected type poT is + -- entry e; + -- procedure p; + -- private + -- open : boolean := false; + -- end poT; + -- type poTV is limited record + -- open : boolean := false; + -- _object : aliased protection_entry; + -- end record; + -- procedure poPT__E1s (O : address; P : address; E : + -- protected_entry_index); + -- function poPT__B2s (O : address; E : protected_entry_index) return + -- boolean; + -- procedure poPT__pN (_object : in out poTV); + -- procedure poPT__pP (_object : in out poTV); + -- poTA : aliased entry_body := ( + -- barrier => poPT__B2s'unrestricted_access, + -- action => poPT__E1s'unrestricted_access); + -- freeze poTV [ + -- procedure poTVIP (_init : in out poTV) is + -- begin + -- _init.open := false; + -- object-init-proc (_init._object); + -- initialize_protection_entry (_init._object'unchecked_access, + -- unspecified_priority, _init'address, poTA' + -- unrestricted_access); + -- return; + -- end poTVIP; + -- ] + -- po : poT; + -- poTVIP (poTV!(po)); + + -- function poPT__B2s (O : address; E : protected_entry_index) return + -- boolean is + -- type poTVP is access poTV; + -- _object : poTVP := poTVP!(O); + -- poR : protection_entry renames _object._object; + -- openP : boolean renames _object.open; + -- begin + -- return open; + -- end poPT__B2s; + + -- procedure poPT__E1s (O : address; P : address; E : + -- protected_entry_index) is + -- type poTVP is access poTV; + -- _object : poTVP := poTVP!(O); + -- begin + -- B1b : declare + -- poR : protection_entry renames _object._object; + -- openP : boolean renames _object.open; + -- ...variable declarations... + -- begin + -- ...B... + -- end B1b; + -- complete_single_entry_body (_object._object'unchecked_access); + -- return; + -- exception + -- when all others => + -- exceptional_complete_single_entry_body (_object._object' + -- unchecked_access, get_gnat_exception); + -- return; + -- end poPT__E1s; + + -- procedure poPT__pN (_object : in out poTV) is + -- poR : protection_entry renames _object._object; + -- openP : boolean renames _object.open; + -- ...variable declarations... + -- begin + -- ...C... + -- return; + -- end poPT__pN; + + -- procedure poPT__pP (_object : in out poTV) is + -- procedure _clean is + -- begin + -- service_entry (_object._object'unchecked_access); + -- return; + -- end _clean; + -- begin + -- lock_entry (_object._object'unchecked_access); + -- B5b : begin + -- poPT__pN (_object); + -- at end + -- _clean; + -- end B5b; + -- return; + -- end poPT__pP; + + type Protection_Entry is limited private; + -- This type contains the GNARL state of a protected object. The + -- application-defined portion of the state (i.e. private objects) + -- is maintained by the compiler-generated code. + + type Protection_Entry_Access is access all Protection_Entry; + + type Entry_Body_Access is access constant Entry_Body; + -- Access to barrier and action function of an entry + + procedure Initialize_Protection_Entry + (Object : Protection_Entry_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Body : Entry_Body_Access); + -- Initialize the Object parameter so that it can be used by the run time + -- to keep track of the runtime state of a protected object. + + procedure Lock_Entry (Object : Protection_Entry_Access); + -- Lock a protected object for write access. Upon return, the caller owns + -- the lock to this object, and no other call to Lock or Lock_Read_Only + -- with the same argument will return until the corresponding call to + -- Unlock has been made by the caller. + + procedure Lock_Read_Only_Entry + (Object : Protection_Entry_Access); + -- Lock a protected object for read access. Upon return, the caller owns + -- the lock for read access, and no other calls to Lock with the same + -- argument will return until the corresponding call to Unlock has been + -- made by the caller. Other calls to Lock_Read_Only may (but need not) + -- return before the call to Unlock, and the corresponding callers will + -- also own the lock for read access. + + procedure Unlock_Entry (Object : Protection_Entry_Access); + -- Relinquish ownership of the lock for the object represented by the + -- Object parameter. If this ownership was for write access, or if it was + -- for read access where there are no other read access locks outstanding, + -- one (or more, in the case of Lock_Read_Only) of the tasks waiting on + -- this lock (if any) will be given the lock and allowed to return from + -- the Lock or Lock_Read_Only call. + + procedure Service_Entry (Object : Protection_Entry_Access); + -- Service the entry queue of the specified object, executing the + -- corresponding body of any queued entry call that is waiting on True + -- barrier. This is used when the state of a protected object may have + -- changed, in particular after the execution of the statement sequence + -- of a protected procedure. + -- + -- This must be called with abort deferred and with the corresponding + -- object locked. Object is unlocked on return. + + procedure Protected_Single_Entry_Call + (Object : Protection_Entry_Access; + Uninterpreted_Data : System.Address); + -- Make a protected entry call to the specified object + -- + -- Pends a protected entry call on the protected object represented by + -- Object. A pended call is not queued; it may be executed immediately + -- or queued, depending on the state of the entry barrier. + -- + -- Uninterpreted_Data + -- This will be returned by Next_Entry_Call when this call is serviced. + -- It can be used by the compiler to pass information between the + -- caller and the server, in particular entry parameters. + + procedure Exceptional_Complete_Single_Entry_Body + (Object : Protection_Entry_Access; + Ex : Ada.Exceptions.Exception_Id); + -- Perform all of the functions of Complete_Entry_Body. In addition, report + -- in Ex the exception whose propagation terminated the entry body to the + -- runtime system. + + function Protected_Count_Entry (Object : Protection_Entry) return Natural; + -- Return the number of entry calls on Object (0 or 1) + + function Protected_Single_Entry_Caller + (Object : Protection_Entry) return Task_Id; + -- Return value of E'Caller, where E is the protected entry currently being + -- handled. This will only work if called from within an entry body, as + -- required by the LRM (C.7.1(14)). + +private + type Protection_Entry is record + Common : aliased Protection; + -- State of the protected object. This part is common to any protected + -- object, including those without entries. + + Compiler_Info : System.Address; + -- Pointer to compiler-generated record representing protected object + + Call_In_Progress : Entry_Call_Link; + -- Pointer to the entry call being executed (if any) + + Entry_Body : Entry_Body_Access; + -- Pointer to executable code for the entry body of the protected type + + Entry_Queue : Entry_Call_Link; + -- Place to store the waiting entry call (if any) + end record; + +end System.Tasking.Protected_Objects.Single_Entry; 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-vxwext.adb b/gcc/ada/libgnarl/s-vxwext.adb new file mode 100644 index 00000000000..332d979cb54 --- /dev/null +++ b/gcc/ada/libgnarl/s-vxwext.adb @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks 5 and VxWorks MILS version of this package + +package body System.VxWorks.Ext is + + ERROR : constant := -1; + + ------------------------ + -- 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.ads b/gcc/ada/libgnarl/s-vxwext.ads new file mode 100644 index 00000000000..860cdac84ea --- /dev/null +++ b/gcc/ada/libgnarl/s-vxwext.ads @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 5 and VxWorks MILS 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 Import (C, Int_Lock, "intLock"); + + function Int_Unlock (Old : int) return int; + pragma Import (C, Int_Unlock, "intUnlock"); + + 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 Import (C, semDelete, "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"); + + -------------------------------- + -- 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 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; diff --git a/gcc/ada/libgnarl/thread.c b/gcc/ada/libgnarl/thread.c new file mode 100644 index 00000000000..5d616505861 --- /dev/null +++ b/gcc/ada/libgnarl/thread.c @@ -0,0 +1,88 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * P T H R E A D * + * * + * C Implementation File * + * * + * Copyright (C) 2011-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 file provides utility functions to access the threads API */ + +#include "s-oscons.h" + +/* If the clock we used for tasking (CLOCK_RT_Ada) is not the default + * CLOCK_REALTIME, we need to set cond var attributes accordingly. + */ +#if CLOCK_RT_Ada != CLOCK_REALTIME +# include +# include + +int +__gnat_pthread_condattr_setup(pthread_condattr_t *attr) { + return pthread_condattr_setclock (attr, CLOCK_RT_Ada); +} + +#else + +int +__gnat_pthread_condattr_setup (void *attr) { + /* Dummy version for other platforms, which may or may not have pthread.h */ + return 0; +} + +#endif + +#if defined (__APPLE__) +#include +#include +#endif + +/* Return the clock ticks per nanosecond for Posix systems lacking the + Posix extension function clock_getres, or else 0 nsecs on error. */ + +int +__gnat_clock_get_res (void) +{ +#if defined (__APPLE__) + clock_serv_t clock_port; + mach_msg_type_number_t count; + int nsecs; + int result; + + count = 1; + result = host_get_clock_service + (mach_host_self (), SYSTEM_CLOCK, &clock_port); + + if (result == KERN_SUCCESS) + result = clock_get_attributes (clock_port, CLOCK_GET_TIME_RES, + (clock_attr_t) &nsecs, &count); + + if (result == KERN_SUCCESS) + return nsecs; +#endif + + return 0; +} diff --git a/gcc/ada/s-inmaop-dummy.adb b/gcc/ada/s-inmaop-dummy.adb deleted file mode 100644 index 080550abec3..00000000000 --- a/gcc/ada/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-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. -- --- -- ------------------------------------------------------------------------------- - --- 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/s-inmaop-posix.adb b/gcc/ada/s-inmaop-posix.adb deleted file mode 100644 index c76f4f0a3ca..00000000000 --- a/gcc/ada/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-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 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/s-inmaop-vxworks.adb b/gcc/ada/s-inmaop-vxworks.adb deleted file mode 100644 index 84b1801b8eb..00000000000 --- a/gcc/ada/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-1994, Florida State University -- --- Copyright (C) 1995-2011, 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/s-inmaop.ads b/gcc/ada/s-inmaop.ads deleted file mode 100644 index 78d2dcbe9f4..00000000000 --- a/gcc/ada/s-inmaop.ads +++ /dev/null @@ -1,125 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - -package System.Interrupt_Management.Operations is - - procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID); - pragma Inline (Thread_Block_Interrupt); - -- Mask the calling thread for the interrupt - - procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID); - pragma Inline (Thread_Unblock_Interrupt); - -- Unmask the calling thread for the interrupt - - procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask); - -- Set the interrupt mask of the calling thread - - procedure Set_Interrupt_Mask - (Mask : access Interrupt_Mask; - OMask : access Interrupt_Mask); - pragma Inline (Set_Interrupt_Mask); - -- Set the interrupt mask of the calling thread while returning the - -- previous Mask. - - procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask); - pragma Inline (Get_Interrupt_Mask); - -- Get the interrupt mask of the calling thread - - function Interrupt_Wait (Mask : access Interrupt_Mask) return Interrupt_ID; - pragma Inline (Interrupt_Wait); - -- Wait for the interrupts specified in Mask and return - -- the interrupt received. Return 0 upon error. - - procedure Install_Default_Action (Interrupt : Interrupt_ID); - pragma Inline (Install_Default_Action); - -- Set the sigaction of the Interrupt to default (SIG_DFL) - - procedure Install_Ignore_Action (Interrupt : Interrupt_ID); - pragma Inline (Install_Ignore_Action); - -- Set the sigaction of the Interrupt to ignore (SIG_IGN) - - procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask); - pragma Inline (Fill_Interrupt_Mask); - -- Get a Interrupt_Mask with all the interrupt masked - - procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask); - pragma Inline (Empty_Interrupt_Mask); - -- Get a Interrupt_Mask with all the interrupt unmasked - - procedure Add_To_Interrupt_Mask - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID); - pragma Inline (Add_To_Interrupt_Mask); - -- Mask the given interrupt in the Interrupt_Mask - - procedure Delete_From_Interrupt_Mask - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID); - pragma Inline (Delete_From_Interrupt_Mask); - -- Unmask the given interrupt in the Interrupt_Mask - - function Is_Member - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID) return Boolean; - pragma Inline (Is_Member); - -- See if a given interrupt is masked in the Interrupt_Mask - - procedure Copy_Interrupt_Mask (X : out Interrupt_Mask; Y : Interrupt_Mask); - pragma Inline (Copy_Interrupt_Mask); - -- Assignment needed for limited private type Interrupt_Mask - - procedure Interrupt_Self_Process (Interrupt : Interrupt_ID); - pragma Inline (Interrupt_Self_Process); - -- Raise an Interrupt process-level - - procedure Setup_Interrupt_Mask; - -- Mask Environment task for all signals - -- This function should be called by the elaboration of System.Interrupt - -- to set up proper signal masking in all tasks. - - -- The following objects serve as constants, but are initialized in the - -- body to aid portability. These should be in System.Interrupt_Management - -- but since Interrupt_Mask is private type we cannot have them declared - -- there. - - -- Why not make these deferred constants that are initialized using - -- function calls in the private part??? - - Environment_Mask : aliased Interrupt_Mask; - -- This mask represents the mask of Environment task when this package is - -- being elaborated, except the signals being forced to be unmasked by RTS - -- (items in Keep_Unmasked) - - All_Tasks_Mask : aliased Interrupt_Mask; - -- This is the mask of all tasks created in RTS. Only one task in RTS - -- is responsible for masking/unmasking signals (see s-interr.adb). - -end System.Interrupt_Management.Operations; diff --git a/gcc/ada/s-interr-dummy.adb b/gcc/ada/s-interr-dummy.adb deleted file mode 100644 index 87ed21d0367..00000000000 --- a/gcc/ada/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-1994, Florida State University -- --- Copyright (C) 1995-2013, 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/s-interr-hwint.adb b/gcc/ada/s-interr-hwint.adb deleted file mode 100644 index 8e2950f30fb..00000000000 --- a/gcc/ada/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/s-interr-sigaction.adb b/gcc/ada/s-interr-sigaction.adb deleted file mode 100644 index 2e646a20422..00000000000 --- a/gcc/ada/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-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 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/s-interr-vxworks.adb b/gcc/ada/s-interr-vxworks.adb deleted file mode 100644 index 32fba6008af..00000000000 --- a/gcc/ada/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-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. -- --- -- ------------------------------------------------------------------------------- - --- 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/s-interr.adb b/gcc/ada/s-interr.adb deleted file mode 100644 index a88b643784f..00000000000 --- a/gcc/ada/s-interr.adb +++ /dev/null @@ -1,1472 +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-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. -- --- -- ------------------------------------------------------------------------------- - --- Invariants: - --- All user-handleable interrupts are masked at all times in all tasks/threads --- except possibly for the Interrupt_Manager task. - --- When a user task wants to achieve masking/unmasking an interrupt, it must --- call Block_Interrupt/Unblock_Interrupt, which will have the effect of --- unmasking/masking the interrupt in the Interrupt_Manager task. - --- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any --- other low-level interface that changes the interrupt action or --- interrupt mask needs a careful thought. - --- One may achieve the effect of system calls first masking RTS blocked --- (by calling Block_Interrupt) for the interrupt under consideration. --- This will make all the tasks in RTS blocked for the Interrupt. - --- Once we associate a Server_Task with an interrupt, the task never goes --- away, and we never remove the association. - --- There is no more than one interrupt per Server_Task and no more than one --- Server_Task per interrupt. - -with Ada.Exceptions; -with Ada.Task_Identification; - -with System.Task_Primitives; -with System.Interrupt_Management; - -with System.Interrupt_Management.Operations; -pragma Elaborate_All (System.Interrupt_Management.Operations); - -with System.IO; - -with System.Task_Primitives.Operations; -with System.Task_Primitives.Interrupt_Operations; -with System.Storage_Elements; -with System.Tasking.Utilities; - -with System.Tasking.Rendezvous; -pragma Elaborate_All (System.Tasking.Rendezvous); - -with System.Tasking.Initialization; -with System.Parameters; - -with Ada.Unchecked_Conversion; - -package body System.Interrupts is - - use Parameters; - use Tasking; - - package POP renames System.Task_Primitives.Operations; - package PIO renames System.Task_Primitives.Interrupt_Operations; - package IMNG renames System.Interrupt_Management; - package IMOP renames System.Interrupt_Management.Operations; - - 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 Initialize (Mask : IMNG.Interrupt_Mask); - - 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); - - entry Block_Interrupt (Interrupt : Interrupt_ID); - - entry Unblock_Interrupt (Interrupt : Interrupt_ID); - - entry Ignore_Interrupt (Interrupt : Interrupt_ID); - - entry Unignore_Interrupt (Interrupt : Interrupt_ID); - - pragma Interrupt_Priority (System.Interrupt_Priority'Last); - end Interrupt_Manager; - - task type Server_Task (Interrupt : Interrupt_ID) is - pragma Priority (System.Interrupt_Priority'Last); - -- Note: the above pragma Priority is strictly speaking improper since - -- it is outside the range of allowed priorities, but the compiler - -- treats system units specially and does not apply this range checking - -- rule to system units. - - end Server_Task; - - type Server_Task_Access is access 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'Range) 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. A handler is a Static one if it is - -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise, - -- not static) - - User_Entry : array (Interrupt_ID'Range) 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 - - Blocked : array (Interrupt_ID'Range) of Boolean := (others => False); - pragma Atomic_Components (Blocked); - -- True iff the corresponding interrupt is blocked in the process level - - Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); - pragma Atomic_Components (Ignored); - -- True iff the corresponding interrupt is blocked in the process level - - Last_Unblocker : - array (Interrupt_ID'Range) of Task_Id := (others => Null_Task); - pragma Atomic_Components (Last_Unblocker); - -- Holds the ID of the last Task which Unblocked this Interrupt. It - -- contains Null_Task if no tasks have ever requested the Unblocking - -- operation or the Interrupt is currently Blocked. - - Server_ID : array (Interrupt_ID'Range) of Task_Id := - (others => Null_Task); - pragma Atomic_Components (Server_ID); - -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is - -- needed to accomplish locking per Interrupt base. Also is needed to - -- decide whether to create a new Server_Task. - - -- 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; - - Access_Hold : Server_Task_Access; - -- Variable used to allocate Server_Task using "new" - - ----------------------- - -- Local Subprograms -- - ----------------------- - - 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. - - -------------------- - -- 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 - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - 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 - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); - end Bind_Interrupt_To_Entry; - - --------------------- - -- Block_Interrupt -- - --------------------- - - procedure Block_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Block_Interrupt (Interrupt); - end Block_Interrupt; - - --------------------- - -- Current_Handler -- - --------------------- - - function Current_Handler - (Interrupt : Interrupt_ID) return Parameterless_Handler - is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - -- ??? 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 - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - 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. 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 - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static); - end Exchange_Handler; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Static_Interrupt_Protection) is - function State - (Int : System.Interrupt_Management.Interrupt_ID) return Character; - pragma Import (C, State, "__gnat_get_interrupt_state"); - -- Get interrupt state for interrupt number Int. Defined in init.c - - Default : constant Character := 's'; - -- 's' Interrupt_State pragma set state to System (use "default" - -- system handler) - - begin - -- ??? loop to be executed only when we're not doing library level - -- finalization, since in this case all interrupt tasks are gone. - - -- If the Abort_Task signal is set to system, it means that we cannot - -- reset interrupt handlers since this would require sending the abort - -- signal to the Server_Task - - if not Interrupt_Manager'Terminated - and then - State (System.Interrupt_Management.Abort_Task_Interrupt) /= Default - 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; - - ------------------------------------- - -- Has_Interrupt_Or_Attach_Handler -- - ------------------------------------- - - -- Need comments as to why these always return True ??? - - 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 - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Ignore_Interrupt (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; - - ---------------- - -- Is_Blocked -- - ---------------- - - function Is_Blocked (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 Blocked (Interrupt); - end Is_Blocked; - - ----------------------- - -- 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 User_Entry (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"; - end if; - - return User_Handler (Interrupt).H /= null; - end Is_Handler_Attached; - - ---------------- - -- Is_Ignored -- - ---------------- - - function Is_Ignored (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 Ignored (Interrupt); - 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 - begin - return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); - end Is_Reserved; - - --------------- - -- Reference -- - --------------- - - function Reference (Interrupt : Interrupt_ID) return System.Address is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - 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 the Handler as usable for Dynamic Interrupt - -- Handler. Routines attaching and detaching Handler dynamically should - -- first consult if the Handler is registered. A Program Error should - -- be raised if it is not registered. - - -- The pragma Interrupt_Handler can only appear in the library level PO - -- definition and instantiation. Therefore, we do not need to implement - -- Unregistering operation. Neither we need to protect the queue - -- structure using 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 - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Unblock_Interrupt (Interrupt); - end Unblock_Interrupt; - - ------------------ - -- Unblocked_By -- - ------------------ - - function Unblocked_By - (Interrupt : Interrupt_ID) return System.Tasking.Task_Id - is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - return Last_Unblocker (Interrupt); - end Unblocked_By; - - ------------------------ - -- Unignore_Interrupt -- - ------------------------ - - procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Unignore_Interrupt (Interrupt); - end Unignore_Interrupt; - - ----------------------- - -- Interrupt_Manager -- - ----------------------- - - task body Interrupt_Manager is - -- By making this task independent of master, when the process - -- goes away, the Interrupt_Manager will terminate gracefully. - - Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; - - --------------------- - -- Local Variables -- - --------------------- - - Intwait_Mask : aliased IMNG.Interrupt_Mask; - Ret_Interrupt : Interrupt_ID; - Old_Mask : aliased IMNG.Interrupt_Mask; - Old_Handler : Parameterless_Handler; - - -------------------- - -- Local Routines -- - -------------------- - - procedure Bind_Handler (Interrupt : Interrupt_ID); - -- This procedure does not do anything if the Interrupt is blocked. - -- Otherwise, we have to interrupt Server_Task for status change through - -- Wakeup interrupt. - - procedure Unbind_Handler (Interrupt : Interrupt_ID); - -- This procedure does not do anything if the Interrupt is blocked. - -- Otherwise, we have to interrupt Server_Task for status change - -- through abort interrupt. - - 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 - if not Blocked (Interrupt) then - - -- Mask this task for the given Interrupt so that all tasks - -- are masked for the Interrupt and the actual delivery of the - -- Interrupt will be caught using "sigwait" by the - -- corresponding Server_Task. - - IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt)); - - -- We have installed a Handler or an Entry before we called - -- this procedure. If the Handler Task is waiting to be awakened, - -- do it here. Otherwise, the interrupt will be discarded. - - POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep); - end if; - end Bind_Handler; - - -------------------- - -- Unbind_Handler -- - -------------------- - - procedure Unbind_Handler (Interrupt : Interrupt_ID) is - Server : System.Tasking.Task_Id; - - begin - if not Blocked (Interrupt) then - - -- Currently, there is a Handler or an Entry attached and - -- corresponding Server_Task is waiting on "sigwait." We have to - -- wake up the Server_Task and make it wait on condition variable - -- by sending an Abort_Task_Interrupt - - Server := Server_ID (Interrupt); - - case Server.Common.State is - when Interrupt_Server_Blocked_Interrupt_Sleep - | Interrupt_Server_Idle_Sleep - => - POP.Wakeup (Server, Server.Common.State); - - when Interrupt_Server_Blocked_On_Event_Flag => - POP.Abort_Task (Server); - - -- Make sure corresponding Server_Task is out of its - -- own sigwait state. - - Ret_Interrupt := - Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); - pragma Assert - (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt)); - - when Runnable => - null; - - when others => - pragma Assert (False); - null; - end case; - - IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); - - -- Unmake the Interrupt for this task in order to allow default - -- action again. - - IMOP.Thread_Unblock_Interrupt (IMNG.Interrupt_ID (Interrupt)); - - else - IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); - end if; - 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 - - -- In case we have an Interrupt Entry installed, raise a 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. That 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 - - -- Tries to detach a static Interrupt Handler. - -- raise a program error. - - raise Program_Error with - "trying to detach a static interrupt handler"; - end if; - - -- The interrupt should no longer be ignored if - -- it was ever ignored. - - Ignored (Interrupt) := False; - - 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 - - -- 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"; - end if; - - -- Note : A null handler with Static = True will pass the following - -- check. That is the case when we want to Detach a handler - -- regardless of the Static status of the 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 - - -- Tries to overwrite a static Interrupt Handler with a dynamic - -- Handler - - and then (User_Handler (Interrupt).Static - - -- 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; - - -- The interrupt should no longer be ignored if - -- it was ever ignored. - - Ignored (Interrupt) := False; - - -- 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 Server_ID (Interrupt) = Null_Task then - - -- When a new Server_Task is created, it should have its - -- signal mask set to the All_Tasks_Mask. - - IMOP.Set_Interrupt_Mask - (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); - Access_Hold := new Server_Task (Interrupt); - IMOP.Set_Interrupt_Mask (Old_Mask'Access); - - Server_ID (Interrupt) := To_System (Access_Hold.all'Identity); - end if; - - if New_Handler = null then - if Old_Handler /= null then - Unbind_Handler (Interrupt); - end if; - - return; - end if; - - if Old_Handler = null then - Bind_Handler (Interrupt); - end if; - end Unprotected_Exchange_Handler; - - -- Start of processing for Interrupt_Manager - - begin - -- Environment task gets its own interrupt mask, saves it, and then - -- masks all interrupts except the Keep_Unmasked set. - - -- During rendezvous, the Interrupt_Manager receives the old interrupt - -- mask of the environment task, and sets its own interrupt mask to that - -- value. - - -- The environment task will call the entry of Interrupt_Manager some - -- during elaboration of the body of this package. - - accept Initialize (Mask : IMNG.Interrupt_Mask) do - declare - The_Mask : aliased IMNG.Interrupt_Mask; - begin - IMOP.Copy_Interrupt_Mask (The_Mask, Mask); - IMOP.Set_Interrupt_Mask (The_Mask'Access); - end; - end Initialize; - - -- Note: All tasks in RTS will have all the Reserve Interrupts being - -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked - -- when created. - - -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks. - -- We mask the Interrupt in this particular task so that "sigwait" is - -- possible to catch an explicitly sent Abort_Task_Interrupt from the - -- Server_Tasks. - - -- This sigwaiting is needed so that we make sure a Server_Task is out - -- of its own sigwait state. This extra synchronization is necessary to - -- prevent following scenarios. - - -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the - -- Server_Task then changes its own interrupt mask (OS level). - -- If an interrupt (corresponding to the Server_Task) arrives - -- in the mean time we have the Interrupt_Manager unmasked and - -- the Server_Task waiting on sigwait. - - -- 2) For unbinding handler, we install a default action in the - -- Interrupt_Manager. POSIX.1c states that the result of using - -- "sigwait" and "sigaction" simultaneously on the same interrupt - -- is undefined. Therefore, we need to be informed from the - -- Server_Task of the fact that the Server_Task is out of its - -- sigwait stage. - - IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); - IMOP.Add_To_Interrupt_Mask - (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt); - IMOP.Thread_Block_Interrupt - (IMNG.Abort_Task_Interrupt); - - loop - -- A block is needed to absorb Program_Error exception - - 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; - - -- The interrupt should no longer be ignored if - -- it was ever ignored. - - Ignored (Interrupt) := False; - User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); - - -- Indicate the attachment of Interrupt Entry in ATCB. - -- This is need so that when an Interrupt Entry task - -- terminates the binding can be cleaned. The call to - -- unbinding must be made 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 then - - -- When a new Server_Task is created, it should have its - -- signal mask set to the All_Tasks_Mask. - - IMOP.Set_Interrupt_Mask - (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); - Access_Hold := new Server_Task (Interrupt); - IMOP.Set_Interrupt_Mask (Old_Mask'Access); - Server_ID (Interrupt) := - To_System (Access_Hold.all'Identity); - end if; - - Bind_Handler (Interrupt); - end Bind_Interrupt_To_Entry; - - or - accept Detach_Interrupt_Entries (T : Task_Id) do - for J in Interrupt_ID'Range loop - if not Is_Reserved (J) then - if User_Entry (J).T = T then - - -- The interrupt should no longer be ignored if - -- it was ever ignored. - - Ignored (J) := False; - User_Entry (J) := Entry_Assoc' - (T => Null_Task, E => Null_Task_Entry); - Unbind_Handler (J); - end if; - end if; - end loop; - - -- Indicate in ATCB that no Interrupt Entries are attached - - T.Interrupt_Entry := False; - end Detach_Interrupt_Entries; - - or - accept Block_Interrupt (Interrupt : Interrupt_ID) do - if Blocked (Interrupt) then - return; - end if; - - Blocked (Interrupt) := True; - Last_Unblocker (Interrupt) := Null_Task; - - -- Mask this task for the given Interrupt so that all tasks - -- are masked for the Interrupt. - - IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt)); - - if User_Handler (Interrupt).H /= null - or else User_Entry (Interrupt).T /= Null_Task - then - -- This is the case where the Server_Task - -- is waiting on"sigwait." Wake it up by sending an - -- Abort_Task_Interrupt so that the Server_Task waits - -- on Cond. - - POP.Abort_Task (Server_ID (Interrupt)); - - -- Make sure corresponding Server_Task is out of its own - -- sigwait state. - - Ret_Interrupt := Interrupt_ID - (IMOP.Interrupt_Wait (Intwait_Mask'Access)); - pragma Assert - (Ret_Interrupt = - Interrupt_ID (IMNG.Abort_Task_Interrupt)); - end if; - end Block_Interrupt; - - or - accept Unblock_Interrupt (Interrupt : Interrupt_ID) do - if not Blocked (Interrupt) then - return; - end if; - - Blocked (Interrupt) := False; - Last_Unblocker (Interrupt) := - To_System (Unblock_Interrupt'Caller); - - if User_Handler (Interrupt).H = null - and then User_Entry (Interrupt).T = Null_Task - then - -- No handler is attached. Unmask the Interrupt so that - -- the default action can be carried out. - - IMOP.Thread_Unblock_Interrupt - (IMNG.Interrupt_ID (Interrupt)); - - else - -- The Server_Task must be waiting on the Cond variable - -- since it was being blocked and an Interrupt Hander or - -- an Entry was there. Wake it up and let it change it - -- place of waiting according to its new state. - - POP.Wakeup (Server_ID (Interrupt), - Interrupt_Server_Blocked_Interrupt_Sleep); - end if; - end Unblock_Interrupt; - - or - accept Ignore_Interrupt (Interrupt : Interrupt_ID) do - if Ignored (Interrupt) then - return; - end if; - - Ignored (Interrupt) := True; - - -- If there is a handler associated with the Interrupt, - -- detach it first. In this way we make sure that the - -- Server_Task is not on sigwait. This is legal since - -- Unignore_Interrupt is to install the default action. - - if User_Handler (Interrupt).H /= null then - Unprotected_Detach_Handler - (Interrupt => Interrupt, Static => True); - - elsif User_Entry (Interrupt).T /= Null_Task then - User_Entry (Interrupt) := Entry_Assoc' - (T => Null_Task, E => Null_Task_Entry); - Unbind_Handler (Interrupt); - end if; - - IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt)); - end Ignore_Interrupt; - - or - accept Unignore_Interrupt (Interrupt : Interrupt_ID) do - Ignored (Interrupt) := False; - - -- If there is a handler associated with the Interrupt, - -- detach it first. In this way we make sure that the - -- Server_Task is not on sigwait. This is legal since - -- Unignore_Interrupt is to install the default action. - - if User_Handler (Interrupt).H /= null then - Unprotected_Detach_Handler - (Interrupt => Interrupt, Static => True); - - elsif User_Entry (Interrupt).T /= Null_Task then - User_Entry (Interrupt) := Entry_Assoc' - (T => Null_Task, E => Null_Task_Entry); - Unbind_Handler (Interrupt); - end if; - - IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); - end Unignore_Interrupt; - 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 X : others => - System.IO.Put_Line ("Exception in Interrupt_Manager"); - System.IO.Put_Line (Ada.Exceptions.Exception_Information (X)); - pragma Assert (False); - end; - end loop; - end Interrupt_Manager; - - ----------------- - -- Server_Task -- - ----------------- - - task body Server_Task is - -- By making this task independent of master, when the process goes - -- away, the Server_Task will terminate gracefully. - - Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; - - Intwait_Mask : aliased IMNG.Interrupt_Mask; - Ret_Interrupt : Interrupt_ID; - Self_ID : constant Task_Id := Self; - Tmp_Handler : Parameterless_Handler; - Tmp_ID : Task_Id; - Tmp_Entry_Index : Task_Entry_Index; - - begin - -- Install default action in system level - - IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); - - -- Note: All tasks in RTS will have all the Reserve Interrupts being - -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked when - -- created. - - -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks. - -- We mask the Interrupt in this particular task so that "sigwait" is - -- possible to catch an explicitly sent Abort_Task_Interrupt from the - -- Interrupt_Manager. - - -- There are two Interrupt interrupts that this task catch through - -- "sigwait." One is the Interrupt this task is designated to catch - -- in order to execute user handler or entry. The other one is - -- the Abort_Task_Interrupt. This interrupt is being sent from the - -- Interrupt_Manager to inform status changes (e.g: become Blocked, - -- Handler or Entry is to be detached). - - -- Prepare a mask to used for sigwait - - IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); - - IMOP.Add_To_Interrupt_Mask - (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt)); - - IMOP.Add_To_Interrupt_Mask - (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt); - - IMOP.Thread_Block_Interrupt - (IMNG.Abort_Task_Interrupt); - - PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID); - - loop - System.Tasking.Initialization.Defer_Abort (Self_ID); - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - - if User_Handler (Interrupt).H = null - and then User_Entry (Interrupt).T = Null_Task - then - -- No Interrupt binding. If there is an interrupt, - -- Interrupt_Manager will take default action. - - Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep; - POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep); - Self_ID.Common.State := Runnable; - - elsif Blocked (Interrupt) then - - -- Interrupt is blocked, stay here, so we won't catch it - - Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep; - POP.Sleep (Self_ID, Interrupt_Server_Blocked_Interrupt_Sleep); - Self_ID.Common.State := Runnable; - - else - -- A Handler or an Entry is installed. At this point all tasks - -- mask for the Interrupt is masked. Catch the Interrupt using - -- sigwait. - - -- This task may wake up from sigwait by receiving an interrupt - -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding - -- a Procedure Handler or an Entry. Or it could be a wake up - -- from status change (Unblocked -> Blocked). If that is not - -- the case, we should execute the attached Procedure or Entry. - - Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - -- Avoid race condition when terminating application and - -- System.Parameters.No_Abort is True. - - if Parameters.No_Abort and then Self_ID.Pending_Action then - Initialization.Do_Pending_Action (Self_ID); - end if; - - Ret_Interrupt := - Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); - Self_ID.Common.State := Runnable; - - if Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt) then - - -- Inform the Interrupt_Manager of wakeup from above sigwait - - POP.Abort_Task (Interrupt_Manager_ID); - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - - else - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - - if Ret_Interrupt /= Interrupt then - - -- On some systems (e.g. recent linux kernels), sigwait - -- may return unexpectedly (with errno set to EINTR). - - null; - - else - -- Even though we have received an Interrupt the status may - -- have changed already before we got the Self_ID lock above - -- Therefore we make sure a Handler or an Entry is still - -- there and make appropriate call. - - -- If there is no calls to make we need to regenerate the - -- Interrupt in order not to lose it. - - if User_Handler (Interrupt).H /= null then - Tmp_Handler := User_Handler (Interrupt).H; - - -- RTS calls should not be made with self being locked - - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - Tmp_Handler.all; - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - - elsif User_Entry (Interrupt).T /= Null_Task then - Tmp_ID := User_Entry (Interrupt).T; - Tmp_Entry_Index := User_Entry (Interrupt).E; - - -- RTS calls should not be made with self being locked - - if Single_Lock then - POP.Unlock_RTS; - end if; - - POP.Unlock (Self_ID); - - System.Tasking.Rendezvous.Call_Simple - (Tmp_ID, Tmp_Entry_Index, System.Null_Address); - - POP.Write_Lock (Self_ID); - - if Single_Lock then - POP.Lock_RTS; - end if; - - else - -- This is a situation that this task wakes up receiving - -- an Interrupt and before it gets the lock the Interrupt - -- is blocked. We do not want to lose the interrupt in - -- this case so we regenerate the Interrupt to process - -- level. - - IMOP.Interrupt_Self_Process - (IMNG.Interrupt_ID (Interrupt)); - end if; - end if; - end if; - end if; - - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - System.Tasking.Initialization.Undefer_Abort (Self_ID); - - if Self_ID.Pending_Action then - Initialization.Do_Pending_Action (Self_ID); - end if; - - -- Undefer abort here to allow a window for this task to be aborted - -- at the time of system shutdown. We also explicitly test for - -- Pending_Action in case System.Parameters.No_Abort is True. - - end loop; - end Server_Task; - --- Elaboration code for package System.Interrupts - -begin - -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent - - Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); - - -- During the elaboration of this package body we want the RTS - -- to inherit the interrupt mask from the Environment Task. - - IMOP.Setup_Interrupt_Mask; - - -- The environment task should have gotten its mask from the enclosing - -- process during the RTS start up. (See processing in s-inmaop.adb). Pass - -- the Interrupt_Mask of the environment task to the Interrupt_Manager. - - -- Note: At this point we know that all tasks are masked for non-reserved - -- signals. Only the Interrupt_Manager will have masks set up differently - -- inheriting the original environment task's mask. - - Interrupt_Manager.Initialize (IMOP.Environment_Mask); -end System.Interrupts; diff --git a/gcc/ada/s-interr.ads b/gcc/ada/s-interr.ads deleted file mode 100644 index e61f3ab9ec9..00000000000 --- a/gcc/ada/s-interr.ads +++ /dev/null @@ -1,278 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T S -- --- -- --- S p e c -- --- -- --- 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. -- --- -- ------------------------------------------------------------------------------- - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes. - --- This package encapsulates the implementation of interrupt or signal --- handlers. It is logically an extension of the body of Ada.Interrupts. It --- is made a child of System to allow visibility of various runtime system --- internal data and operations. - --- See System.Interrupt_Management for core interrupt/signal interfaces - --- These two packages are separated to allow System.Interrupt_Management to be --- used without requiring the whole tasking implementation to be linked and --- elaborated. - -with System.Tasking; -with System.Tasking.Protected_Objects.Entries; -with System.OS_Interface; - -package System.Interrupts is - - pragma Elaborate_Body; - -- Comment needed on why this is here ??? - - ------------------------- - -- Constants and types -- - ------------------------- - - Default_Interrupt_Priority : constant System.Interrupt_Priority := - System.Interrupt_Priority'Last; - -- Default value used when a pragma Interrupt_Handler or Attach_Handler is - -- specified without an Interrupt_Priority pragma, see D.3(10). - - type Ada_Interrupt_ID is range 0 .. System.OS_Interface.Max_Interrupt; - -- Avoid inheritance by Ada.Interrupts.Interrupt_ID of unwanted operations - - type Interrupt_ID is range 0 .. System.OS_Interface.Max_Interrupt; - - subtype System_Interrupt_Id is Interrupt_ID; - -- This synonym is introduced so that the type is accessible through - -- rtsfind, otherwise the name clashes with its homonym in Ada.Interrupts. - - type Parameterless_Handler is access protected procedure; - - ---------------------- - -- General services -- - ---------------------- - - -- Attempt to attach a Handler to an Interrupt to which an Entry is - -- already bound will raise a Program_Error. - - function Is_Reserved (Interrupt : Interrupt_ID) return Boolean; - - function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean; - - function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean; - - function Current_Handler - (Interrupt : Interrupt_ID) return Parameterless_Handler; - - -- Calling the following procedures with New_Handler = null and Static = - -- true means that we want to modify the current handler regardless of the - -- previous handler's binding status. (i.e. we do not care whether it is a - -- dynamic or static handler) - - procedure Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False); - - procedure Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False); - - procedure Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean := False); - - function Reference - (Interrupt : Interrupt_ID) return System.Address; - - -------------------------------- - -- Interrupt Entries Services -- - -------------------------------- - - -- Routines needed for Interrupt Entries - - procedure Bind_Interrupt_To_Entry - (T : System.Tasking.Task_Id; - E : System.Tasking.Task_Entry_Index; - Int_Ref : System.Address); - -- Bind the given interrupt to the given entry. If the interrupt is - -- already bound to another entry, Program_Error will be raised. - - procedure Detach_Interrupt_Entries (T : System.Tasking.Task_Id); - -- This procedure detaches all the Interrupt Entries bound to a task - - ------------------------------ - -- POSIX.5 Signals Services -- - ------------------------------ - - -- Routines needed for POSIX dot5 POSIX_Signals - - procedure Block_Interrupt (Interrupt : Interrupt_ID); - -- Block the Interrupt on the process level - - procedure Unblock_Interrupt (Interrupt : Interrupt_ID); - - function Unblocked_By - (Interrupt : Interrupt_ID) return System.Tasking.Task_Id; - -- It returns the ID of the last Task which Unblocked this Interrupt. - -- It returns Null_Task if no tasks have ever requested the Unblocking - -- operation or the Interrupt is currently Blocked. - - function Is_Blocked (Interrupt : Interrupt_ID) return Boolean; - -- Comment needed ??? - - procedure Ignore_Interrupt (Interrupt : Interrupt_ID); - -- Set the sigaction for the interrupt to SIG_IGN - - procedure Unignore_Interrupt (Interrupt : Interrupt_ID); - -- Comment needed ??? - - function Is_Ignored (Interrupt : Interrupt_ID) return Boolean; - -- Comment needed ??? - - -- Note : Direct calls to sigaction, sigprocmask, thr_sigsetmask, or any - -- other low-level interface that changes the signal action or signal mask - -- needs careful thought. - - -- One may achieve the effect of system calls first making RTS blocked (by - -- calling Block_Interrupt) for the signal under consideration. This will - -- make all the tasks in RTS blocked for the Interrupt. - - ---------------------- - -- Protection Types -- - ---------------------- - - -- Routines and types needed to implement Interrupt_Handler and - -- Attach_Handler. - - -- There are two kinds of protected objects that deal with interrupts: - - -- (1) Only Interrupt_Handler pragmas are used. We need to be able to tell - -- if an Interrupt_Handler applies to a given procedure, so - -- Register_Interrupt_Handler has to be called for all the potential - -- handlers, it should be done by calling Register_Interrupt_Handler with - -- the handler code address. On finalization, which can happen only has - -- part of library level finalization since PO with Interrupt_Handler - -- pragmas can only be declared at library level, nothing special needs to - -- be done since the default handlers have been restored as part of task - -- completion which is done just before global finalization. - -- Dynamic_Interrupt_Protection should be used in this case. - - -- (2) Attach_Handler pragmas are used, and possibly Interrupt_Handler - -- pragma. We need to attach the handlers to the given interrupts when the - -- object is elaborated. This should be done by constructing an array of - -- pairs (interrupt, handler) from the pragmas and calling Install_Handlers - -- with it (types to be used are New_Handler_Item and New_Handler_Array). - -- On finalization, we need to restore the handlers that were installed - -- before the elaboration of the PO, so we need to store these previous - -- handlers. This is also done by Install_Handlers, the room for this - -- information is provided by adding a discriminant which is the number - -- of Attach_Handler pragmas and an array of this size in the protection - -- type, Static_Interrupt_Protection. - - procedure Register_Interrupt_Handler - (Handler_Addr : System.Address); - -- This routine should be called by the compiler to allow the handler be - -- used as an Interrupt Handler. That means call this procedure for each - -- pragma Interrupt_Handler providing the address of the handler (not - -- including the pointer to the actual PO, this way this routine is called - -- only once for each type definition of PO). - - type Static_Handler_Index is range 0 .. Integer'Last; - subtype Positive_Static_Handler_Index is - Static_Handler_Index range 1 .. Static_Handler_Index'Last; - -- Comment needed ??? - - type Previous_Handler_Item is record - Interrupt : Interrupt_ID; - Handler : Parameterless_Handler; - Static : Boolean; - end record; - -- Contains all the information needed to restore a previous handler - - type Previous_Handler_Array is array - (Positive_Static_Handler_Index range <>) of Previous_Handler_Item; - - type New_Handler_Item is record - Interrupt : Interrupt_ID; - Handler : Parameterless_Handler; - end record; - -- Contains all the information from an Attach_Handler pragma - - type New_Handler_Array is - array (Positive_Static_Handler_Index range <>) of New_Handler_Item; - -- Comment needed ??? - - -- Case (1) - - type Dynamic_Interrupt_Protection is new - Tasking.Protected_Objects.Entries.Protection_Entries with null record; - - -- ??? Finalize is not overloaded since we currently have no - -- way to detach the handlers during library level finalization. - - function Has_Interrupt_Or_Attach_Handler - (Object : access Dynamic_Interrupt_Protection) return Boolean; - -- Returns True - - -- Case (2) - - type Static_Interrupt_Protection - (Num_Entries : Tasking.Protected_Objects.Protected_Entry_Index; - Num_Attach_Handler : Static_Handler_Index) - is new - Tasking.Protected_Objects.Entries.Protection_Entries (Num_Entries) with - record - Previous_Handlers : Previous_Handler_Array (1 .. Num_Attach_Handler); - end record; - - function Has_Interrupt_Or_Attach_Handler - (Object : access Static_Interrupt_Protection) return Boolean; - -- Returns True - - overriding procedure Finalize (Object : in out Static_Interrupt_Protection); - -- Restore previous handlers as required by C.3.1(12) then call - -- Finalize (Protection). - - procedure Install_Handlers - (Object : access Static_Interrupt_Protection; - New_Handlers : New_Handler_Array); - -- Store the old handlers in Object.Previous_Handlers and install - -- the new static handlers. - - procedure Install_Restricted_Handlers - (Prio : Any_Priority; - Handlers : New_Handler_Array); - -- Install the static Handlers for the given interrupts and do not - -- store previously installed handlers. This procedure is used when - -- the Ravenscar restrictions are in place since in that case there - -- are only library-level protected handlers that will be installed - -- at initialization and never be replaced. - -end System.Interrupts; diff --git a/gcc/ada/s-intman-android.adb b/gcc/ada/s-intman-android.adb deleted file mode 100644 index 6c8f0fbe1d4..00000000000 --- a/gcc/ada/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-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. -- --- -- --- 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/s-intman-dummy.adb b/gcc/ada/s-intman-dummy.adb deleted file mode 100644 index d3e222ce671..00000000000 --- a/gcc/ada/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-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. -- --- -- ------------------------------------------------------------------------------- - --- 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/s-intman-mingw.adb b/gcc/ada/s-intman-mingw.adb deleted file mode 100644 index ab9f08ee5e4..00000000000 --- a/gcc/ada/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-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. -- --- -- ------------------------------------------------------------------------------- - --- 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/s-intman-posix.adb b/gcc/ada/s-intman-posix.adb deleted file mode 100644 index 92e7ab156b9..00000000000 --- a/gcc/ada/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-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. -- --- -- ------------------------------------------------------------------------------- - --- 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/s-intman-solaris.adb b/gcc/ada/s-intman-solaris.adb deleted file mode 100644 index 03366b90189..00000000000 --- a/gcc/ada/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-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. -- --- -- ------------------------------------------------------------------------------- - --- 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/s-intman-susv3.adb b/gcc/ada/s-intman-susv3.adb deleted file mode 100644 index 864d7e1d2dd..00000000000 --- a/gcc/ada/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-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. -- --- -- ------------------------------------------------------------------------------- - --- 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/s-intman-vxworks.adb b/gcc/ada/s-intman-vxworks.adb deleted file mode 100644 index f1576e92644..00000000000 --- a/gcc/ada/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-2010, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License 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/s-intman-vxworks.ads b/gcc/ada/s-intman-vxworks.ads deleted file mode 100644 index 6c63d7546ba..00000000000 --- a/gcc/ada/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-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 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/s-intman.ads b/gcc/ada/s-intman.ads deleted file mode 100644 index 71a1cefcc6e..00000000000 --- a/gcc/ada/s-intman.ads +++ /dev/null @@ -1,111 +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-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 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; - - -- 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 : Interrupt_ID; - -- The interrupt that is used to implement task abort if an interrupt is - -- used for that purpose. This is one of the reserved interrupts. - - Keep_Unmasked : Interrupt_Set := (others => False); - -- Keep_Unmasked (I) is true iff the interrupt I is one that must be kept - -- unmasked at all times, except (perhaps) for short critical sections. - -- This includes interrupts that are mapped to exceptions (see - -- System.Interrupt_Exceptions.Is_Exception), but may also include - -- interrupts (e.g. timer) that need to be kept unmasked for other - -- reasons. Where interrupts are implemented as OS signals, and signal - -- masking is per-task, the interrupt should be unmasked in ALL TASKS. - - Reserve : Interrupt_Set := (others => False); - -- Reserve (I) is true iff the interrupt I is one that cannot be permitted - -- to be attached to a user handler. The possible reasons are many. For - -- example, it may be mapped to an exception used to implement task abort, - -- or used to implement time delays. - - procedure Initialize; - -- Initialize the various variables defined in this package. This procedure - -- must be called before accessing any object from this package, and can be - -- called multiple times. - -private - type Interrupt_Mask is new System.OS_Interface.sigset_t; - -- In some implementations Interrupt_Mask is represented as a linked list - - procedure Adjust_Context_For_Raise - (Signo : System.OS_Interface.Signal; - Ucontext : System.Address); - pragma Import - (C, Adjust_Context_For_Raise, "__gnat_adjust_context_for_raise"); - -- Target specific hook performing adjustments to the signal's machine - -- context, to be called before an exception may be raised from a signal - -- handler. This service is provided by init.c, together with the - -- non-tasking signal handler. - -end System.Interrupt_Management; diff --git a/gcc/ada/s-linux-alpha.ads b/gcc/ada/s-linux-alpha.ads deleted file mode 100644 index 23ca44aad7c..00000000000 --- a/gcc/ada/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-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 -- --- . -- --- -- --- -- ------------------------------------------------------------------------------- - --- 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/s-linux-android.ads b/gcc/ada/s-linux-android.ads deleted file mode 100644 index d02b96e0e79..00000000000 --- a/gcc/ada/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, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL 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/s-linux-hppa.ads b/gcc/ada/s-linux-hppa.ads deleted file mode 100644 index d72c96ebcaf..00000000000 --- a/gcc/ada/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-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 -- --- . -- --- -- --- -- ------------------------------------------------------------------------------- - --- 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/s-linux-mips.ads b/gcc/ada/s-linux-mips.ads deleted file mode 100644 index 6ec4a8b7576..00000000000 --- a/gcc/ada/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/s-linux-sparc.ads b/gcc/ada/s-linux-sparc.ads deleted file mode 100644 index 96c67145fe1..00000000000 --- a/gcc/ada/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-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 -- --- . -- --- -- --- -- ------------------------------------------------------------------------------- - --- 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/s-linux-x32.ads b/gcc/ada/s-linux-x32.ads deleted file mode 100644 index 6fb453c2b4b..00000000000 --- a/gcc/ada/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-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 -- --- . -- --- -- --- -- ------------------------------------------------------------------------------- - --- 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/s-linux.ads b/gcc/ada/s-linux.ads deleted file mode 100644 index 3b482846441..00000000000 --- a/gcc/ada/s-linux.ads +++ /dev/null @@ -1,127 +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-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 -- --- . -- --- -- --- -- ------------------------------------------------------------------------------- - --- This is the default version of this package - --- This package encapsulates cpu specific differences between implementations --- of GNU/Linux, in order to share s-osinte-linux.ads. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package - -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 := 128 + sa_mask_pos; - - SA_SIGINFO : constant := 16#04#; - SA_ONSTACK : constant := 16#08000000#; - -end System.Linux; diff --git a/gcc/ada/s-mudido-affinity.adb b/gcc/ada/s-mudido-affinity.adb deleted file mode 100644 index b0a5fdd1898..00000000000 --- a/gcc/ada/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/s-mudido.adb b/gcc/ada/s-mudido.adb deleted file mode 100644 index b982df4cf03..00000000000 --- a/gcc/ada/s-mudido.adb +++ /dev/null @@ -1,175 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-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. -- --- -- ------------------------------------------------------------------------------- - --- Body used on unimplemented targets, where the operating system does not --- support setting task affinities. - -package body System.Multiprocessors.Dispatching_Domains is - - ----------------------- - -- Local subprograms -- - ----------------------- - - 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 - pragma Unreferenced (Domain, CPU, T); - begin - raise Dispatching_Domain_Error with "dispatching domains not supported"; - end Assign_Task; - - ------------ - -- Create -- - ------------ - - function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain is - pragma Unreferenced (First, Last); - begin - return raise Dispatching_Domain_Error with - "dispatching domains not supported"; - end Create; - - function Create (Set : CPU_Set) return Dispatching_Domain is - pragma Unreferenced (Set); - begin - return raise Dispatching_Domain_Error with - "dispatching domains not supported"; - end Create; - - ----------------------------- - -- Delay_Until_And_Set_CPU -- - ----------------------------- - - procedure Delay_Until_And_Set_CPU - (Delay_Until_Time : Ada.Real_Time.Time; - CPU : CPU_Range) - is - pragma Unreferenced (Delay_Until_Time, CPU); - begin - raise Dispatching_Domain_Error with "dispatching domains not supported"; - end Delay_Until_And_Set_CPU; - - -------------------------------- - -- Freeze_Dispatching_Domains -- - -------------------------------- - - procedure Freeze_Dispatching_Domains is - begin - null; - end Freeze_Dispatching_Domains; - - ------------- - -- Get_CPU -- - ------------- - - function Get_CPU - (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) return CPU_Range - is - pragma Unreferenced (T); - begin - return Not_A_Specific_CPU; - end Get_CPU; - - ----------------- - -- Get_CPU_Set -- - ----------------- - - function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is - pragma Unreferenced (Domain); - begin - return raise Dispatching_Domain_Error - with "dispatching domains not supported"; - 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 - pragma Unreferenced (T); - begin - return System_Dispatching_Domain; - end Get_Dispatching_Domain; - - ------------------- - -- Get_First_CPU -- - ------------------- - - function Get_First_CPU (Domain : Dispatching_Domain) return CPU is - pragma Unreferenced (Domain); - begin - return CPU'First; - end Get_First_CPU; - - ------------------ - -- Get_Last_CPU -- - ------------------ - - function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is - pragma Unreferenced (Domain); - begin - return Number_Of_CPUs; - end Get_Last_CPU; - - ------------- - -- Set_CPU -- - ------------- - - procedure Set_CPU - (CPU : CPU_Range; - T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) - is - pragma Unreferenced (CPU, T); - begin - raise Dispatching_Domain_Error with "dispatching domains not supported"; - end Set_CPU; - -end System.Multiprocessors.Dispatching_Domains; diff --git a/gcc/ada/s-mudido.ads b/gcc/ada/s-mudido.ads deleted file mode 100644 index 06e48bd1b9c..00000000000 --- a/gcc/ada/s-mudido.ads +++ /dev/null @@ -1,75 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Real_Time; - -with Ada.Task_Identification; - -private with System.Tasking; - -package System.Multiprocessors.Dispatching_Domains is - -- pragma Preelaborate (Dispatching_Domains); - -- ??? According to AI 167 this unit should be preelaborate, but it cannot - -- be preelaborate because it depends on Ada.Real_Time which is not - -- preelaborate. - - Dispatching_Domain_Error : exception; - - type Dispatching_Domain (<>) is limited private; - - System_Dispatching_Domain : constant Dispatching_Domain; - - function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain; - - function Get_First_CPU (Domain : Dispatching_Domain) return CPU; - - function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range; - - type CPU_Set is array (CPU range <>) of Boolean; - - function Create (Set : CPU_Set) return Dispatching_Domain; - - function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set; - - function Get_Dispatching_Domain - (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) return Dispatching_Domain; - - 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); - - procedure Set_CPU - (CPU : CPU_Range; - T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task); - - function Get_CPU - (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) return CPU_Range; - - procedure Delay_Until_And_Set_CPU - (Delay_Until_Time : Ada.Real_Time.Time; - CPU : CPU_Range); - -private - type Dispatching_Domain is new System.Tasking.Dispatching_Domain_Access; - - System_Dispatching_Domain : constant Dispatching_Domain := - Dispatching_Domain - (System.Tasking.System_Domain); -end System.Multiprocessors.Dispatching_Domains; diff --git a/gcc/ada/s-osinte-aix.adb b/gcc/ada/s-osinte-aix.adb deleted file mode 100644 index 2d5f160ca5f..00000000000 --- a/gcc/ada/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-2013, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License 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/s-osinte-aix.ads b/gcc/ada/s-osinte-aix.ads deleted file mode 100644 index 02e843718b6..00000000000 --- a/gcc/ada/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-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. -- --- 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/s-osinte-android.adb b/gcc/ada/s-osinte-android.adb deleted file mode 100644 index 81103ee78d1..00000000000 --- a/gcc/ada/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-2015, 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/s-osinte-android.ads b/gcc/ada/s-osinte-android.ads deleted file mode 100644 index 88dc03eb7ca..00000000000 --- a/gcc/ada/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-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. -- --- 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/s-osinte-darwin.adb b/gcc/ada/s-osinte-darwin.adb deleted file mode 100644 index 4998e8359a6..00000000000 --- a/gcc/ada/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-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 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/s-osinte-darwin.ads b/gcc/ada/s-osinte-darwin.ads deleted file mode 100644 index 946373c2f26..00000000000 --- a/gcc/ada/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-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. -- --- 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/s-osinte-dragonfly.adb b/gcc/ada/s-osinte-dragonfly.adb deleted file mode 100644 index dc9e19c1984..00000000000 --- a/gcc/ada/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/s-osinte-dragonfly.ads b/gcc/ada/s-osinte-dragonfly.ads deleted file mode 100644 index a67702ca82c..00000000000 --- a/gcc/ada/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/s-osinte-dummy.ads b/gcc/ada/s-osinte-dummy.ads deleted file mode 100644 index 65f1f002850..00000000000 --- a/gcc/ada/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-1994, Florida State University -- --- Copyright (C) 1995-2011, 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/s-osinte-freebsd.adb b/gcc/ada/s-osinte-freebsd.adb deleted file mode 100644 index 8c053b7049f..00000000000 --- a/gcc/ada/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-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 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/s-osinte-freebsd.ads b/gcc/ada/s-osinte-freebsd.ads deleted file mode 100644 index 12854445bd3..00000000000 --- a/gcc/ada/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-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. 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/s-osinte-gnu.adb b/gcc/ada/s-osinte-gnu.adb deleted file mode 100644 index fb099acfc7d..00000000000 --- a/gcc/ada/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/s-osinte-gnu.ads b/gcc/ada/s-osinte-gnu.ads deleted file mode 100644 index 183c5b83f60..00000000000 --- a/gcc/ada/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/s-osinte-hpux-dce.adb b/gcc/ada/s-osinte-hpux-dce.adb deleted file mode 100644 index a9d46a02e9a..00000000000 --- a/gcc/ada/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/s-osinte-hpux-dce.ads b/gcc/ada/s-osinte-hpux-dce.ads deleted file mode 100644 index 28fb5ba8569..00000000000 --- a/gcc/ada/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/s-osinte-hpux.ads b/gcc/ada/s-osinte-hpux.ads deleted file mode 100644 index ab22dad81c8..00000000000 --- a/gcc/ada/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-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. -- --- 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/s-osinte-kfreebsd-gnu.ads b/gcc/ada/s-osinte-kfreebsd-gnu.ads deleted file mode 100644 index 647778bb053..00000000000 --- a/gcc/ada/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/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads deleted file mode 100644 index fa1e060405a..00000000000 --- a/gcc/ada/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-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 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/s-osinte-mingw.ads b/gcc/ada/s-osinte-mingw.ads deleted file mode 100644 index a84d635bf86..00000000000 --- a/gcc/ada/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-1994, Florida State University -- --- Copyright (C) 1995-2014, 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/s-osinte-posix.adb b/gcc/ada/s-osinte-posix.adb deleted file mode 100644 index 6bcc7223564..00000000000 --- a/gcc/ada/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-1994, Florida State University -- --- Copyright (C) 1995-2014, 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/s-osinte-rtems.adb b/gcc/ada/s-osinte-rtems.adb deleted file mode 100644 index 9f01128c918..00000000000 --- a/gcc/ada/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/s-osinte-rtems.ads b/gcc/ada/s-osinte-rtems.ads deleted file mode 100644 index a658bbe8b0d..00000000000 --- a/gcc/ada/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/s-osinte-solaris.adb b/gcc/ada/s-osinte-solaris.adb deleted file mode 100644 index 3322133720b..00000000000 --- a/gcc/ada/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-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 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/s-osinte-solaris.ads b/gcc/ada/s-osinte-solaris.ads deleted file mode 100644 index b4baa6d4998..00000000000 --- a/gcc/ada/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-1994, Florida State University -- --- Copyright (C) 1995-2011, 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/s-osinte-vxworks.adb b/gcc/ada/s-osinte-vxworks.adb deleted file mode 100644 index ab56b8c7d5b..00000000000 --- a/gcc/ada/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-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 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/s-osinte-vxworks.ads b/gcc/ada/s-osinte-vxworks.ads deleted file mode 100644 index 10152343a61..00000000000 --- a/gcc/ada/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-1994, Florida State University -- --- Copyright (C) 1995-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. 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/s-osinte-x32.adb b/gcc/ada/s-osinte-x32.adb deleted file mode 100644 index 467970b963d..00000000000 --- a/gcc/ada/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-1994, Florida State University -- --- Copyright (C) 1995-2014, 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/s-proinf.adb b/gcc/ada/s-proinf.adb deleted file mode 100644 index 1d7e424c92e..00000000000 --- a/gcc/ada/s-proinf.adb +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P R O G R A M _ I N F O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2014, 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. -- --- -- ------------------------------------------------------------------------------- - -package body System.Program_Info is - - Default_Stack_Size : constant := 10000; - - function Default_Task_Stack return Integer is - begin - return Default_Stack_Size; - end Default_Task_Stack; - -end System.Program_Info; diff --git a/gcc/ada/s-proinf.ads b/gcc/ada/s-proinf.ads deleted file mode 100644 index beff342383b..00000000000 --- a/gcc/ada/s-proinf.ads +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P R O G R A M _ I N F O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1996-2009, 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 used as parameters --- to the run-time system at program startup. - -package System.Program_Info is - pragma Preelaborate; - - function Default_Task_Stack return Integer; - -- The default stack size for each created thread. This default value - -- can be overridden on a per-task basis by the language-defined - -- Storage_Size pragma. - -end System.Program_Info; diff --git a/gcc/ada/s-solita.adb b/gcc/ada/s-solita.adb deleted file mode 100644 index d1ca2c474c7..00000000000 --- a/gcc/ada/s-solita.adb +++ /dev/null @@ -1,232 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S O F T _ L I N K S . T A S K I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Style_Checks (All_Checks); --- Turn off subprogram alpha ordering check, since we group soft link bodies --- and dummy soft link bodies together separately in this unit. - -pragma Polling (Off); --- Turn polling off for this package. We don't need polling during any of the --- routines in this package, and more to the point, if we try to poll it can --- cause infinite loops. - -with Ada.Exceptions; -with Ada.Exceptions.Is_Null_Occurrence; - -with System.Task_Primitives.Operations; -with System.Tasking; -with System.Stack_Checking; - -package body System.Soft_Links.Tasking is - - package STPO renames System.Task_Primitives.Operations; - package SSL renames System.Soft_Links; - - use Ada.Exceptions; - - use type System.Tasking.Task_Id; - use type System.Tasking.Termination_Handler; - - ---------------- - -- Local Data -- - ---------------- - - Initialized : Boolean := False; - -- Boolean flag that indicates whether the tasking soft links have - -- already been set. - - ----------------------------------------------------------------- - -- Tasking Versions of Services Needed by Non-Tasking Programs -- - ----------------------------------------------------------------- - - function Get_Jmpbuf_Address return Address; - procedure Set_Jmpbuf_Address (Addr : Address); - -- Get/Set Jmpbuf_Address for current task - - function Get_Sec_Stack_Addr return Address; - procedure Set_Sec_Stack_Addr (Addr : Address); - -- Get/Set location of current task's secondary stack - - procedure Timed_Delay_T (Time : Duration; Mode : Integer); - -- Task-safe version of SSL.Timed_Delay - - procedure Task_Termination_Handler_T (Excep : SSL.EO); - -- Task-safe version of the task termination procedure - - function Get_Stack_Info return Stack_Checking.Stack_Access; - -- Get access to the current task's Stack_Info - - -------------------------- - -- Soft-Link Get Bodies -- - -------------------------- - - function Get_Jmpbuf_Address return Address is - begin - return STPO.Self.Common.Compiler_Data.Jmpbuf_Address; - end Get_Jmpbuf_Address; - - function Get_Sec_Stack_Addr return Address is - begin - return Result : constant Address := - STPO.Self.Common.Compiler_Data.Sec_Stack_Addr - do - pragma Assert (Result /= Null_Address); - end return; - end Get_Sec_Stack_Addr; - - function Get_Stack_Info return Stack_Checking.Stack_Access is - begin - return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access; - end Get_Stack_Info; - - -------------------------- - -- Soft-Link Set Bodies -- - -------------------------- - - procedure Set_Jmpbuf_Address (Addr : Address) is - begin - STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr; - end Set_Jmpbuf_Address; - - procedure Set_Sec_Stack_Addr (Addr : Address) is - begin - STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr; - end Set_Sec_Stack_Addr; - - ------------------- - -- Timed_Delay_T -- - ------------------- - - procedure Timed_Delay_T (Time : Duration; Mode : Integer) is - Self_Id : constant System.Tasking.Task_Id := STPO.Self; - - begin - -- In case pragma Detect_Blocking is active then Program_Error - -- must be raised if this potentially blocking operation - -- is called from a protected operation. - - if System.Tasking.Detect_Blocking - and then Self_Id.Common.Protected_Action_Nesting > 0 - then - raise Program_Error with "potentially blocking operation"; - else - Abort_Defer.all; - STPO.Timed_Delay (Self_Id, Time, Mode); - Abort_Undefer.all; - end if; - end Timed_Delay_T; - - -------------------------------- - -- Task_Termination_Handler_T -- - -------------------------------- - - procedure Task_Termination_Handler_T (Excep : SSL.EO) is - Self_Id : constant System.Tasking.Task_Id := STPO.Self; - Cause : System.Tasking.Cause_Of_Termination; - EO : Ada.Exceptions.Exception_Occurrence; - - begin - -- We can only be here because we are terminating the environment task. - -- Task termination for all other tasks is handled in the Task_Wrapper. - - -- We do not want to enable this check and e.g. call System.OS_Lib.Abort - -- here because some restricted run-times may not have System.OS_Lib - -- and calling abort may do more harm than good to the main application. - - pragma Assert (Self_Id = STPO.Environment_Task); - - -- Normal task termination - - if Is_Null_Occurrence (Excep) then - Cause := System.Tasking.Normal; - Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); - - -- Abnormal task termination - - elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then - Cause := System.Tasking.Abnormal; - Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); - - -- Termination because of an unhandled exception - - else - Cause := System.Tasking.Unhandled_Exception; - Ada.Exceptions.Save_Occurrence (EO, Excep); - end if; - - -- There is no need for explicit protection against race conditions for - -- this part because it can only be executed by the environment task - -- after all the other tasks have been finalized. Note that there is no - -- fall-back handler which could apply to this environment task because - -- it has no parents, and, as specified in ARM C.7.3 par. 9/2, "the - -- fall-back handler applies only to the dependent tasks of the task". - - if Self_Id.Common.Specific_Handler /= null then - Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO); - end if; - end Task_Termination_Handler_T; - - ----------------------------- - -- Init_Tasking_Soft_Links -- - ----------------------------- - - procedure Init_Tasking_Soft_Links is - begin - -- Set links only if not set already - - if not Initialized then - - -- Mark tasking soft links as initialized - - Initialized := True; - - -- The application being executed uses tasking so that the tasking - -- version of the following soft links need to be used. - - SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access; - SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access; - SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access; - SSL.Get_Stack_Info := Get_Stack_Info'Access; - SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access; - SSL.Timed_Delay := Timed_Delay_T'Access; - SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access; - - -- No need to create a new secondary stack, since we will use the - -- default one created in s-secsta.adb. - - SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT); - SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT); - end if; - - pragma Assert (Get_Sec_Stack_Addr /= Null_Address); - end Init_Tasking_Soft_Links; - -end System.Soft_Links.Tasking; diff --git a/gcc/ada/s-solita.ads b/gcc/ada/s-solita.ads deleted file mode 100644 index 0e987ea0bab..00000000000 --- a/gcc/ada/s-solita.ads +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S O F T _ L I N K S . T A S K I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2014, 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 tasking versions soft links that are common --- to the full and the restricted run times. The rest of the required soft --- links are set by System.Tasking.Initialization and System.Tasking.Stages --- (full run time) or System.Tasking.Restricted.Stages (restricted run time). - -package System.Soft_Links.Tasking is - - procedure Init_Tasking_Soft_Links; - -- Set the tasking soft links that are common to the full and the - -- restricted run times. Clients need to make sure the body of - -- System.Secondary_Stack is elaborated before calling this. - -end System.Soft_Links.Tasking; diff --git a/gcc/ada/s-stusta.adb b/gcc/ada/s-stusta.adb deleted file mode 100644 index f899266218e..00000000000 --- a/gcc/ada/s-stusta.adb +++ /dev/null @@ -1,258 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T A C K _ U S A G E . T A S K I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2011, 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. -- --- -- ------------------------------------------------------------------------------- - -with System.Stack_Usage; - --- This is why this package is part of GNARL: - -with System.Tasking.Debug; -with System.Task_Primitives.Operations; - -with System.IO; - -package body System.Stack_Usage.Tasking is - use System.IO; - - procedure Report_For_Task (Id : System.Tasking.Task_Id); - -- A generic procedure calculating stack usage for a given task - - procedure Compute_All_Tasks; - -- Compute the stack usage for all tasks and saves it in - -- System.Stack_Usage.Result_Array - - procedure Compute_Current_Task; - -- Compute the stack usage for a given task and saves it in the precise - -- slot in System.Stack_Usage.Result_Array; - - procedure Report_Impl (All_Tasks : Boolean; Do_Print : Boolean); - -- Report the stack usage of either all tasks (All_Tasks = True) or of the - -- current task (All_Task = False). If Print is True, then results are - -- printed on stderr - - procedure Convert - (TS : System.Stack_Usage.Task_Result; - Res : out Stack_Usage_Result); - -- Convert an object of type System.Stack_Usage in a Stack_Usage_Result - - ------------- - -- Convert -- - ------------- - - procedure Convert - (TS : System.Stack_Usage.Task_Result; - Res : out Stack_Usage_Result) is - begin - Res := TS; - end Convert; - - --------------------- - -- Report_For_Task -- - --------------------- - - procedure Report_For_Task (Id : System.Tasking.Task_Id) is - begin - System.Stack_Usage.Compute_Result (Id.Common.Analyzer); - System.Stack_Usage.Report_Result (Id.Common.Analyzer); - end Report_For_Task; - - ----------------------- - -- Compute_All_Tasks -- - ----------------------- - - procedure Compute_All_Tasks is - Id : System.Tasking.Task_Id; - use type System.Tasking.Task_Id; - begin - if not System.Stack_Usage.Is_Enabled then - Put_Line ("Stack Usage not enabled: bind with -uNNN switch"); - else - - -- Loop over all tasks - - for J in System.Tasking.Debug.Known_Tasks'First + 1 - .. System.Tasking.Debug.Known_Tasks'Last - loop - Id := System.Tasking.Debug.Known_Tasks (J); - exit when Id = null; - - -- Calculate the task usage for a given task - - Report_For_Task (Id); - end loop; - - end if; - end Compute_All_Tasks; - - -------------------------- - -- Compute_Current_Task -- - -------------------------- - - procedure Compute_Current_Task is - begin - if not System.Stack_Usage.Is_Enabled then - Put_Line ("Stack Usage not enabled: bind with -uNNN switch"); - else - - -- The current task - - Report_For_Task (System.Tasking.Self); - - end if; - end Compute_Current_Task; - - ----------------- - -- Report_Impl -- - ----------------- - - procedure Report_Impl (All_Tasks : Boolean; Do_Print : Boolean) is - begin - - -- Lock the runtime - - System.Task_Primitives.Operations.Lock_RTS; - - -- Calculate results - - if All_Tasks then - Compute_All_Tasks; - else - Compute_Current_Task; - end if; - - -- Output results - if Do_Print then - System.Stack_Usage.Output_Results; - end if; - - -- Unlock the runtime - - System.Task_Primitives.Operations.Unlock_RTS; - - end Report_Impl; - - --------------------- - -- Report_All_Task -- - --------------------- - - procedure Report_All_Tasks is - begin - Report_Impl (True, True); - end Report_All_Tasks; - - ------------------------- - -- Report_Current_Task -- - ------------------------- - - procedure Report_Current_Task is - Res : Stack_Usage_Result; - begin - Res := Get_Current_Task_Usage; - Print (Res); - end Report_Current_Task; - - ------------------------- - -- Get_All_Tasks_Usage -- - ------------------------- - - function Get_All_Tasks_Usage return Stack_Usage_Result_Array is - Res : Stack_Usage_Result_Array - (1 .. System.Stack_Usage.Result_Array'Length); - begin - Report_Impl (True, False); - - for J in Res'Range loop - Convert (System.Stack_Usage.Result_Array (J), Res (J)); - end loop; - - return Res; - end Get_All_Tasks_Usage; - - ---------------------------- - -- Get_Current_Task_Usage -- - ---------------------------- - - function Get_Current_Task_Usage return Stack_Usage_Result is - Res : Stack_Usage_Result; - Original : System.Stack_Usage.Task_Result; - Found : Boolean := False; - begin - - Report_Impl (False, False); - - -- Look for the task info in System.Stack_Usage.Result_Array; - -- the search is based on task name - - for T in System.Stack_Usage.Result_Array'Range loop - if System.Stack_Usage.Result_Array (T).Task_Name = - System.Tasking.Self.Common.Analyzer.Task_Name - then - Original := System.Stack_Usage.Result_Array (T); - Found := True; - exit; - end if; - end loop; - - -- Be sure a task has been found - - pragma Assert (Found); - - Convert (Original, Res); - return Res; - end Get_Current_Task_Usage; - - ----------- - -- Print -- - ----------- - - procedure Print (Obj : Stack_Usage_Result) is - Pos : Positive := Obj.Task_Name'Last; - - begin - -- Simply trim the string containing the task name - - for S in Obj.Task_Name'Range loop - if Obj.Task_Name (S) = ' ' then - Pos := S; - exit; - end if; - end loop; - - declare - T_Name : constant String := - Obj.Task_Name (Obj.Task_Name'First .. Pos); - begin - Put_Line - ("| " & T_Name & " | " & Natural'Image (Obj.Stack_Size) & - Natural'Image (Obj.Value)); - end; - end Print; - -end System.Stack_Usage.Tasking; diff --git a/gcc/ada/s-stusta.ads b/gcc/ada/s-stusta.ads deleted file mode 100644 index 88a8e7971c5..00000000000 --- a/gcc/ada/s-stusta.ads +++ /dev/null @@ -1,75 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T A C K _ U S A G E . T A S K I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2011, 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 package provides exported subprograms to be called at debug time to --- measure stack usage at run-time. - --- Note: this package must be a child package of System.Stack_Usage to have --- visibility over its private part; it is however part of GNARL because it --- needs to access tasking features via System.Tasking.Debug and --- System.Task_Primitives.Operations; - -package System.Stack_Usage.Tasking is - - procedure Report_All_Tasks; - -- Print the current stack usage of all tasks on stderr. Exported to be - -- called also in debug mode. - - pragma Export - (C, - Report_All_Tasks, - "__gnat_tasks_stack_usage_report_all_tasks"); - - procedure Report_Current_Task; - -- Print the stack usage of current task on stderr. Exported to be called - -- also in debug mode. - - pragma Export - (C, - Report_Current_Task, - "__gnat_tasks_stack_usage_report_current_task"); - - subtype Stack_Usage_Result is System.Stack_Usage.Task_Result; - -- This type is a descriptor for task stack usage result - - type Stack_Usage_Result_Array is - array (Positive range <>) of Stack_Usage_Result; - - function Get_Current_Task_Usage return Stack_Usage_Result; - -- Return the current stack usage for the invoking task - - function Get_All_Tasks_Usage return Stack_Usage_Result_Array; - -- Return an array containing the stack usage results for all tasks - - procedure Print (Obj : Stack_Usage_Result); - -- Print Obj on stderr - -end System.Stack_Usage.Tasking; diff --git a/gcc/ada/s-taasde.adb b/gcc/ada/s-taasde.adb deleted file mode 100644 index cab0be7b13e..00000000000 --- a/gcc/ada/s-taasde.adb +++ /dev/null @@ -1,395 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y 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. -- --- -- ------------------------------------------------------------------------------- - -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 Ada.Task_Identification; - -with System.Task_Primitives.Operations; -with System.Tasking.Utilities; -with System.Tasking.Initialization; -with System.Tasking.Debug; -with System.OS_Primitives; -with System.Interrupt_Management.Operations; - -package body System.Tasking.Async_Delays is - - package STPO renames System.Task_Primitives.Operations; - package ST renames System.Tasking; - package STU renames System.Tasking.Utilities; - package STI renames System.Tasking.Initialization; - package OSP renames System.OS_Primitives; - - use Parameters; - - function To_System is new Ada.Unchecked_Conversion - (Ada.Task_Identification.Task_Id, Task_Id); - - Timer_Attention : Boolean := False; - pragma Atomic (Timer_Attention); - - task Timer_Server is - pragma Interrupt_Priority (System.Any_Priority'Last); - end Timer_Server; - - Timer_Server_ID : constant ST.Task_Id := To_System (Timer_Server'Identity); - - -- The timer queue is a circular doubly linked list, ordered by absolute - -- wakeup time. The first item in the queue is Timer_Queue.Succ. - -- It is given a Resume_Time that is larger than any legitimate wakeup - -- time, so that the ordered insertion will always stop searching when it - -- gets back to the queue header block. - - Timer_Queue : aliased Delay_Block; - - package Init_Timer_Queue is end Init_Timer_Queue; - pragma Unreferenced (Init_Timer_Queue); - -- Initialize the Timer_Queue. This is a package to work around the - -- fact that statements are syntactically illegal here. We want this - -- initialization to happen before the Timer_Server is activated. A - -- build-in-place function would also work, but that's not supported - -- on all platforms (e.g. cil). - - package body Init_Timer_Queue is - begin - Timer_Queue.Succ := Timer_Queue'Unchecked_Access; - Timer_Queue.Pred := Timer_Queue'Unchecked_Access; - Timer_Queue.Resume_Time := Duration'Last; - end Init_Timer_Queue; - - ------------------------ - -- Cancel_Async_Delay -- - ------------------------ - - -- This should (only) be called from the compiler-generated cleanup routine - -- for an async. select statement with delay statement as trigger. The - -- effect should be to remove the delay from the timer queue, and exit one - -- ATC nesting level. - -- The usage and logic are similar to Cancel_Protected_Entry_Call, but - -- simplified because this is not a true entry call. - - procedure Cancel_Async_Delay (D : Delay_Block_Access) is - Dpred : Delay_Block_Access; - Dsucc : Delay_Block_Access; - - begin - -- Note that we mark the delay as being cancelled - -- using a level value that is reserved. - - -- make this operation idempotent - - if D.Level = ATC_Level_Infinity then - return; - end if; - - D.Level := ATC_Level_Infinity; - - -- remove self from timer queue - - STI.Defer_Abort_Nestable (D.Self_Id); - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Timer_Server_ID); - Dpred := D.Pred; - Dsucc := D.Succ; - Dpred.Succ := Dsucc; - Dsucc.Pred := Dpred; - D.Succ := D; - D.Pred := D; - STPO.Unlock (Timer_Server_ID); - - -- Note that the above deletion code is required to be - -- idempotent, since the block may have been dequeued - -- previously by the Timer_Server. - - -- leave the asynchronous select - - STPO.Write_Lock (D.Self_Id); - STU.Exit_One_ATC_Level (D.Self_Id); - STPO.Unlock (D.Self_Id); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - STI.Undefer_Abort_Nestable (D.Self_Id); - end Cancel_Async_Delay; - - ---------------------- - -- Enqueue_Duration -- - ---------------------- - - function Enqueue_Duration - (T : Duration; - D : Delay_Block_Access) return Boolean - is - begin - if T <= 0.0 then - D.Timed_Out := True; - STPO.Yield; - return False; - - else - -- The corresponding call to Undefer_Abort is performed by the - -- expanded code (see exp_ch9). - - STI.Defer_Abort (STPO.Self); - Time_Enqueue - (STPO.Monotonic_Clock - + Duration'Min (T, OSP.Max_Sensible_Delay), D); - return True; - end if; - end Enqueue_Duration; - - ------------------ - -- Time_Enqueue -- - ------------------ - - -- Allocate a queue element for the wakeup time T and put it in the - -- queue in wakeup time order. Assume we are on an asynchronous - -- select statement with delay trigger. Put the calling task to - -- sleep until either the delay expires or is cancelled. - - -- We use one entry call record for this delay, since we have - -- to increment the ATC nesting level, but since it is not a - -- real entry call we do not need to use any of the fields of - -- the call record. The following code implements a subset of - -- the actions for the asynchronous case of Protected_Entry_Call, - -- much simplified since we know this never blocks, and does not - -- have the full semantics of a protected entry call. - - procedure Time_Enqueue - (T : Duration; - D : Delay_Block_Access) - is - Self_Id : constant Task_Id := STPO.Self; - Q : Delay_Block_Access; - - begin - pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P')); - pragma Assert (Self_Id.Deferral_Level = 1, - "async delay from within abort-deferred region"); - - if Self_Id.ATC_Nesting_Level = ATC_Level'Last then - raise Storage_Error with "not enough ATC nesting levels"; - end if; - - Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; - - pragma Debug - (Debug.Trace (Self_Id, "ASD: entered ATC level: " & - ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); - - D.Level := Self_Id.ATC_Nesting_Level; - D.Self_Id := Self_Id; - D.Resume_Time := T; - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Timer_Server_ID); - - -- Previously, there was code here to dynamically create - -- the Timer_Server task, if one did not already exist. - -- That code had a timing window that could allow multiple - -- timer servers to be created. Luckily, the need for - -- postponing creation of the timer server should now be - -- gone, since this package will only be linked in if - -- there are calls to enqueue calls on the timer server. - - -- Insert D in the timer queue, at the position determined - -- by the wakeup time T. - - Q := Timer_Queue.Succ; - - while Q.Resume_Time < T loop - Q := Q.Succ; - end loop; - - -- Q is the block that has Resume_Time equal to or greater than - -- T. After the insertion we want Q to be the successor of D. - - D.Succ := Q; - D.Pred := Q.Pred; - D.Pred.Succ := D; - Q.Pred := D; - - -- If the new element became the head of the queue, - -- signal the Timer_Server to wake up. - - if Timer_Queue.Succ = D then - Timer_Attention := True; - STPO.Wakeup (Timer_Server_ID, ST.Timer_Server_Sleep); - end if; - - STPO.Unlock (Timer_Server_ID); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - end Time_Enqueue; - - --------------- - -- Timed_Out -- - --------------- - - function Timed_Out (D : Delay_Block_Access) return Boolean is - begin - return D.Timed_Out; - end Timed_Out; - - ------------------ - -- Timer_Server -- - ------------------ - - task body Timer_Server is - Ignore : constant Boolean := STU.Make_Independent; - - -- Local Declarations - - Next_Wakeup_Time : Duration := Duration'Last; - Timedout : Boolean; - Yielded : Boolean; - Now : Duration; - Dequeued : Delay_Block_Access; - Dequeued_Task : Task_Id; - - pragma Unreferenced (Timedout, Yielded); - - begin - pragma Assert (Timer_Server_ID = STPO.Self); - - -- Since this package may be elaborated before System.Interrupt, - -- we need to call Setup_Interrupt_Mask explicitly to ensure that - -- this task has the proper signal mask. - - Interrupt_Management.Operations.Setup_Interrupt_Mask; - - -- Initialize the timer queue to empty, and make the wakeup time of the - -- header node be larger than any real wakeup time we will ever use. - - loop - STI.Defer_Abort (Timer_Server_ID); - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Timer_Server_ID); - - -- The timer server needs to catch pending aborts after finalization - -- of library packages. If it doesn't poll for it, the server will - -- sometimes hang. - - if not Timer_Attention then - Timer_Server_ID.Common.State := ST.Timer_Server_Sleep; - - if Next_Wakeup_Time = Duration'Last then - Timer_Server_ID.User_State := 1; - Next_Wakeup_Time := - STPO.Monotonic_Clock + OSP.Max_Sensible_Delay; - - else - Timer_Server_ID.User_State := 2; - end if; - - STPO.Timed_Sleep - (Timer_Server_ID, Next_Wakeup_Time, - OSP.Absolute_RT, ST.Timer_Server_Sleep, - Timedout, Yielded); - Timer_Server_ID.Common.State := ST.Runnable; - end if; - - -- Service all of the wakeup requests on the queue whose times have - -- been reached, and update Next_Wakeup_Time to next wakeup time - -- after that (the wakeup time of the head of the queue if any, else - -- a time far in the future). - - Timer_Server_ID.User_State := 3; - Timer_Attention := False; - - Now := STPO.Monotonic_Clock; - while Timer_Queue.Succ.Resume_Time <= Now loop - - -- Dequeue the waiting task from the front of the queue - - pragma Debug (System.Tasking.Debug.Trace - (Timer_Server_ID, "Timer service: waking up waiting task", 'E')); - - Dequeued := Timer_Queue.Succ; - Timer_Queue.Succ := Dequeued.Succ; - Dequeued.Succ.Pred := Dequeued.Pred; - Dequeued.Succ := Dequeued; - Dequeued.Pred := Dequeued; - - -- We want to abort the queued task to the level of the async. - -- select statement with the delay. To do that, we need to lock - -- the ATCB of that task, but to avoid deadlock we need to release - -- the lock of the Timer_Server. This leaves a window in which - -- another task might perform an enqueue or dequeue operation on - -- the timer queue, but that is OK because we always restart the - -- next iteration at the head of the queue. - - STPO.Unlock (Timer_Server_ID); - STPO.Write_Lock (Dequeued.Self_Id); - Dequeued_Task := Dequeued.Self_Id; - Dequeued.Timed_Out := True; - STI.Locked_Abort_To_Level - (Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1); - STPO.Unlock (Dequeued_Task); - STPO.Write_Lock (Timer_Server_ID); - end loop; - - Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time; - - -- Service returns the Next_Wakeup_Time. - -- The Next_Wakeup_Time is either an infinity (no delay request) - -- or the wakeup time of the queue head. This value is used for - -- an actual delay in this server. - - STPO.Unlock (Timer_Server_ID); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - STI.Undefer_Abort (Timer_Server_ID); - end loop; - end Timer_Server; - -end System.Tasking.Async_Delays; diff --git a/gcc/ada/s-taasde.ads b/gcc/ada/s-taasde.ads deleted file mode 100644 index 11227539dd7..00000000000 --- a/gcc/ada/s-taasde.ads +++ /dev/null @@ -1,147 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-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 package contains the procedures to implements timeouts (delays) for --- asynchronous select statements. - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes. - -package System.Tasking.Async_Delays is - - -- Suppose the following source code is given: - - -- select delay When; - -- ...continuation for timeout case... - -- then abort - -- ...abortable part... - -- end select; - - -- The compiler should expand this to the following: - - -- declare - -- DB : aliased Delay_Block; - -- begin - -- if System.Tasking.Async_Delays.Enqueue_Duration - -- (When, DB'Unchecked_Access) - -- then - -- begin - -- A101b : declare - -- procedure _clean is - -- begin - -- System.Tasking.Async_Delays.Cancel_Async_Delay - -- (DB'Unchecked_Access); - -- return; - -- end _clean; - -- begin - -- abort_undefer.all; - -- ...abortable part... - -- exception - -- when all others => - -- declare - -- E105b : exception_occurrence; - -- begin - -- save_occurrence (E105b, get_current_excep.all.all); - -- _clean; - -- reraise_occurrence_no_defer (E105b); - -- end; - -- at end - -- _clean; - -- end A101b; - -- exception - -- when _abort_signal => - -- abort_undefer.all; - -- end; - -- end if; - - -- if Timed_Out (DB'Unchecked_Access) then - -- ...continuation for timeout case... - -- end if; - -- end; - - ----------------- - -- Delay_Block -- - ----------------- - - type Delay_Block is limited private; - type Delay_Block_Access is access all Delay_Block; - - function Enqueue_Duration - (T : Duration; - D : Delay_Block_Access) return Boolean; - -- Enqueue the specified relative delay. Returns True if the delay has - -- been enqueued, False if it has already expired. If the delay has been - -- enqueued, abort is deferred. - - procedure Cancel_Async_Delay (D : Delay_Block_Access); - -- Cancel the specified asynchronous delay - - function Timed_Out (D : Delay_Block_Access) return Boolean; - pragma Inline (Timed_Out); - -- Return True if the delay specified in D has timed out - - -- There are child units for delays on Ada.Calendar.Time/Ada.Real_Time.Time - -- so that an application need not link in features that it is not using. - -private - - type Delay_Block is limited record - Self_Id : Task_Id; - -- ID of the calling task - - Level : ATC_Level_Base; - -- Normally Level is the ATC nesting level of the asynchronous select - -- statement to which this delay belongs, but after a call has been - -- dequeued we set it to ATC_Level_Infinity so that the Cancel operation - -- can detect repeated calls, and act idempotently. - - Resume_Time : Duration; - -- The absolute wake up time, represented as Duration - - Timed_Out : Boolean := False; - -- Set to true if the delay has timed out - - Succ, Pred : Delay_Block_Access; - -- A double linked list - end record; - - -- The above "overlaying" of Self_Id and Level to hold other data that has - -- a non-overlapping lifetime is an unabashed hack to save memory. - - procedure Time_Enqueue - (T : Duration; - D : Delay_Block_Access); - pragma Inline (Time_Enqueue); - -- Used by the child units to enqueue delays on the timer queue implemented - -- in the body of this package. T denotes a point in time as the duration - -- elapsed since the epoch of the Ada real-time clock. - -end System.Tasking.Async_Delays; diff --git a/gcc/ada/s-tadeca.adb b/gcc/ada/s-tadeca.adb deleted file mode 100644 index 4ebbee7ab32..00000000000 --- a/gcc/ada/s-tadeca.adb +++ /dev/null @@ -1,76 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_CALENDAR -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-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. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Calendar.Delays; - -with System.OS_Constants; -with System.OS_Primitives; -with System.Task_Primitives.Operations; -with System.Tasking.Initialization; - -function System.Tasking.Async_Delays.Enqueue_Calendar - (T : Ada.Calendar.Time; - D : Delay_Block_Access) return Boolean -is - use type Ada.Calendar.Time; - - package SOSC renames System.OS_Constants; - package STPO renames System.Task_Primitives.Operations; - - RT_T : Duration := Ada.Calendar.Delays.To_Duration (T); - -begin - if T <= Ada.Calendar.Clock then - D.Timed_Out := True; - System.Task_Primitives.Operations.Yield; - return False; - end if; - - -- T is expressed as a duration elapsed since the UNIX epoch, whereas - -- Time_Enqueue expects duration elapsed since the epoch of the Ada real- - -- time clock: compensate if necessary. - - -- Comparison "SOSC.CLOCK_RT_Ada = SOSC.CLOCK_REALTIME" is compile - -- time known, so turn warnings off. - - pragma Warnings (Off); - - if SOSC.CLOCK_RT_Ada /= SOSC.CLOCK_REALTIME then - pragma Warnings (On); - - RT_T := RT_T - OS_Primitives.Clock + STPO.Monotonic_Clock; - end if; - - System.Tasking.Initialization.Defer_Abort - (System.Task_Primitives.Operations.Self); - Time_Enqueue (RT_T, D); - return True; -end System.Tasking.Async_Delays.Enqueue_Calendar; diff --git a/gcc/ada/s-tadeca.ads b/gcc/ada/s-tadeca.ads deleted file mode 100644 index ac6a270c87e..00000000000 --- a/gcc/ada/s-tadeca.ads +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_CALENDAR -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2013, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License 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. -- --- -- ------------------------------------------------------------------------------- - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes. - --- See comments in package System.Tasking.Async_Delays - -with Ada.Calendar; -function System.Tasking.Async_Delays.Enqueue_Calendar - (T : Ada.Calendar.Time; - D : Delay_Block_Access) return Boolean; diff --git a/gcc/ada/s-tadert.adb b/gcc/ada/s-tadert.adb deleted file mode 100644 index 241523baf08..00000000000 --- a/gcc/ada/s-tadert.adb +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_RT -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-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. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Real_Time; -with Ada.Real_Time.Delays; -with System.Task_Primitives.Operations; -with System.Tasking.Initialization; - -function System.Tasking.Async_Delays.Enqueue_RT - (T : Ada.Real_Time.Time; - D : Delay_Block_Access) return Boolean -is - use type Ada.Real_Time.Time; -- for "=" operator -begin - if T <= Ada.Real_Time.Clock then - D.Timed_Out := True; - System.Task_Primitives.Operations.Yield; - return False; - end if; - - System.Tasking.Initialization.Defer_Abort - (System.Task_Primitives.Operations.Self); - Time_Enqueue (Ada.Real_Time.Delays.To_Duration (T), D); - return True; -end System.Tasking.Async_Delays.Enqueue_RT; diff --git a/gcc/ada/s-tadert.ads b/gcc/ada/s-tadert.ads deleted file mode 100644 index da8fafbd86c..00000000000 --- a/gcc/ada/s-tadert.ads +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASKING.ASYNC_DELAYS.ENQUEUE_RT -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-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. -- --- -- ------------------------------------------------------------------------------- - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes. - --- See comments in package System.Tasking.Async_Delays - -with Ada.Real_Time; -function System.Tasking.Async_Delays.Enqueue_RT - (T : Ada.Real_Time.Time; - D : Delay_Block_Access) - return Boolean; diff --git a/gcc/ada/s-taenca.adb b/gcc/ada/s-taenca.adb deleted file mode 100644 index 1236194441c..00000000000 --- a/gcc/ada/s-taenca.adb +++ /dev/null @@ -1,636 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . E N T R Y _ C A L L 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. -- --- -- ------------------------------------------------------------------------------- - -with System.Task_Primitives.Operations; -with System.Tasking.Initialization; -with System.Tasking.Protected_Objects.Entries; -with System.Tasking.Protected_Objects.Operations; -with System.Tasking.Queuing; -with System.Tasking.Utilities; -with System.Parameters; - -package body System.Tasking.Entry_Calls is - - package STPO renames System.Task_Primitives.Operations; - - use Parameters; - use Task_Primitives; - use Protected_Objects.Entries; - use Protected_Objects.Operations; - - -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock - -- internally. Those operations will raise Program_Error, which - -- we are not prepared to handle inside the RTS. Instead, use - -- System.Task_Primitives lock operations directly on Protection.L. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Lock_Server (Entry_Call : Entry_Call_Link); - - -- This locks the server targeted by Entry_Call - -- - -- This may be a task or a protected object, depending on the target of the - -- original call or any subsequent requeues. - -- - -- This routine is needed because the field specifying the server for this - -- call must be protected by the server's mutex. If it were protected by - -- the caller's mutex, accessing the server's queues would require locking - -- the caller to get the server, locking the server, and then accessing the - -- queues. This involves holding two ATCB locks at once, something which we - -- can guarantee that it will always be done in the same order, or locking - -- a protected object while we hold an ATCB lock, something which is not - -- permitted. Since the server cannot be obtained reliably, it must be - -- obtained unreliably and then checked again once it has been locked. - -- - -- If Single_Lock and server is a PO, release RTS_Lock - -- - -- This should only be called by the Entry_Call.Self. - -- It should be holding no other ATCB locks at the time. - - procedure Unlock_Server (Entry_Call : Entry_Call_Link); - -- STPO.Unlock the server targeted by Entry_Call. The server must - -- be locked before calling this. - -- - -- If Single_Lock and server is a PO, take RTS_Lock on exit. - - procedure Unlock_And_Update_Server - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link); - -- Similar to Unlock_Server, but services entry calls if the - -- server is a protected object. - -- - -- If Single_Lock and server is a PO, take RTS_Lock on exit. - - procedure Check_Pending_Actions_For_Entry_Call - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link); - -- This procedure performs priority change of a queued call and dequeuing - -- of an entry call when the call is cancelled. If the call is dequeued the - -- state should be set to Cancelled. Call only with abort deferred and - -- holding lock of Self_ID. This is a bit of common code for all entry - -- calls. The effect is to do any deferred base priority change operation, - -- in case some other task called STPO.Set_Priority while the current task - -- had abort deferred, and to dequeue the call if the call has been - -- aborted. - - procedure Poll_Base_Priority_Change_At_Entry_Call - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link); - pragma Inline (Poll_Base_Priority_Change_At_Entry_Call); - -- A specialized version of Poll_Base_Priority_Change, that does the - -- optional entry queue reordering. Has to be called with the Self_ID's - -- ATCB write-locked. May temporarily release the lock. - - --------------------- - -- Check_Exception -- - --------------------- - - procedure Check_Exception - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link) - is - pragma Warnings (Off, Self_ID); - - use type Ada.Exceptions.Exception_Id; - - procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); - pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); - - E : constant Ada.Exceptions.Exception_Id := - Entry_Call.Exception_To_Raise; - begin - -- pragma Assert (Self_ID.Deferral_Level = 0); - - -- The above may be useful for debugging, but the Florist packages - -- contain critical sections that defer abort and then do entry calls, - -- which causes the above Assert to trip. - - if E /= Ada.Exceptions.Null_Id then - Internal_Raise (E); - end if; - end Check_Exception; - - ------------------------------------------ - -- Check_Pending_Actions_For_Entry_Call -- - ------------------------------------------ - - procedure Check_Pending_Actions_For_Entry_Call - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link) - is - begin - pragma Assert (Self_ID = Entry_Call.Self); - - Poll_Base_Priority_Change_At_Entry_Call (Self_ID, Entry_Call); - - if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - and then Entry_Call.State = Now_Abortable - then - STPO.Unlock (Self_ID); - Lock_Server (Entry_Call); - - if Queuing.Onqueue (Entry_Call) - and then Entry_Call.State = Now_Abortable - then - Queuing.Dequeue_Call (Entry_Call); - Entry_Call.State := - (if Entry_Call.Cancellation_Attempted then Cancelled else Done); - Unlock_And_Update_Server (Self_ID, Entry_Call); - - else - Unlock_Server (Entry_Call); - end if; - - STPO.Write_Lock (Self_ID); - end if; - end Check_Pending_Actions_For_Entry_Call; - - ----------------- - -- Lock_Server -- - ----------------- - - procedure Lock_Server (Entry_Call : Entry_Call_Link) is - Test_Task : Task_Id; - Test_PO : Protection_Entries_Access; - Ceiling_Violation : Boolean; - Failures : Integer := 0; - - begin - Test_Task := Entry_Call.Called_Task; - - loop - if Test_Task = null then - - -- Entry_Call was queued on a protected object, or in transition, - -- when we last fetched Test_Task. - - Test_PO := To_Protection (Entry_Call.Called_PO); - - if Test_PO = null then - - -- We had very bad luck, interleaving with TWO different - -- requeue operations. Go around the loop and try again. - - if Single_Lock then - STPO.Unlock_RTS; - STPO.Yield; - STPO.Lock_RTS; - else - STPO.Yield; - end if; - - else - if Single_Lock then - STPO.Unlock_RTS; - end if; - - Lock_Entries_With_Status (Test_PO, Ceiling_Violation); - - -- ??? - - -- The following code allows Lock_Server to be called when - -- cancelling a call, to allow for the possibility that the - -- priority of the caller has been raised beyond that of the - -- protected entry call by Ada.Dynamic_Priorities.Set_Priority. - - -- If the current task has a higher priority than the ceiling - -- of the protected object, temporarily lower it. It will - -- be reset in Unlock. - - if Ceiling_Violation then - declare - Current_Task : constant Task_Id := STPO.Self; - Old_Base_Priority : System.Any_Priority; - - begin - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Current_Task); - Old_Base_Priority := Current_Task.Common.Base_Priority; - Current_Task.New_Base_Priority := Test_PO.Ceiling; - System.Tasking.Initialization.Change_Base_Priority - (Current_Task); - STPO.Unlock (Current_Task); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - -- Following lock should not fail - - Lock_Entries (Test_PO); - - Test_PO.Old_Base_Priority := Old_Base_Priority; - Test_PO.Pending_Action := True; - end; - end if; - - exit when To_Address (Test_PO) = Entry_Call.Called_PO; - Unlock_Entries (Test_PO); - - if Single_Lock then - STPO.Lock_RTS; - end if; - end if; - - else - STPO.Write_Lock (Test_Task); - exit when Test_Task = Entry_Call.Called_Task; - STPO.Unlock (Test_Task); - end if; - - Test_Task := Entry_Call.Called_Task; - Failures := Failures + 1; - pragma Assert (Failures <= 5); - end loop; - end Lock_Server; - - --------------------------------------------- - -- Poll_Base_Priority_Change_At_Entry_Call -- - --------------------------------------------- - - procedure Poll_Base_Priority_Change_At_Entry_Call - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link) - is - begin - if Self_ID.Pending_Priority_Change then - - -- Check for ceiling violations ??? - - Self_ID.Pending_Priority_Change := False; - - -- Requeue the entry call at the new priority. We need to requeue - -- even if the new priority is the same than the previous (see ACATS - -- test cxd4006). - - STPO.Unlock (Self_ID); - Lock_Server (Entry_Call); - Queuing.Requeue_Call_With_New_Prio - (Entry_Call, STPO.Get_Priority (Self_ID)); - Unlock_And_Update_Server (Self_ID, Entry_Call); - STPO.Write_Lock (Self_ID); - end if; - end Poll_Base_Priority_Change_At_Entry_Call; - - -------------------- - -- Reset_Priority -- - -------------------- - - procedure Reset_Priority - (Acceptor : Task_Id; - Acceptor_Prev_Priority : Rendezvous_Priority) - is - begin - pragma Assert (Acceptor = STPO.Self); - - -- Since we limit this kind of "active" priority change to be done - -- by the task for itself, we don't need to lock Acceptor. - - if Acceptor_Prev_Priority /= Priority_Not_Boosted then - STPO.Set_Priority (Acceptor, Acceptor_Prev_Priority, - Loss_Of_Inheritance => True); - end if; - end Reset_Priority; - - ------------------------------ - -- Try_To_Cancel_Entry_Call -- - ------------------------------ - - procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean) is - Entry_Call : Entry_Call_Link; - Self_ID : constant Task_Id := STPO.Self; - - use type Ada.Exceptions.Exception_Id; - - begin - Entry_Call := Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; - - -- Experimentation has shown that abort is sometimes (but not - -- always) already deferred when Cancel_xxx_Entry_Call is called. - -- That may indicate an error. Find out what is going on. ??? - - pragma Assert (Entry_Call.Mode = Asynchronous_Call); - Initialization.Defer_Abort_Nestable (Self_ID); - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Self_ID); - Entry_Call.Cancellation_Attempted := True; - - if Self_ID.Pending_ATC_Level >= Entry_Call.Level then - Self_ID.Pending_ATC_Level := Entry_Call.Level - 1; - end if; - - Entry_Calls.Wait_For_Completion (Entry_Call); - STPO.Unlock (Self_ID); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - Succeeded := Entry_Call.State = Cancelled; - - Initialization.Undefer_Abort_Nestable (Self_ID); - - -- Ideally, abort should no longer be deferred at this point, so we - -- should be able to call Check_Exception. The loop below should be - -- considered temporary, to work around the possibility that abort - -- may be deferred more than one level deep ??? - - if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then - while Self_ID.Deferral_Level > 0 loop - System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID); - end loop; - - Entry_Calls.Check_Exception (Self_ID, Entry_Call); - end if; - end Try_To_Cancel_Entry_Call; - - ------------------------------ - -- Unlock_And_Update_Server -- - ------------------------------ - - procedure Unlock_And_Update_Server - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link) - is - Called_PO : Protection_Entries_Access; - Caller : Task_Id; - - begin - if Entry_Call.Called_Task /= null then - STPO.Unlock (Entry_Call.Called_Task); - else - Called_PO := To_Protection (Entry_Call.Called_PO); - PO_Service_Entries (Self_ID, Called_PO, False); - - if Called_PO.Pending_Action then - Called_PO.Pending_Action := False; - Caller := STPO.Self; - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Caller); - Caller.New_Base_Priority := Called_PO.Old_Base_Priority; - Initialization.Change_Base_Priority (Caller); - STPO.Unlock (Caller); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - end if; - - Unlock_Entries (Called_PO); - - if Single_Lock then - STPO.Lock_RTS; - end if; - end if; - end Unlock_And_Update_Server; - - ------------------- - -- Unlock_Server -- - ------------------- - - procedure Unlock_Server (Entry_Call : Entry_Call_Link) is - Caller : Task_Id; - Called_PO : Protection_Entries_Access; - - begin - if Entry_Call.Called_Task /= null then - STPO.Unlock (Entry_Call.Called_Task); - else - Called_PO := To_Protection (Entry_Call.Called_PO); - - if Called_PO.Pending_Action then - Called_PO.Pending_Action := False; - Caller := STPO.Self; - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Caller); - Caller.New_Base_Priority := Called_PO.Old_Base_Priority; - Initialization.Change_Base_Priority (Caller); - STPO.Unlock (Caller); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - end if; - - Unlock_Entries (Called_PO); - - if Single_Lock then - STPO.Lock_RTS; - end if; - end if; - end Unlock_Server; - - ------------------------- - -- Wait_For_Completion -- - ------------------------- - - procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is - Self_Id : constant Task_Id := Entry_Call.Self; - - begin - -- If this is a conditional call, it should be cancelled when it - -- becomes abortable. This is checked in the loop below. - - Self_Id.Common.State := Entry_Caller_Sleep; - - -- Try to remove calls to Sleep in the loop below by letting the caller - -- a chance of getting ready immediately, using Unlock & Yield. - -- See similar action in Wait_For_Call & Timed_Selective_Wait. - - if Single_Lock then - STPO.Unlock_RTS; - else - STPO.Unlock (Self_Id); - end if; - - if Entry_Call.State < Done then - STPO.Yield; - end if; - - if Single_Lock then - STPO.Lock_RTS; - else - STPO.Write_Lock (Self_Id); - end if; - - loop - Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); - - exit when Entry_Call.State >= Done; - - STPO.Sleep (Self_Id, Entry_Caller_Sleep); - end loop; - - Self_Id.Common.State := Runnable; - Utilities.Exit_One_ATC_Level (Self_Id); - - end Wait_For_Completion; - - -------------------------------------- - -- Wait_For_Completion_With_Timeout -- - -------------------------------------- - - procedure Wait_For_Completion_With_Timeout - (Entry_Call : Entry_Call_Link; - Wakeup_Time : Duration; - Mode : Delay_Modes; - Yielded : out Boolean) - is - Self_Id : constant Task_Id := Entry_Call.Self; - Timedout : Boolean := False; - - begin - -- This procedure waits for the entry call to be served, with a timeout. - -- It tries to cancel the call if the timeout expires before the call is - -- served. - - -- If we wake up from the timed sleep operation here, it may be for - -- several possible reasons: - - -- 1) The entry call is done being served. - -- 2) There is an abort or priority change to be served. - -- 3) The timeout has expired (Timedout = True) - -- 4) There has been a spurious wakeup. - - -- Once the timeout has expired we may need to continue to wait if the - -- call is already being serviced. In that case, we want to go back to - -- sleep, but without any timeout. The variable Timedout is used to - -- control this. If the Timedout flag is set, we do not need to - -- STPO.Sleep with a timeout. We just sleep until we get a wakeup for - -- some status change. - - -- The original call may have become abortable after waking up. We want - -- to check Check_Pending_Actions_For_Entry_Call again in any case. - - pragma Assert (Entry_Call.Mode = Timed_Call); - - Yielded := False; - Self_Id.Common.State := Entry_Caller_Sleep; - - -- Looping is necessary in case the task wakes up early from the timed - -- sleep, due to a "spurious wakeup". Spurious wakeups are a weakness of - -- POSIX condition variables. A thread waiting for a condition variable - -- is allowed to wake up at any time, not just when the condition is - -- signaled. See same loop in the ordinary Wait_For_Completion, above. - - loop - Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); - exit when Entry_Call.State >= Done; - - STPO.Timed_Sleep (Self_Id, Wakeup_Time, Mode, - Entry_Caller_Sleep, Timedout, Yielded); - - if Timedout then - -- Try to cancel the call (see Try_To_Cancel_Entry_Call for - -- corresponding code in the ATC case). - - Entry_Call.Cancellation_Attempted := True; - - -- Reset Entry_Call.State so that the call is marked as cancelled - -- by Check_Pending_Actions_For_Entry_Call below. - - if Entry_Call.State < Was_Abortable then - Entry_Call.State := Now_Abortable; - end if; - - if Self_Id.Pending_ATC_Level >= Entry_Call.Level then - Self_Id.Pending_ATC_Level := Entry_Call.Level - 1; - end if; - - -- The following loop is the same as the loop and exit code - -- from the ordinary Wait_For_Completion. If we get here, we - -- have timed out but we need to keep waiting until the call - -- has actually completed or been cancelled successfully. - - loop - Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); - exit when Entry_Call.State >= Done; - STPO.Sleep (Self_Id, Entry_Caller_Sleep); - end loop; - - Self_Id.Common.State := Runnable; - Utilities.Exit_One_ATC_Level (Self_Id); - - return; - end if; - end loop; - - -- This last part is the same as ordinary Wait_For_Completion, - -- and is only executed if the call completed without timing out. - - Self_Id.Common.State := Runnable; - Utilities.Exit_One_ATC_Level (Self_Id); - end Wait_For_Completion_With_Timeout; - - -------------------------- - -- Wait_Until_Abortable -- - -------------------------- - - procedure Wait_Until_Abortable - (Self_ID : Task_Id; - Call : Entry_Call_Link) - is - begin - pragma Assert (Self_ID.ATC_Nesting_Level > 0); - pragma Assert (Call.Mode = Asynchronous_Call); - - STPO.Write_Lock (Self_ID); - Self_ID.Common.State := Entry_Caller_Sleep; - - loop - Check_Pending_Actions_For_Entry_Call (Self_ID, Call); - exit when Call.State >= Was_Abortable; - STPO.Sleep (Self_ID, Async_Select_Sleep); - end loop; - - Self_ID.Common.State := Runnable; - STPO.Unlock (Self_ID); - - end Wait_Until_Abortable; - -end System.Tasking.Entry_Calls; diff --git a/gcc/ada/s-taenca.ads b/gcc/ada/s-taenca.ads deleted file mode 100644 index 6c8d66f5778..00000000000 --- a/gcc/ada/s-taenca.ads +++ /dev/null @@ -1,97 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . E N T R Y _ C A L L S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - --- This package provides internal RTS calls implementing operations --- that apply to general entry calls, that is, calls to either --- protected or task entries. - --- These declarations are not part of the GNARL Interface - -package System.Tasking.Entry_Calls is - - procedure Wait_For_Completion (Entry_Call : Entry_Call_Link); - -- This procedure suspends the calling task until the specified entry - -- call has either been completed or cancelled. It performs other - -- operations required of suspended tasks, such as performing - -- dynamic priority changes. On exit, the call will not be queued. - -- This waits for calls on task or protected entries. - -- Abortion must be deferred when calling this procedure. - -- Call this only when holding Self (= Entry_Call.Self) or global RTS lock. - - procedure Wait_For_Completion_With_Timeout - (Entry_Call : Entry_Call_Link; - Wakeup_Time : Duration; - Mode : Delay_Modes; - Yielded : out Boolean); - -- Same as Wait_For_Completion but wait for a timeout with the value - -- specified in Wakeup_Time as well. - -- On return, Yielded indicates whether the wait has performed a yield. - -- Check_Exception must be called after calling this procedure. - - procedure Wait_Until_Abortable - (Self_ID : Task_Id; - Call : Entry_Call_Link); - -- This procedure suspends the calling task until the specified entry - -- call is queued abortably or completes. - -- Abortion must be deferred when calling this procedure, and the global - -- RTS lock taken when Single_Lock. - - procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean); - pragma Inline (Try_To_Cancel_Entry_Call); - -- Try to cancel async. entry call. - -- Effect includes Abort_To_Level and Wait_For_Completion. - -- Cancelled = True iff the cancellation was successful, i.e., - -- the call was not Done before this call. - -- On return, the call is off-queue and the ATC level is reduced by one. - - procedure Reset_Priority - (Acceptor : Task_Id; - Acceptor_Prev_Priority : Rendezvous_Priority); - pragma Inline (Reset_Priority); - -- Reset the priority of a task completing an accept statement to - -- the value it had before the call. - -- Acceptor should always be equal to Self. - - procedure Check_Exception - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link); - pragma Inline (Check_Exception); - -- Raise any pending exception from the Entry_Call. - -- This should be called at the end of every compiler interface procedure - -- that implements an entry call. - -- In principle, the caller should not be abort-deferred (unless the - -- application program violates the Ada language rules by doing entry calls - -- from within protected operations -- an erroneous practice apparently - -- followed with success by some adventurous GNAT users). - -- Absolutely, the caller should not be holding any locks, or there - -- will be deadlock. - -end System.Tasking.Entry_Calls; diff --git a/gcc/ada/s-taprob.adb b/gcc/ada/s-taprob.adb deleted file mode 100644 index 8ba5198cce7..00000000000 --- a/gcc/ada/s-taprob.adb +++ /dev/null @@ -1,271 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1991-1997, 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. -- --- -- ------------------------------------------------------------------------------- - -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.Task_Primitives.Operations; -with System.Soft_Links.Tasking; - -with System.Secondary_Stack; -pragma Elaborate_All (System.Secondary_Stack); -pragma Unreferenced (System.Secondary_Stack); --- Make sure the body of Secondary_Stack is elaborated before calling --- Init_Tasking_Soft_Links. See comments for this routine for explanation. - -package body System.Tasking.Protected_Objects is - - use System.Task_Primitives.Operations; - - ---------------- - -- Local Data -- - ---------------- - - Locking_Policy : Character; - pragma Import (C, Locking_Policy, "__gl_locking_policy"); - - ------------------------- - -- Finalize_Protection -- - ------------------------- - - procedure Finalize_Protection (Object : in out Protection) is - begin - Finalize_Lock (Object.L'Unrestricted_Access); - end Finalize_Protection; - - --------------------------- - -- Initialize_Protection -- - --------------------------- - - procedure Initialize_Protection - (Object : Protection_Access; - Ceiling_Priority : Integer) - is - Init_Priority : Integer := Ceiling_Priority; - - begin - if Init_Priority = Unspecified_Priority then - Init_Priority := System.Priority'Last; - end if; - - Initialize_Lock (Init_Priority, Object.L'Access); - Object.Ceiling := System.Any_Priority (Init_Priority); - Object.New_Ceiling := System.Any_Priority (Init_Priority); - Object.Owner := Null_Task; - end Initialize_Protection; - - ----------------- - -- Get_Ceiling -- - ----------------- - - function Get_Ceiling - (Object : Protection_Access) return System.Any_Priority is - begin - return Object.New_Ceiling; - end Get_Ceiling; - - ---------- - -- Lock -- - ---------- - - procedure Lock (Object : Protection_Access) is - Ceiling_Violation : Boolean; - - begin - -- The lock is made without deferring abort - - -- Therefore the abort has to be deferred before calling this routine. - -- This means that the compiler has to generate a Defer_Abort call - -- before the call to Lock. - - -- The caller is responsible for undeferring abort, and compiler - -- generated calls must be protected with cleanup handlers to ensure - -- that abort is undeferred in all cases. - - -- If pragma Detect_Blocking is active then, as described in the ARM - -- 9.5.1, par. 15, we must check whether this is an external call on a - -- protected subprogram with the same target object as that of the - -- protected action that is currently in progress (i.e., if the caller - -- is already the protected object's owner). If this is the case hence - -- Program_Error must be raised. - - if Detect_Blocking and then Object.Owner = Self then - raise Program_Error; - end if; - - Write_Lock (Object.L'Access, Ceiling_Violation); - - if Ceiling_Violation then - raise Program_Error; - end if; - - -- We are entering in a protected action, so that we increase the - -- protected object nesting level (if pragma Detect_Blocking is - -- active), and update the protected object's owner. - - if Detect_Blocking then - declare - Self_Id : constant Task_Id := Self; - begin - -- Update the protected object's owner - - Object.Owner := Self_Id; - - -- Increase protected object nesting level - - Self_Id.Common.Protected_Action_Nesting := - Self_Id.Common.Protected_Action_Nesting + 1; - end; - end if; - end Lock; - - -------------------- - -- Lock_Read_Only -- - -------------------- - - procedure Lock_Read_Only (Object : Protection_Access) is - Ceiling_Violation : Boolean; - - begin - -- If pragma Detect_Blocking is active then, as described in the ARM - -- 9.5.1, par. 15, we must check whether this is an external call on - -- protected subprogram with the same target object as that of the - -- protected action that is currently in progress (i.e., if the caller - -- is already the protected object's owner). If this is the case hence - -- Program_Error must be raised. - -- - -- Note that in this case (getting read access), several tasks may have - -- read ownership of the protected object, so that this method of - -- storing the (single) protected object's owner does not work reliably - -- for read locks. However, this is the approach taken for two major - -- reasons: first, this function is not currently being used (it is - -- provided for possible future use), and second, it largely simplifies - -- the implementation. - - if Detect_Blocking and then Object.Owner = Self then - raise Program_Error; - end if; - - Read_Lock (Object.L'Access, Ceiling_Violation); - - if Ceiling_Violation then - raise Program_Error; - end if; - - -- We are entering in a protected action, so we increase the protected - -- object nesting level (if pragma Detect_Blocking is active). - - if Detect_Blocking then - declare - Self_Id : constant Task_Id := Self; - begin - -- Update the protected object's owner - - Object.Owner := Self_Id; - - -- Increase protected object nesting level - - Self_Id.Common.Protected_Action_Nesting := - Self_Id.Common.Protected_Action_Nesting + 1; - end; - end if; - end Lock_Read_Only; - - ----------------- - -- Set_Ceiling -- - ----------------- - - procedure Set_Ceiling - (Object : Protection_Access; - Prio : System.Any_Priority) is - begin - Object.New_Ceiling := Prio; - end Set_Ceiling; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (Object : Protection_Access) is - begin - -- We are exiting from a protected action, so that we decrease the - -- protected object nesting level (if pragma Detect_Blocking is - -- active), and remove ownership of the protected object. - - if Detect_Blocking then - declare - Self_Id : constant Task_Id := Self; - - begin - -- Calls to this procedure can only take place when being within - -- a protected action and when the caller is the protected - -- object's owner. - - pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 - and then Object.Owner = Self_Id); - - -- Remove ownership of the protected object - - Object.Owner := Null_Task; - - -- We are exiting from a protected action, so we decrease the - -- protected object nesting level. - - Self_Id.Common.Protected_Action_Nesting := - Self_Id.Common.Protected_Action_Nesting - 1; - end; - end if; - - -- Before releasing the mutex we must actually update its ceiling - -- priority if it has been changed. - - if Object.New_Ceiling /= Object.Ceiling then - if Locking_Policy = 'C' then - System.Task_Primitives.Operations.Set_Ceiling - (Object.L'Access, Object.New_Ceiling); - end if; - - Object.Ceiling := Object.New_Ceiling; - end if; - - Unlock (Object.L'Access); - - end Unlock; - -begin - -- Ensure that tasking is initialized, as well as tasking soft links - -- when using protected objects. - - Tasking.Initialize; - System.Soft_Links.Tasking.Init_Tasking_Soft_Links; -end System.Tasking.Protected_Objects; diff --git a/gcc/ada/s-taprob.ads b/gcc/ada/s-taprob.ads deleted file mode 100644 index 98bc4b2b36d..00000000000 --- a/gcc/ada/s-taprob.ads +++ /dev/null @@ -1,241 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - --- This package provides necessary definitions to handle simple (i.e without --- entries) protected objects. - --- All the routines that handle protected objects with entries have been moved --- to two children: Entries and Operations. Note that Entries only contains --- the type declaration and the OO primitives. This is needed to avoid --- circular dependency. - --- This package is part of the high level tasking interface used by the --- compiler to expand Ada 95 tasking constructs into simpler run time calls --- (aka GNARLI, GNU Ada Run-time Library Interface) - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes --- in exp_ch9.adb and possibly exp_ch7.adb and exp_attr.adb - -package System.Tasking.Protected_Objects is - pragma Elaborate_Body; - - --------------------------------- - -- Compiler Interface (GNARLI) -- - --------------------------------- - - -- The compiler will expand in the GNAT tree the following construct: - - -- protected PO is - -- procedure P; - -- private - -- open : boolean := false; - -- end PO; - - -- protected body PO is - -- procedure P is - -- ...variable declarations... - -- begin - -- ...B... - -- end P; - -- end PO; - - -- as follows: - - -- protected type poT is - -- procedure p; - -- private - -- open : boolean := false; - -- end poT; - -- type poTV is limited record - -- open : boolean := false; - -- _object : aliased protection; - -- end record; - -- procedure poPT__pN (_object : in out poTV); - -- procedure poPT__pP (_object : in out poTV); - -- freeze poTV [ - -- procedure poTVI (_init : in out poTV) is - -- begin - -- _init.open := false; - -- object-init-proc (_init._object); - -- initialize_protection (_init._object'unchecked_access, - -- unspecified_priority); - -- return; - -- end _init_proc; - -- ] - -- po : poT; - -- poTVI (poTV!(po)); - - -- procedure poPT__pN (_object : in out poTV) is - -- poR : protection renames _object._object; - -- openP : boolean renames _object.open; - -- ...variable declarations... - -- begin - -- ...B... - -- return; - -- end poPT__pN; - - -- procedure poPT__pP (_object : in out poTV) is - -- procedure _clean is - -- begin - -- unlock (_object._object'unchecked_access); - -- return; - -- end _clean; - -- begin - -- lock (_object._object'unchecked_access); - -- B2b : begin - -- poPT__pN (_object); - -- at end - -- _clean; - -- end B2b; - -- return; - -- end poPT__pP; - - Null_Protected_Entry : constant := Null_Entry; - - Max_Protected_Entry : constant := Max_Entry; - - type Protected_Entry_Index is new Entry_Index - range Null_Protected_Entry .. Max_Protected_Entry; - - type Barrier_Function_Pointer is access - function - (O : System.Address; - E : Protected_Entry_Index) - return Boolean; - -- Pointer to a function which evaluates the barrier of a protected - -- entry body. O is a pointer to the compiler-generated record - -- representing the protected object, and E is the index of the - -- entry serviced by the body. - - type Entry_Action_Pointer is access - procedure - (O : System.Address; - P : System.Address; - E : Protected_Entry_Index); - -- Pointer to a procedure which executes the sequence of statements - -- of a protected entry body. O is a pointer to the compiler-generated - -- record representing the protected object, P is a pointer to the - -- record of entry parameters, and E is the index of the - -- entry serviced by the body. - - type Entry_Body is record - Barrier : Barrier_Function_Pointer; - Action : Entry_Action_Pointer; - end record; - -- The compiler-generated code passes objects of this type to the GNARL - -- to allow it to access the executable code of an entry body and its - -- barrier. - - type Protection is limited private; - -- This type contains the GNARL state of a protected object. The - -- application-defined portion of the state (i.e. private objects) - -- is maintained by the compiler-generated code. - -- Note that there are now 2 Protection types. One for the simple - -- case (no entries) and one for the general case that needs the whole - -- Finalization mechanism. - -- This split helps in the case of restricted run time where we want to - -- minimize the size of the code. - - type Protection_Access is access all Protection; - - Null_PO : constant Protection_Access := null; - - function Get_Ceiling - (Object : Protection_Access) return System.Any_Priority; - -- Returns the new ceiling priority of the protected object - - procedure Initialize_Protection - (Object : Protection_Access; - Ceiling_Priority : Integer); - -- Initialize the Object parameter so that it can be used by the runtime - -- to keep track of the runtime state of a protected object. - - procedure Lock (Object : Protection_Access); - -- Lock a protected object for write access. Upon return, the caller - -- owns the lock to this object, and no other call to Lock or - -- Lock_Read_Only with the same argument will return until the - -- corresponding call to Unlock has been made by the caller. - - procedure Lock_Read_Only (Object : Protection_Access); - -- Lock a protected object for read access. Upon return, the caller - -- owns the lock for read access, and no other calls to Lock with the - -- same argument will return until the corresponding call to Unlock - -- has been made by the caller. Other calls to Lock_Read_Only may (but - -- need not) return before the call to Unlock, and the corresponding - -- callers will also own the lock for read access. - - procedure Set_Ceiling - (Object : Protection_Access; - Prio : System.Any_Priority); - -- Sets the new ceiling priority of the protected object - - procedure Unlock (Object : Protection_Access); - -- Relinquish ownership of the lock for the object represented by - -- the Object parameter. If this ownership was for write access, or - -- if it was for read access where there are no other read access - -- locks outstanding, one (or more, in the case of Lock_Read_Only) - -- of the tasks waiting on this lock (if any) will be given the - -- lock and allowed to return from the Lock or Lock_Read_Only call. - -private - type Protection is record - L : aliased Task_Primitives.Lock; - -- Lock used to ensure mutual exclusive access to the protected object - - Ceiling : System.Any_Priority; - -- Ceiling priority associated to the protected object - - New_Ceiling : System.Any_Priority; - -- New ceiling priority associated to the protected object. In case - -- of assignment of a new ceiling priority to the protected object the - -- frontend generates a call to set_ceiling to save the new value in - -- this field. After such assignment this value can be read by means - -- of the 'Priority attribute, which generates a call to get_ceiling. - -- However, the ceiling of the protected object will not be changed - -- until completion of the protected action in which the assignment - -- has been executed (AARM D.5.2 (10/2)). - - Owner : Task_Id; - -- This field contains the protected object's owner. Null_Task - -- indicates that the protected object is not currently being used. - -- This information is used for detecting the type of potentially - -- blocking operations described in the ARM 9.5.1, par. 15 (external - -- calls on a protected subprogram with the same target object as that - -- of the protected action). - end record; - - procedure Finalize_Protection (Object : in out Protection); - -- Clean up a Protection object (in particular, finalize the associated - -- Lock object). The compiler generates calls automatically to this - -- procedure - -end System.Tasking.Protected_Objects; diff --git a/gcc/ada/s-taprop-dummy.adb b/gcc/ada/s-taprop-dummy.adb deleted file mode 100644 index 61cb2940c68..00000000000 --- a/gcc/ada/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-2012, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License 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/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb deleted file mode 100644 index 1c5dcc1a024..00000000000 --- a/gcc/ada/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/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb deleted file mode 100644 index cc49205cf0a..00000000000 --- a/gcc/ada/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/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb deleted file mode 100644 index e3d0842953c..00000000000 --- a/gcc/ada/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-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. -- --- -- ------------------------------------------------------------------------------- - --- 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/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb deleted file mode 100644 index fc647aa2d5e..00000000000 --- a/gcc/ada/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-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. -- --- -- ------------------------------------------------------------------------------- - --- 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/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb deleted file mode 100644 index a508c42e224..00000000000 --- a/gcc/ada/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-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 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/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb deleted file mode 100644 index 3b0dca37ae5..00000000000 --- a/gcc/ada/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-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 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/s-taprop.ads b/gcc/ada/s-taprop.ads deleted file mode 100644 index efe9dd265a1..00000000000 --- a/gcc/ada/s-taprop.ads +++ /dev/null @@ -1,571 +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 -- --- -- --- S p e c -- --- -- --- 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. -- --- -- ------------------------------------------------------------------------------- - --- This package contains all the GNULL primitives that interface directly with --- the underlying OS. - -with System.Parameters; -with System.Tasking; -with System.OS_Interface; - -package System.Task_Primitives.Operations is - pragma Preelaborate; - - package ST renames System.Tasking; - package OSI renames System.OS_Interface; - - procedure Initialize (Environment_Task : ST.Task_Id); - -- Perform initialization and set up of the environment task for proper - -- operation of the tasking run-time. This must be called once, before any - -- other subprograms of this package are called. - - procedure Create_Task - (T : ST.Task_Id; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean); - pragma Inline (Create_Task); - -- Create a new low-level task with ST.Task_Id T and place other needed - -- information in the ATCB. - -- - -- A new thread of control is created, with a stack of at least Stack_Size - -- storage units, and the procedure Wrapper is called by this new thread - -- of control. If Stack_Size = Unspecified_Storage_Size, choose a default - -- stack size; this may be effectively "unbounded" on some systems. - -- - -- The newly created low-level task is associated with the ST.Task_Id T - -- such that any subsequent call to Self from within the context of the - -- low-level task returns T. - -- - -- The caller is responsible for ensuring that the storage of the Ada - -- task control block object pointed to by T persists for the lifetime - -- of the new task. - -- - -- Succeeded is set to true unless creation of the task failed, - -- as it may if there are insufficient resources to create another task. - - procedure Enter_Task (Self_ID : ST.Task_Id); - pragma Inline (Enter_Task); - -- Initialize data structures specific to the calling task. Self must be - -- the ID of the calling task. It must be called (once) by the task - -- immediately after creation, while abort is still deferred. The effects - -- of other operations defined below are not defined unless the caller has - -- previously called Initialize_Task. - - procedure Exit_Task; - pragma Inline (Exit_Task); - -- Destroy the thread of control. Self must be the ID of the calling task. - -- The effects of further calls to operations defined below on the task - -- are undefined thereafter. - - ---------------------------------- - -- ATCB allocation/deallocation -- - ---------------------------------- - - package ATCB_Allocation is - - function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id; - pragma Inline (New_ATCB); - -- Allocate a new ATCB with the specified number of entries - - procedure Free_ATCB (T : ST.Task_Id); - pragma Inline (Free_ATCB); - -- Deallocate an ATCB previously allocated by New_ATCB - - end ATCB_Allocation; - - function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id - renames ATCB_Allocation.New_ATCB; - - procedure Initialize_TCB (Self_ID : ST.Task_Id; Succeeded : out Boolean); - pragma Inline (Initialize_TCB); - -- Initialize all fields of the TCB - - procedure Finalize_TCB (T : ST.Task_Id); - pragma Inline (Finalize_TCB); - -- Finalizes Private_Data of ATCB, and then deallocates it. This is also - -- responsible for recovering any storage or other resources that were - -- allocated by Create_Task (the one in this package). This should only be - -- called from Free_Task. After it is called there should be no further - -- reference to the ATCB that corresponds to T. - - procedure Abort_Task (T : ST.Task_Id); - pragma Inline (Abort_Task); - -- Abort the task specified by T (the target task). This causes the target - -- task to asynchronously raise Abort_Signal if abort is not deferred, or - -- if it is blocked on an interruptible system call. - -- - -- precondition: - -- the calling task is holding T's lock and has abort deferred - -- - -- postcondition: - -- the calling task is holding T's lock and has abort deferred. - - -- ??? modify GNARL to skip wakeup and always call Abort_Task - - function Self return ST.Task_Id; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task - - type Lock_Level is - (PO_Level, - Global_Task_Level, - RTS_Lock_Level, - ATCB_Level); - -- Type used to describe kind of lock for second form of Initialize_Lock - -- call specified below. See locking rules in System.Tasking (spec) for - -- more details. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : not null access Lock); - procedure Initialize_Lock - (L : not null access RTS_Lock; - Level : Lock_Level); - pragma Inline (Initialize_Lock); - -- Initialize a lock object - -- - -- For Lock, Prio is the ceiling priority associated with the lock. For - -- RTS_Lock, the ceiling is implicitly Priority'Last. - -- - -- If the underlying system does not support priority ceiling - -- locking, the Prio parameter is ignored. - -- - -- The effect of either initialize operation is undefined unless is a lock - -- object that has not been initialized, or which has been finalized since - -- it was last initialized. - -- - -- The effects of the other operations on lock objects are undefined - -- unless the lock object has been initialized and has not since been - -- finalized. - -- - -- Initialization of the per-task lock is implicit in Create_Task - -- - -- These operations raise Storage_Error if a lack of storage is detected - - procedure Finalize_Lock (L : not null access Lock); - procedure Finalize_Lock (L : not null access RTS_Lock); - pragma Inline (Finalize_Lock); - -- Finalize a lock object, freeing any resources allocated by the - -- corresponding Initialize_Lock operation. - - procedure Write_Lock - (L : not null access Lock; - Ceiling_Violation : out Boolean); - procedure Write_Lock - (L : not null access RTS_Lock; - Global_Lock : Boolean := False); - procedure Write_Lock - (T : ST.Task_Id); - pragma Inline (Write_Lock); - -- Lock a lock object for write access. After this operation returns, - -- the calling task holds write permission for the lock object. No other - -- Write_Lock or Read_Lock operation on the same lock object will return - -- until this task executes an Unlock operation on the same object. The - -- effect is undefined if the calling task already holds read or write - -- permission for the lock object L. - -- - -- For the operation on Lock, Ceiling_Violation is set to true iff the - -- operation failed, which will happen if there is a priority ceiling - -- violation. - -- - -- For the operation on RTS_Lock, Global_Lock should be set to True - -- if L is a global lock (Single_RTS_Lock, Global_Task_Lock). - -- - -- For the operation on ST.Task_Id, the lock is the special lock object - -- associated with that task's ATCB. This lock has effective ceiling - -- priority high enough that it is safe to call by a task with any - -- priority in the range System.Priority. It is implicitly initialized - -- by task creation. The effect is undefined if the calling task already - -- holds T's lock, or has interrupt-level priority. Finalization of the - -- per-task lock is implicit in Exit_Task. - - procedure Read_Lock - (L : not null access Lock; - Ceiling_Violation : out Boolean); - pragma Inline (Read_Lock); - -- Lock a lock object for read access. After this operation returns, - -- the calling task has non-exclusive read permission for the logical - -- resources that are protected by the lock. No other Write_Lock operation - -- on the same object will return until this task and any other tasks with - -- read permission for this lock have executed Unlock operation(s) on the - -- lock object. A Read_Lock for a lock object may return immediately while - -- there are tasks holding read permission, provided there are no tasks - -- holding write permission for the object. The effect is undefined if - -- the calling task already holds read or write permission for L. - -- - -- Alternatively: An implementation may treat Read_Lock identically to - -- Write_Lock. This simplifies the implementation, but reduces the level - -- of concurrency that can be achieved. - -- - -- Note that Read_Lock is not defined for RT_Lock and ST.Task_Id. - -- That is because (1) so far Read_Lock has always been implemented - -- the same as Write_Lock, (2) most lock usage inside the RTS involves - -- potential write access, and (3) implementations of priority ceiling - -- locking that make a reader-writer distinction have higher overhead. - - procedure Unlock - (L : not null access Lock); - procedure Unlock - (L : not null access RTS_Lock; - Global_Lock : Boolean := False); - procedure Unlock - (T : ST.Task_Id); - pragma Inline (Unlock); - -- Unlock a locked lock object - -- - -- The effect is undefined unless the calling task holds read or write - -- permission for the lock L, and L is the lock object most recently - -- locked by the calling task for which the calling task still holds - -- read or write permission. (That is, matching pairs of Lock and Unlock - -- operations on each lock object must be properly nested.) - - -- For the operation on RTS_Lock, Global_Lock should be set to True if L - -- is a global lock (Single_RTS_Lock, Global_Task_Lock). - -- - -- Note that Write_Lock for RTS_Lock does not have an out-parameter. - -- RTS_Locks are used in situations where we have not made provision for - -- recovery from ceiling violations. We do not expect them to occur inside - -- the runtime system, because all RTS locks have ceiling Priority'Last. - - -- There is one way there can be a ceiling violation. That is if the - -- runtime system is called from a task that is executing in the - -- Interrupt_Priority range. - - -- It is not clear what to do about ceiling violations due to RTS calls - -- done at interrupt priority. In general, it is not acceptable to give - -- all RTS locks interrupt priority, since that would give terrible - -- performance on systems where this has the effect of masking hardware - -- interrupts, though we could get away allowing Interrupt_Priority'last - -- where we are layered on an OS that does not allow us to mask interrupts. - -- Ideally, we would like to raise Program_Error back at the original point - -- of the RTS call, but this would require a lot of detailed analysis and - -- recoding, with almost certain performance penalties. - - -- For POSIX systems, we considered just skipping setting priority ceiling - -- on RTS locks. This would mean there is no ceiling violation, but we - -- would end up with priority inversions inside the runtime system, - -- resulting in failure to satisfy the Ada priority rules, and possible - -- missed validation tests. This could be compensated-for by explicit - -- priority-change calls to raise the caller to Priority'Last whenever it - -- first enters the runtime system, but the expected overhead seems high, - -- though it might be lower than using locks with ceilings if the - -- underlying implementation of ceiling locks is an inefficient one. - - -- This issue should be reconsidered whenever we get around to checking - -- for calls to potentially blocking operations from within protected - -- operations. If we check for such calls and catch them on entry to the - -- OS, it may be that we can eliminate the possibility of ceiling - -- violations inside the RTS. For this to work, we would have to forbid - -- explicitly setting the priority of a task to anything in the - -- Interrupt_Priority range, at least. We would also have to check that - -- there are no RTS-lock operations done inside any operations that are - -- not treated as potentially blocking. - - -- The latter approach seems to be the best, i.e. to check on entry to RTS - -- calls that may need to use locks that the priority is not in the - -- interrupt range. If there are RTS operations that NEED to be called - -- from interrupt handlers, those few RTS locks should then be converted - -- to PO-type locks, with ceiling Interrupt_Priority'Last. - - -- For now, we will just shut down the system if there is ceiling violation - - procedure Set_Ceiling - (L : not null access Lock; - Prio : System.Any_Priority); - pragma Inline (Set_Ceiling); - -- Change the ceiling priority associated to the lock - -- - -- The effect is undefined unless the calling task holds read or write - -- permission for the lock L, and L is the lock object most recently - -- locked by the calling task for which the calling task still holds - -- read or write permission. (That is, matching pairs of Lock and Unlock - -- operations on each lock object must be properly nested.) - - procedure Yield (Do_Yield : Boolean := True); - pragma Inline (Yield); - -- Yield the processor. Add the calling task to the tail of the ready queue - -- for its active_priority. On most platforms, Yield is a no-op if Do_Yield - -- is False. But on some platforms (notably VxWorks), Do_Yield is ignored. - -- This is only used in some very rare cases where a Yield should have an - -- effect on a specific target and not on regular ones. - - procedure Set_Priority - (T : ST.Task_Id; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False); - pragma Inline (Set_Priority); - -- Set the priority of the task specified by T to Prio. The priority set - -- is what would correspond to the Ada concept of "base priority" in the - -- terms of the lower layer system, but the operation may be used by the - -- upper layer to implement changes in "active priority" that are not due - -- to lock effects. The effect should be consistent with the Ada Reference - -- Manual. In particular, when a task lowers its priority due to the loss - -- of inherited priority, it goes at the head of the queue for its new - -- priority (RM D.2.2 par 9). Loss_Of_Inheritance helps the underlying - -- implementation to do it right when the OS doesn't. - - function Get_Priority (T : ST.Task_Id) return System.Any_Priority; - pragma Inline (Get_Priority); - -- Returns the priority last set by Set_Priority for this task - - function Monotonic_Clock return Duration; - pragma Inline (Monotonic_Clock); - -- Returns "absolute" time, represented as an offset relative to "the - -- Epoch", which is Jan 1, 1970. This clock implementation is immune to - -- the system's clock changes. - - function RT_Resolution return Duration; - pragma Inline (RT_Resolution); - -- Returns resolution of the underlying clock used to implement RT_Clock - - ---------------- - -- Extensions -- - ---------------- - - -- Whoever calls either of the Sleep routines is responsible for checking - -- for pending aborts before the call. Pending priority changes are handled - -- internally. - - procedure Sleep - (Self_ID : ST.Task_Id; - Reason : System.Tasking.Task_States); - pragma Inline (Sleep); - -- Wait until the current task, T, is signaled to wake up - -- - -- precondition: - -- The calling task is holding its own ATCB lock - -- and has abort deferred - -- - -- postcondition: - -- The calling task is holding its own ATCB lock and has abort deferred. - - -- The effect is to atomically unlock T's lock and wait, so that another - -- task that is able to lock T's lock can be assured that the wait has - -- actually commenced, and that a Wakeup operation will cause the waiting - -- task to become ready for execution once again. When Sleep returns, the - -- waiting task will again hold its own ATCB lock. The waiting task may - -- become ready for execution at any time (that is, spurious wakeups are - -- permitted), but it will definitely become ready for execution when a - -- Wakeup operation is performed for the same task. - - procedure Timed_Sleep - (Self_ID : ST.Task_Id; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean); - -- Combination of Sleep (above) and Timed_Delay - - procedure Timed_Delay - (Self_ID : ST.Task_Id; - Time : Duration; - Mode : ST.Delay_Modes); - -- Implement the semantics of the delay statement. - -- The caller should be abort-deferred and should not hold any locks. - - procedure Wakeup - (T : ST.Task_Id; - Reason : System.Tasking.Task_States); - pragma Inline (Wakeup); - -- Wake up task T if it is waiting on a Sleep call (of ordinary - -- or timed variety), making it ready for execution once again. - -- If the task T is not waiting on a Sleep, the operation has no effect. - - function Environment_Task return ST.Task_Id; - pragma Inline (Environment_Task); - -- Return the task ID of the environment task - -- Consider putting this into a variable visible directly - -- by the rest of the runtime system. ??? - - function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id; - -- Return the thread id of the specified task - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does the calling thread have an ATCB? - - function Register_Foreign_Thread return ST.Task_Id; - -- Allocate and initialize a new ATCB for the current thread - - ----------------------- - -- RTS Entrance/Exit -- - ----------------------- - - -- Following two routines are used for possible operations needed to be - -- setup/cleared upon entrance/exit of RTS while maintaining a single - -- thread of control in the RTS. Since we intend these routines to be used - -- for implementing the Single_Lock RTS, Lock_RTS should follow the first - -- Defer_Abort operation entering RTS. In the same fashion Unlock_RTS - -- should precede the last Undefer_Abort exiting RTS. - -- - -- These routines also replace the functions Lock/Unlock_All_Tasks_List - - procedure Lock_RTS; - -- Take the global RTS lock - - procedure Unlock_RTS; - -- Release the global RTS lock - - -------------------- - -- Stack Checking -- - -------------------- - - -- Stack checking in GNAT is done using the concept of stack probes. A - -- stack probe is an operation that will generate a storage error if - -- an insufficient amount of stack space remains in the current task. - - -- The exact mechanism for a stack probe is target dependent. Typical - -- possibilities are to use a load from a non-existent page, a store to a - -- read-only page, or a comparison with some stack limit constant. Where - -- possible we prefer to use a trap on a bad page access, since this has - -- less overhead. The generation of stack probes is either automatic if - -- the ABI requires it (as on for example DEC Unix), or is controlled by - -- the gcc parameter -fstack-check. - - -- When we are using bad-page accesses, we need a bad page, called guard - -- page, at the end of each task stack. On some systems, this is provided - -- automatically, but on other systems, we need to create the guard page - -- ourselves, and the procedure Stack_Guard is provided for this purpose. - - procedure Stack_Guard (T : ST.Task_Id; On : Boolean); - -- Ensure guard page is set if one is needed and the underlying thread - -- system does not provide it. The procedure is as follows: - -- - -- 1. When we create a task adjust its size so a guard page can - -- safely be set at the bottom of the stack. - -- - -- 2. When the thread is created (and its stack allocated by the - -- underlying thread system), get the stack base (and size, depending - -- how the stack is growing), and create the guard page taking care - -- of page boundaries issues. - -- - -- 3. When the task is destroyed, remove the guard page. - -- - -- If On is true then protect the stack bottom (i.e make it read only) - -- else unprotect it (i.e. On is True for the call when creating a task, - -- and False when a task is destroyed). - -- - -- The call to Stack_Guard has no effect if guard pages are not used on - -- the target, or if guard pages are automatically provided by the system. - - ------------------------ - -- Suspension objects -- - ------------------------ - - -- These subprograms provide the functionality required for synchronizing - -- on a suspension object. Tasks can suspend execution and relinquish the - -- processors until the condition is signaled. - - function Current_State (S : Suspension_Object) return Boolean; - -- Return the state of the suspension object - - procedure Set_False (S : in out Suspension_Object); - -- Set the state of the suspension object to False - - procedure Set_True (S : in out Suspension_Object); - -- Set the state of the suspension object to True. If a task were - -- suspended on the protected object then this task is released (and - -- the state of the suspension object remains set to False). - - procedure Suspend_Until_True (S : in out Suspension_Object); - -- If the state of the suspension object is True then the calling task - -- continues its execution, and the state is set to False. If the state - -- of the object is False then the task is suspended on the suspension - -- object until a Set_True operation is executed. Program_Error is raised - -- if another task is already waiting on that suspension object. - - procedure Initialize (S : in out Suspension_Object); - -- Initialize the suspension object - - procedure Finalize (S : in out Suspension_Object); - -- Finalize the suspension object - - ----------------------------------------- - -- Runtime System Debugging Interfaces -- - ----------------------------------------- - - -- These interfaces have been added to assist in debugging the - -- tasking runtime system. - - function Check_Exit (Self_ID : ST.Task_Id) return Boolean; - pragma Inline (Check_Exit); - -- Check that the current task is holding only Global_Task_Lock - - function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean; - pragma Inline (Check_No_Locks); - -- Check that current task is holding no locks - - function Suspend_Task - (T : ST.Task_Id; - Thread_Self : OSI.Thread_Id) return Boolean; - -- Suspend a specific task when the underlying thread library provides this - -- functionality, unless the thread associated with T is Thread_Self. Such - -- functionality is needed by gdb on some targets (e.g VxWorks) Return True - -- is the operation is successful. On targets where this operation is not - -- available, a dummy body is present which always returns False. - - function Resume_Task - (T : ST.Task_Id; - Thread_Self : OSI.Thread_Id) return Boolean; - -- Resume a specific task when the underlying thread library provides - -- such functionality, unless the thread associated with T is Thread_Self. - -- Such functionality is needed by gdb on some targets (e.g VxWorks) - -- Return True is the operation is successful - - procedure Stop_All_Tasks; - -- Stop all tasks when the underlying thread library provides such - -- functionality. Such functionality is needed by gdb on some targets (e.g - -- VxWorks) This function can be run from an interrupt handler. Return True - -- is the operation is successful - - function Stop_Task (T : ST.Task_Id) return Boolean; - -- Stop a specific task when the underlying thread library provides - -- such functionality. Such functionality is needed by gdb on some targets - -- (e.g VxWorks). Return True is the operation is successful. - - function Continue_Task (T : ST.Task_Id) return Boolean; - -- Continue a specific task when the underlying thread library provides - -- such functionality. Such functionality is needed by gdb on some targets - -- (e.g VxWorks) Return True is the operation is successful - - ------------------- - -- Task affinity -- - ------------------- - - procedure Set_Task_Affinity (T : ST.Task_Id); - -- Enforce at the operating system level the task affinity defined in the - -- Ada Task Control Block. Has no effect if the underlying operating system - -- does not support this capability. - -end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb deleted file mode 100644 index 936e5fe16ee..00000000000 --- a/gcc/ada/s-tarest.adb +++ /dev/null @@ -1,810 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-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. -- --- -- ------------------------------------------------------------------------------- - -pragma Style_Checks (All_Checks); --- Turn off subprogram alpha order check, since we group soft link --- bodies and also separate off subprograms for restricted GNARLI. - --- This is a simplified version of the System.Tasking.Stages package, --- intended to be used in a restricted run time. - --- This package represents the high level tasking interface used by the --- compiler to expand Ada 95 tasking constructs into simpler run time calls. - -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.Exceptions; - -with System.Task_Primitives.Operations; -with System.Soft_Links.Tasking; -with System.Storage_Elements; - -with System.Secondary_Stack; -pragma Elaborate_All (System.Secondary_Stack); --- Make sure the body of Secondary_Stack is elaborated before calling --- Init_Tasking_Soft_Links. See comments for this routine for explanation. - -with System.Soft_Links; --- Used for the non-tasking routines (*_NT) that refer to global data. They --- are needed here before the tasking run time has been elaborated. used for --- Create_TSD This package also provides initialization routines for task --- specific data. The GNARL must call these to be sure that all non-tasking --- Ada constructs will work. - -package body System.Tasking.Restricted.Stages is - - package STPO renames System.Task_Primitives.Operations; - package SSL renames System.Soft_Links; - package SSE renames System.Storage_Elements; - package SST renames System.Secondary_Stack; - - use Ada.Exceptions; - - use Parameters; - use Task_Primitives.Operations; - use Task_Info; - - Tasks_Activation_Chain : Task_Id; - -- Chain of all the tasks to activate - - Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock; - -- This is a global lock; it is used to execute in mutual exclusion - -- from all other tasks. It is only used by Task_Lock and Task_Unlock. - - ----------------------------------------------------------------- - -- Tasking versions of services needed by non-tasking programs -- - ----------------------------------------------------------------- - - function Get_Current_Excep return SSL.EOA; - -- Task-safe version of SSL.Get_Current_Excep - - procedure Task_Lock; - -- Locks out other tasks. Preceding a section of code by Task_Lock and - -- following it by Task_Unlock creates a critical region. This is used - -- for ensuring that a region of non-tasking code (such as code used to - -- allocate memory) is tasking safe. Note that it is valid for calls to - -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e. - -- only the corresponding outer level Task_Unlock will actually unlock. - - procedure Task_Unlock; - -- Releases lock previously set by call to Task_Lock. In the nested case, - -- all nested locks must be released before other tasks competing for the - -- tasking lock are released. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Task_Wrapper (Self_ID : Task_Id); - -- This is the procedure that is called by the GNULL from the - -- new context when a task is created. It waits for activation - -- and then calls the task body procedure. When the task body - -- procedure completes, it terminates the task. - - procedure Terminate_Task (Self_ID : Task_Id); - -- Terminate the calling task. - -- This should only be called by the Task_Wrapper procedure. - - procedure Create_Restricted_Task - (Priority : Integer; - Stack_Address : System.Address; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Task_Image : String; - Created_Task : Task_Id); - -- Code shared between Create_Restricted_Task (the concurrent version) and - -- Create_Restricted_Task_Sequential. See comment of the former in the - -- specification of this package. - - procedure Activate_Tasks (Chain : Task_Id); - -- Activate the list of tasks started by Chain - - procedure Init_RTS; - -- This procedure performs the initialization of the GNARL. - -- It consists of initializing the environment task, global locks, and - -- installing tasking versions of certain operations used by the compiler. - -- Init_RTS is called during elaboration. - - ----------------------- - -- Get_Current_Excep -- - ----------------------- - - function Get_Current_Excep return SSL.EOA is - begin - return STPO.Self.Common.Compiler_Data.Current_Excep'Access; - end Get_Current_Excep; - - --------------- - -- Task_Lock -- - --------------- - - procedure Task_Lock is - Self_ID : constant Task_Id := STPO.Self; - - begin - Self_ID.Common.Global_Task_Lock_Nesting := - Self_ID.Common.Global_Task_Lock_Nesting + 1; - - if Self_ID.Common.Global_Task_Lock_Nesting = 1 then - STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True); - end if; - end Task_Lock; - - ----------------- - -- Task_Unlock -- - ----------------- - - procedure Task_Unlock is - Self_ID : constant Task_Id := STPO.Self; - - begin - pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting > 0); - Self_ID.Common.Global_Task_Lock_Nesting := - Self_ID.Common.Global_Task_Lock_Nesting - 1; - - if Self_ID.Common.Global_Task_Lock_Nesting = 0 then - STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True); - end if; - end Task_Unlock; - - ------------------ - -- Task_Wrapper -- - ------------------ - - -- The task wrapper is a procedure that is called first for each task - -- task body, and which in turn calls the compiler-generated task body - -- procedure. The wrapper's main job is to do initialization for the task. - - -- The variable ID in the task wrapper is used to implement the Self - -- function on targets where there is a fast way to find the stack base - -- of the current thread, since it should be at a fixed offset from the - -- stack base. - - procedure Task_Wrapper (Self_ID : Task_Id) is - ID : Task_Id := Self_ID; - pragma Volatile (ID); - pragma Warnings (Off, ID); - -- Variable used on some targets to implement a fast self. We turn off - -- warnings because a stand alone volatile constant has to be imported, - -- so we don't want warnings about ID not being referenced, and volatile - -- having no effect. - -- - -- DO NOT delete ID. As noted, it is needed on some targets. - - function Secondary_Stack_Size return Storage_Elements.Storage_Offset; - -- Returns the size of the secondary stack for the task. For fixed - -- secondary stacks, the function will return the ATCB field - -- Secondary_Stack_Size if it is not set to Unspecified_Size, - -- otherwise a percentage of the stack is reserved using the - -- System.Parameters.Sec_Stack_Percentage property. - - -- Dynamic secondary stacks are allocated in System.Soft_Links. - -- Create_TSD and thus the function returns 0 to suppress the - -- creation of the fixed secondary stack in the primary stack. - - -------------------------- - -- Secondary_Stack_Size -- - -------------------------- - - function Secondary_Stack_Size return Storage_Elements.Storage_Offset is - use System.Storage_Elements; - use System.Secondary_Stack; - - begin - if Parameters.Sec_Stack_Dynamic then - return 0; - - elsif Self_ID.Common.Secondary_Stack_Size = Unspecified_Size then - return (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size - * SSE.Storage_Offset (Sec_Stack_Percentage) / 100); - else - -- Use the size specified by aspect Secondary_Stack_Size padded - -- by the amount of space used by the stack data structure. - - return Storage_Offset (Self_ID.Common.Secondary_Stack_Size) + - Storage_Offset (Minimum_Secondary_Stack_Size); - end if; - end Secondary_Stack_Size; - - Secondary_Stack : aliased Storage_Elements.Storage_Array - (1 .. Secondary_Stack_Size); - for Secondary_Stack'Alignment use Standard'Maximum_Alignment; - -- This is the secondary stack data. Note that it is critical that this - -- have maximum alignment, since any kind of data can be allocated here. - - pragma Warnings (Off); - Secondary_Stack_Address : System.Address := Secondary_Stack'Address; - pragma Warnings (On); - -- Address of secondary stack. In the fixed secondary stack case, this - -- value is not modified, causing a warning, hence the bracketing with - -- Warnings (Off/On). - - Cause : Cause_Of_Termination := Normal; - -- Indicates the reason why this task terminates. Normal corresponds to - -- a task terminating due to completing the last statement of its body. - -- If the task terminates because of an exception raised by the - -- execution of its task body, then Cause is set to Unhandled_Exception. - -- Aborts are not allowed in the restricted profile to which this file - -- belongs. - - EO : Exception_Occurrence; - -- If the task terminates because of an exception raised by the - -- execution of its task body, then EO will contain the associated - -- exception occurrence. Otherwise, it will contain Null_Occurrence. - - -- Start of processing for Task_Wrapper - - begin - if not Parameters.Sec_Stack_Dynamic then - Self_ID.Common.Compiler_Data.Sec_Stack_Addr := - Secondary_Stack'Address; - SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last)); - end if; - - -- Initialize low-level TCB components, that cannot be initialized by - -- the creator. - - Enter_Task (Self_ID); - - -- Call the task body procedure - - begin - -- We are separating the following portion of the code in order to - -- place the exception handlers in a different block. In this way we - -- do not call Set_Jmpbuf_Address (which needs Self) before we set - -- Self in Enter_Task. - - -- Note that in the case of Ravenscar HI-E where there are no - -- exception handlers, the exception handler is suppressed. - - -- Call the task body procedure - - Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg); - - -- Normal task termination - - Cause := Normal; - Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); - - exception - when E : others => - - -- Task terminating because of an unhandled exception - - Cause := Unhandled_Exception; - Save_Occurrence (EO, E); - end; - - -- Look for a fall-back handler - - -- This package is part of the restricted run time which supports - -- neither task hierarchies (No_Task_Hierarchy) nor specific task - -- termination handlers (No_Specific_Termination_Handlers). - - -- As specified in ARM C.7.3 par. 9/2, "the fall-back handler applies - -- only to the dependent tasks of the task". Hence, if the terminating - -- tasks (Self_ID) had a fall-back handler, it would not apply to - -- itself. This code is always executed by a task whose master is the - -- environment task (the task termination code for the environment task - -- is executed by SSL.Task_Termination_Handler), so the fall-back - -- handler to execute for this task can only be defined by its parent - -- (there is no grandparent). - - declare - TH : Termination_Handler := null; - - begin - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID.Common.Parent); - - TH := Self_ID.Common.Parent.Common.Fall_Back_Handler; - - Unlock (Self_ID.Common.Parent); - - if Single_Lock then - Unlock_RTS; - end if; - - -- Execute the task termination handler if we found it - - if TH /= null then - TH.all (Cause, Self_ID, EO); - end if; - end; - - Terminate_Task (Self_ID); - end Task_Wrapper; - - ----------------------- - -- Restricted GNARLI -- - ----------------------- - - ----------------------------------- - -- Activate_All_Tasks_Sequential -- - ----------------------------------- - - procedure Activate_All_Tasks_Sequential is - begin - pragma Assert (Partition_Elaboration_Policy = 'S'); - - Activate_Tasks (Tasks_Activation_Chain); - Tasks_Activation_Chain := Null_Task; - end Activate_All_Tasks_Sequential; - - ------------------------------- - -- Activate_Restricted_Tasks -- - ------------------------------- - - procedure Activate_Restricted_Tasks - (Chain_Access : Activation_Chain_Access) is - begin - if Partition_Elaboration_Policy = 'S' then - - -- In sequential elaboration policy, the chain must be empty. This - -- procedure can be called if the unit has been compiled without - -- partition elaboration policy, but the partition has a sequential - -- elaboration policy. - - pragma Assert (Chain_Access.T_ID = Null_Task); - null; - else - Activate_Tasks (Chain_Access.T_ID); - Chain_Access.T_ID := Null_Task; - end if; - end Activate_Restricted_Tasks; - - -------------------- - -- Activate_Tasks -- - -------------------- - - -- Note that locks of activator and activated task are both locked here. - -- This is necessary because C.State and Self.Wait_Count have to be - -- synchronized. This is safe from deadlock because the activator is always - -- created before the activated task. That satisfies our - -- in-order-of-creation ATCB locking policy. - - procedure Activate_Tasks (Chain : Task_Id) is - Self_ID : constant Task_Id := STPO.Self; - C : Task_Id; - Activate_Prio : System.Any_Priority; - Success : Boolean; - - begin - pragma Assert (Self_ID = Environment_Task); - pragma Assert (Self_ID.Common.Wait_Count = 0); - - if Single_Lock then - Lock_RTS; - end if; - - -- Lock self, to prevent activated tasks from racing ahead before we - -- finish activating the chain. - - Write_Lock (Self_ID); - - -- Activate all the tasks in the chain. Creation of the thread of - -- control was deferred until activation. So create it now. - - C := Chain; - while C /= null loop - if C.Common.State /= Terminated then - pragma Assert (C.Common.State = Unactivated); - - Write_Lock (C); - - Activate_Prio := - (if C.Common.Base_Priority < Get_Priority (Self_ID) - then Get_Priority (Self_ID) - else C.Common.Base_Priority); - - STPO.Create_Task - (C, Task_Wrapper'Address, - Parameters.Size_Type - (C.Common.Compiler_Data.Pri_Stack_Info.Size), - Activate_Prio, Success); - - Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; - - if Success then - C.Common.State := Runnable; - else - raise Program_Error; - end if; - - Unlock (C); - end if; - - C := C.Common.Activation_Link; - end loop; - - Self_ID.Common.State := Activator_Sleep; - - -- Wait for the activated tasks to complete activation. It is unsafe to - -- abort any of these tasks until the count goes to zero. - - loop - exit when Self_ID.Common.Wait_Count = 0; - Sleep (Self_ID, Activator_Sleep); - end loop; - - Self_ID.Common.State := Runnable; - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - end Activate_Tasks; - - ------------------------------------ - -- Complete_Restricted_Activation -- - ------------------------------------ - - -- As in several other places, the locks of the activator and activated - -- task are both locked here. This follows our deadlock prevention lock - -- ordering policy, since the activated task must be created after the - -- activator. - - procedure Complete_Restricted_Activation is - Self_ID : constant Task_Id := STPO.Self; - Activator : constant Task_Id := Self_ID.Common.Activator; - - begin - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Activator); - Write_Lock (Self_ID); - - -- Remove dangling reference to Activator, since a task may outlive its - -- activator. - - Self_ID.Common.Activator := null; - - -- Wake up the activator, if it is waiting for a chain of tasks to - -- activate, and we are the last in the chain to complete activation - - if Activator.Common.State = Activator_Sleep then - Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1; - - if Activator.Common.Wait_Count = 0 then - Wakeup (Activator, Activator_Sleep); - end if; - end if; - - Unlock (Self_ID); - Unlock (Activator); - - if Single_Lock then - Unlock_RTS; - end if; - - -- After the activation, active priority should be the same as base - -- priority. We must unlock the Activator first, though, since it should - -- not wait if we have lower priority. - - if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - end Complete_Restricted_Activation; - - ------------------------------ - -- Complete_Restricted_Task -- - ------------------------------ - - procedure Complete_Restricted_Task is - begin - STPO.Self.Common.State := Terminated; - end Complete_Restricted_Task; - - ---------------------------- - -- Create_Restricted_Task -- - ---------------------------- - - procedure Create_Restricted_Task - (Priority : Integer; - Stack_Address : System.Address; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Task_Image : String; - Created_Task : Task_Id) - is - Self_ID : constant Task_Id := STPO.Self; - Base_Priority : System.Any_Priority; - Base_CPU : System.Multiprocessors.CPU_Range; - Success : Boolean; - Len : Integer; - - begin - -- Stack is not preallocated on this target, so that Stack_Address must - -- be null. - - pragma Assert (Stack_Address = Null_Address); - - Base_Priority := - (if Priority = Unspecified_Priority - then Self_ID.Common.Base_Priority - else System.Any_Priority (Priority)); - - -- Legal values of CPU are the special Unspecified_CPU value which is - -- inserted by the compiler for tasks without CPU aspect, and those in - -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise - -- the task is defined to have failed, and it becomes a completed task - -- (RM D.16(14/3)). - - if CPU /= Unspecified_CPU - and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) - or else CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) - then - raise Tasking_Error with "CPU not in range"; - - -- Normal CPU affinity - else - -- When the application code says nothing about the task affinity - -- (task without CPU aspect) then the compiler inserts the - -- Unspecified_CPU value which indicates to the run-time library that - -- the task will activate and execute on the same processor as its - -- activating task if the activating task is assigned a processor - -- (RM D.16(14/3)). - - Base_CPU := - (if CPU = Unspecified_CPU - then Self_ID.Common.Base_CPU - else System.Multiprocessors.CPU_Range (CPU)); - end if; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - -- With no task hierarchy, the parent of all non-Environment tasks that - -- are created must be the Environment task. Dispatching domains are - -- not allowed in Ravenscar, so the dispatching domain parameter will - -- always be null. - - Initialize_ATCB - (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority, - Base_CPU, null, Task_Info, Size, Secondary_Stack_Size, - Created_Task, Success); - - -- If we do our job right then there should never be any failures, which - -- was probably said about the Titanic; so just to be safe, let's retain - -- this code for now - - if not Success then - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - raise Program_Error; - end if; - - Created_Task.Entry_Calls (1).Self := Created_Task; - - Len := - Integer'Min (Created_Task.Common.Task_Image'Length, Task_Image'Length); - Created_Task.Common.Task_Image_Len := Len; - Created_Task.Common.Task_Image (1 .. Len) := - Task_Image (Task_Image'First .. Task_Image'First + Len - 1); - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - -- Create TSD as early as possible in the creation of a task, since it - -- may be used by the operation of Ada code within the task. - - SSL.Create_TSD (Created_Task.Common.Compiler_Data); - end Create_Restricted_Task; - - procedure Create_Restricted_Task - (Priority : Integer; - Stack_Address : System.Address; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Chain : in out Activation_Chain; - Task_Image : String; - Created_Task : Task_Id) - is - begin - if Partition_Elaboration_Policy = 'S' then - - -- A unit may have been compiled without partition elaboration - -- policy, and in this case the compiler will emit calls for the - -- default policy (concurrent). But if the partition policy is - -- sequential, activation must be deferred. - - Create_Restricted_Task_Sequential - (Priority, Stack_Address, Size, Secondary_Stack_Size, - Task_Info, CPU, State, Discriminants, Elaborated, - Task_Image, Created_Task); - - else - Create_Restricted_Task - (Priority, Stack_Address, Size, Secondary_Stack_Size, - Task_Info, CPU, State, Discriminants, Elaborated, - Task_Image, Created_Task); - - -- Append this task to the activation chain - - Created_Task.Common.Activation_Link := Chain.T_ID; - Chain.T_ID := Created_Task; - end if; - end Create_Restricted_Task; - - --------------------------------------- - -- Create_Restricted_Task_Sequential -- - --------------------------------------- - - procedure Create_Restricted_Task_Sequential - (Priority : Integer; - Stack_Address : System.Address; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Task_Image : String; - Created_Task : Task_Id) is - begin - Create_Restricted_Task (Priority, Stack_Address, Size, - Secondary_Stack_Size, Task_Info, - CPU, State, Discriminants, Elaborated, - Task_Image, Created_Task); - - -- Append this task to the activation chain - - Created_Task.Common.Activation_Link := Tasks_Activation_Chain; - Tasks_Activation_Chain := Created_Task; - end Create_Restricted_Task_Sequential; - - --------------------------- - -- Finalize_Global_Tasks -- - --------------------------- - - -- This is needed to support the compiler interface; it will only be called - -- by the Environment task. Instead, it will cause the Environment to block - -- forever, since none of the dependent tasks are expected to terminate - - procedure Finalize_Global_Tasks is - Self_ID : constant Task_Id := STPO.Self; - - begin - pragma Assert (Self_ID = STPO.Environment_Task); - - if Single_Lock then - Lock_RTS; - end if; - - -- Handle normal task termination by the environment task, but only for - -- the normal task termination. In the case of Abnormal and - -- Unhandled_Exception they must have been handled before, and the task - -- termination soft link must have been changed so the task termination - -- routine is not executed twice. - - -- Note that in the "normal" implementation in s-tassta.adb the task - -- termination procedure for the environment task should be executed - -- after termination of library-level tasks. However, this - -- implementation is to be used when the Ravenscar restrictions are in - -- effect, and AI-394 says that if there is a fall-back handler set for - -- the partition it should be called when the first task (including the - -- environment task) attempts to terminate. - - SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence); - - Write_Lock (Self_ID); - Sleep (Self_ID, Master_Completion_Sleep); - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - -- Should never return from Master Completion Sleep - - raise Program_Error; - end Finalize_Global_Tasks; - - --------------------------- - -- Restricted_Terminated -- - --------------------------- - - function Restricted_Terminated (T : Task_Id) return Boolean is - begin - return T.Common.State = Terminated; - end Restricted_Terminated; - - -------------------- - -- Terminate_Task -- - -------------------- - - procedure Terminate_Task (Self_ID : Task_Id) is - begin - Self_ID.Common.State := Terminated; - end Terminate_Task; - - -------------- - -- Init_RTS -- - -------------- - - procedure Init_RTS is - begin - Tasking.Initialize; - - -- Initialize lock used to implement mutual exclusion between all tasks - - STPO.Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level); - - -- Notify that the tasking run time has been elaborated so that - -- the tasking version of the soft links can be used. - - SSL.Lock_Task := Task_Lock'Access; - SSL.Unlock_Task := Task_Unlock'Access; - SSL.Adafinal := Finalize_Global_Tasks'Access; - SSL.Get_Current_Excep := Get_Current_Excep'Access; - - -- Initialize the tasking soft links (if not done yet) that are common - -- to the full and the restricted run times. - - SSL.Tasking.Init_Tasking_Soft_Links; - end Init_RTS; - -begin - Init_RTS; -end System.Tasking.Restricted.Stages; diff --git a/gcc/ada/s-tarest.ads b/gcc/ada/s-tarest.ads deleted file mode 100644 index 6a53289144f..00000000000 --- a/gcc/ada/s-tarest.ads +++ /dev/null @@ -1,264 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - --- This is a simplified version of the System.Tasking.Stages package, --- intended to be used in a restricted run time. - --- This package represents the high level tasking interface used by the --- compiler to expand Ada 95 tasking constructs into simpler run time calls --- (aka GNARLI, GNU Ada Run-time Library Interface) - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes --- in exp_ch9.adb and possibly exp_ch7.adb - --- The restricted GNARLI is also composed of System.Protected_Objects and --- System.Protected_Objects.Single_Entry - -with System.Task_Info; -with System.Parameters; - -package System.Tasking.Restricted.Stages is - pragma Elaborate_Body; - - --------------------------------- - -- Compiler Interface (GNARLI) -- - --------------------------------- - - -- The compiler will expand in the GNAT tree the following construct: - - -- task type T (Discr : Integer); - - -- task body T is - -- ...declarations, possibly some controlled... - -- begin - -- ...B...; - -- end T; - - -- T1 : T (1); - - -- as follows: - - -- task type t (discr : integer); - -- tE : aliased boolean := false; - -- tZ : size_type := unspecified_size; - - -- type tV (discr : integer) is limited record - -- _task_id : task_id; - -- _atcb : aliased system__tasking__ada_task_control_block (0); - -- end record; - - -- procedure tB (_task : access tV); - -- freeze tV [ - -- procedure tVIP (_init : in out tV; _master : master_id; - -- _chain : in out activation_chain; _task_name : in string; - -- discr : integer) is - -- begin - -- _init.discr := discr; - -- _init._task_id := null; - -- system__tasking__ada_task_control_blockIP (_init._atcb, 0); - -- _init._task_id := _init._atcb'unchecked_access; - -- create_restricted_task (unspecified_priority, tZ, - -- unspecified_task_info, unspecified_cpu, - -- task_procedure_access!(tB'address), _init'address, - -- tE'unchecked_access, _task_name, _init._task_id); - -- return; - -- end tVIP; - - -- _chain : aliased activation_chain; - -- activation_chainIP (_chain); - - -- procedure tB (_task : access tV) is - -- discr : integer renames _task.discr; - - -- procedure _clean is - -- begin - -- complete_restricted_task; - -- finalize_list (F14b); - -- return; - -- end _clean; - - -- begin - -- ...declarations... - -- complete_restricted_activation; - -- ...B...; - -- return; - -- at end - -- _clean; - -- end tB; - - -- tE := true; - -- t1 : t (1); - -- t1S : constant String := "t1"; - -- tIP (t1, 3, _chain, t1S, 1); - - Partition_Elaboration_Policy : Character := 'C'; - pragma Export (C, Partition_Elaboration_Policy, - "__gnat_partition_elaboration_policy"); - -- Partition elaboration policy. Value can be either 'C' for concurrent, - -- which is the default or 'S' for sequential. This value can be modified - -- by the binder generated code, before calling elaboration code. - - procedure Create_Restricted_Task - (Priority : Integer; - Stack_Address : System.Address; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Chain : in out Activation_Chain; - Task_Image : String; - Created_Task : Task_Id); - -- Compiler interface only. Do not call from within the RTS. - -- This must be called to create a new task, when the partition - -- elaboration policy is not specified (or is concurrent). - -- - -- Priority is the task's priority (assumed to be in the - -- System.Any_Priority'Range) - -- - -- Stack_Address is the start address of the stack associated to the task, - -- in case it has been preallocated by the compiler; it is equal to - -- Null_Address when the stack needs to be allocated by the underlying - -- operating system. - -- - -- Size is the stack size of the task to create - -- - -- Secondary_Stack_Size is the secondary stack size of the task to create - -- - -- Task_Info is the task info associated with the created task, or - -- Unspecified_Task_Info if none. - -- - -- CPU is the task affinity. We pass it as an Integer to avoid an explicit - -- dependency from System.Multiprocessors when not needed. Static range - -- checks are performed when analyzing the pragma, and dynamic ones are - -- performed before setting the affinity at run time. - -- - -- State is the compiler generated task's procedure body - -- - -- Discriminants is a pointer to a limited record whose discriminants are - -- those of the task to create. This parameter should be passed as the - -- single argument to State. - -- - -- Elaborated is a pointer to a Boolean that must be set to true on exit - -- if the task could be successfully elaborated. - -- - -- Chain is a linked list of task that needs to be created. On exit, - -- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID will be - -- Created_Task (the created task will be linked at the front of Chain). - -- - -- Task_Image is a string created by the compiler that the run time can - -- store to ease the debugging and the Ada.Task_Identification facility. - -- - -- Created_Task is the resulting task. - -- - -- This procedure can raise Storage_Error if the task creation fails - - procedure Create_Restricted_Task_Sequential - (Priority : Integer; - Stack_Address : System.Address; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Task_Image : String; - Created_Task : Task_Id); - -- Compiler interface only. Do not call from within the RTS. - -- This must be called to create a new task, when the sequential partition - -- elaboration policy is used. - -- - -- The parameters are the same as Create_Restricted_Task except there is - -- no Chain parameter (for the activation chain), as there is only one - -- global activation chain, which is declared in the body of this package. - - procedure Activate_Restricted_Tasks - (Chain_Access : Activation_Chain_Access); - -- Compiler interface only. Do not call from within the RTS. - -- This must be called by the creator of a chain of one or more new tasks, - -- to activate them. The chain is a linked list that up to this point is - -- only known to the task that created them, though the individual tasks - -- are already in the All_Tasks_List. - -- - -- The compiler builds the chain in LIFO order (as a stack). Another - -- version of this procedure had code to reverse the chain, so as to - -- activate the tasks in the order of declaration. This might be nice, but - -- it is not needed if priority-based scheduling is supported, since all - -- the activated tasks synchronize on the activators lock before they start - -- activating and so they should start activating in priority order. - -- - -- When the partition elaboration policy is sequential, this procedure - -- does nothing, tasks will be activated at end of elaboration. - - procedure Activate_All_Tasks_Sequential; - pragma Export (C, Activate_All_Tasks_Sequential, - "__gnat_activate_all_tasks"); - -- Binder interface only. Do not call from within the RTS. This must be - -- called an the end of the elaboration to activate all tasks, in order - -- to implement the sequential elaboration policy. - - procedure Complete_Restricted_Activation; - -- Compiler interface only. Do not call from within the RTS. This should be - -- called from the task body at the end of the elaboration code for its - -- declarative part. Decrement the count of tasks to be activated by the - -- activator and wake it up so it can check to see if all tasks have been - -- activated. Except for the environment task, which should never call this - -- procedure, T.Activator should only be null iff T has completed - -- activation. - - procedure Complete_Restricted_Task; - -- Compiler interface only. Do not call from within the RTS. This should be - -- called from an implicit at-end handler associated with the task body, - -- when it completes. From this point, the current task will become not - -- callable. If the current task have not completed activation, this should - -- be done now in order to wake up the activator (the environment task). - - function Restricted_Terminated (T : Task_Id) return Boolean; - -- Compiler interface only. Do not call from within the RTS. This is called - -- by the compiler to implement the 'Terminated attribute. - -- - -- source code: - -- T1'Terminated - -- - -- code expansion: - -- restricted_terminated (t1._task_id) - - procedure Finalize_Global_Tasks; - -- This is needed to support the compiler interface. It will only be called - -- by the Environment task in the binder generated file (by adafinal). - -- Instead, it will cause the Environment to block forever, since none of - -- the dependent tasks are expected to terminate - -end System.Tasking.Restricted.Stages; diff --git a/gcc/ada/s-tasdeb.adb b/gcc/ada/s-tasdeb.adb deleted file mode 100644 index a18b844bcba..00000000000 --- a/gcc/ada/s-tasdeb.adb +++ /dev/null @@ -1,470 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . D E B U G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-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 package encapsulates all direct interfaces to task debugging services --- that are needed by gdb with gnat mode. - --- Note : This file *must* be compiled with debugging information - --- Do not add any dependency to GNARL packages since this package is used --- in both normal and restricted (ravenscar) environments. - -pragma Restriction_Warnings (No_Secondary_Stack); --- We wish to avoid secondary stack usage here, because (e.g.) Trace is called --- at delicate times, such as during task termination after the secondary --- stack has been deallocated. It's just a warning, so we don't require --- partition-wide consistency. - -with System.CRTL; -with System.Storage_Elements; use System.Storage_Elements; -with System.Task_Primitives; -with System.Task_Primitives.Operations; - -package body System.Tasking.Debug is - - package STPO renames System.Task_Primitives.Operations; - - type Trace_Flag_Set is array (Character) of Boolean; - - Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True); - - Stderr_Fd : constant := 2; - -- File descriptor for standard error - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Write (Fd : Integer; S : String; Count : Integer); - -- Write Count characters of S to the file descriptor Fd - - procedure Put (S : String); - -- Display S on standard error - - procedure Put_Line (S : String := ""); - -- Display S on standard error with an additional line terminator - - procedure Put_Task_Image (T : Task_Id); - -- Display relevant characters from T.Common.Task_Image on standard error - - procedure Put_Task_Id_Image (T : Task_Id); - -- Display address in hexadecimal form on standard error - - ------------------------ - -- Continue_All_Tasks -- - ------------------------ - - procedure Continue_All_Tasks is - C : Task_Id; - Dummy : Boolean; - - begin - STPO.Lock_RTS; - - C := All_Tasks_List; - while C /= null loop - Dummy := STPO.Continue_Task (C); - C := C.Common.All_Tasks_Link; - end loop; - - STPO.Unlock_RTS; - end Continue_All_Tasks; - - -------------------- - -- Get_User_State -- - -------------------- - - function Get_User_State return Long_Integer is - begin - return STPO.Self.User_State; - end Get_User_State; - - ---------------- - -- List_Tasks -- - ---------------- - - procedure List_Tasks is - C : Task_Id; - begin - C := All_Tasks_List; - while C /= null loop - Print_Task_Info (C); - C := C.Common.All_Tasks_Link; - end loop; - end List_Tasks; - - ------------------------ - -- Print_Current_Task -- - ------------------------ - - procedure Print_Current_Task is - begin - Print_Task_Info (STPO.Self); - end Print_Current_Task; - - --------------------- - -- Print_Task_Info -- - --------------------- - - procedure Print_Task_Info (T : Task_Id) is - Entry_Call : Entry_Call_Link; - Parent : Task_Id; - - begin - if T = null then - Put_Line ("null task"); - return; - end if; - - Put_Task_Image (T); - Put (": " & Task_States'Image (T.Common.State)); - Parent := T.Common.Parent; - - if Parent = null then - Put (", parent: "); - else - Put (", parent: "); - Put_Task_Image (Parent); - end if; - - Put (", prio:" & T.Common.Current_Priority'Img); - - if not T.Callable then - Put (", not callable"); - end if; - - if T.Aborting then - Put (", aborting"); - end if; - - if T.Deferral_Level /= 0 then - Put (", abort deferred"); - end if; - - if T.Common.Call /= null then - Entry_Call := T.Common.Call; - Put (", serving:"); - - while Entry_Call /= null loop - Put_Task_Id_Image (Entry_Call.Self); - Entry_Call := Entry_Call.Acceptor_Prev_Call; - end loop; - end if; - - if T.Open_Accepts /= null then - Put (", accepting:"); - - for J in T.Open_Accepts'Range loop - Put (T.Open_Accepts (J).S'Img); - end loop; - - if T.Terminate_Alternative then - Put (" or terminate"); - end if; - end if; - - if T.User_State /= 0 then - Put (", state:" & T.User_State'Img); - end if; - - Put_Line; - end Print_Task_Info; - - --------- - -- Put -- - --------- - - procedure Put (S : String) is - begin - Write (Stderr_Fd, S, S'Length); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (S : String := "") is - begin - Write (Stderr_Fd, S & ASCII.LF, S'Length + 1); - end Put_Line; - - ----------------------- - -- Put_Task_Id_Image -- - ----------------------- - - procedure Put_Task_Id_Image (T : Task_Id) is - Address_Image_Length : constant := - 13 + (if Standard'Address_Size = 64 then 10 else 0); - -- Length of string to be printed for address of task - - H : constant array (0 .. 15) of Character := "0123456789ABCDEF"; - -- Table of hex digits - - S : String (1 .. Address_Image_Length); - P : Natural; - N : Integer_Address; - U : Natural := 0; - - begin - if T = null then - Put ("Null_Task_Id"); - - else - S (S'Last) := '#'; - P := Address_Image_Length - 1; - N := To_Integer (T.all'Address); - while P > 3 loop - if U = 4 then - S (P) := '_'; - P := P - 1; - U := 1; - else - U := U + 1; - end if; - - S (P) := H (Integer (N mod 16)); - P := P - 1; - N := N / 16; - end loop; - - S (1 .. 3) := "16#"; - Put (S); - end if; - end Put_Task_Id_Image; - - -------------------- - -- Put_Task_Image -- - -------------------- - - procedure Put_Task_Image (T : Task_Id) is - begin - -- In case T.Common.Task_Image_Len is uninitialized junk, we check that - -- it is in range, to make this more robust. - - if T.Common.Task_Image_Len in T.Common.Task_Image'Range then - Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len)); - else - Put (T.Common.Task_Image); - end if; - end Put_Task_Image; - - ---------------------- - -- Resume_All_Tasks -- - ---------------------- - - procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is - C : Task_Id; - Dummy : Boolean; - - begin - STPO.Lock_RTS; - - C := All_Tasks_List; - while C /= null loop - Dummy := STPO.Resume_Task (C, Thread_Self); - C := C.Common.All_Tasks_Link; - end loop; - - STPO.Unlock_RTS; - end Resume_All_Tasks; - - --------------- - -- Set_Trace -- - --------------- - - procedure Set_Trace (Flag : Character; Value : Boolean := True) is - begin - Trace_On (Flag) := Value; - end Set_Trace; - - -------------------- - -- Set_User_State -- - -------------------- - - procedure Set_User_State (Value : Long_Integer) is - begin - STPO.Self.User_State := Value; - end Set_User_State; - - ------------------------ - -- Signal_Debug_Event -- - ------------------------ - - procedure Signal_Debug_Event - (Event_Kind : Event_Kind_Type; - Task_Value : Task_Id) - is - begin - null; - end Signal_Debug_Event; - - -------------------- - -- Stop_All_Tasks -- - -------------------- - - procedure Stop_All_Tasks is - C : Task_Id; - Dummy : Boolean; - - begin - STPO.Lock_RTS; - - C := All_Tasks_List; - while C /= null loop - Dummy := STPO.Stop_Task (C); - C := C.Common.All_Tasks_Link; - end loop; - - STPO.Unlock_RTS; - end Stop_All_Tasks; - - ---------------------------- - -- Stop_All_Tasks_Handler -- - ---------------------------- - - procedure Stop_All_Tasks_Handler is - begin - STPO.Stop_All_Tasks; - end Stop_All_Tasks_Handler; - - ----------------------- - -- Suspend_All_Tasks -- - ----------------------- - - procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is - C : Task_Id; - Dummy : Boolean; - - begin - STPO.Lock_RTS; - - C := All_Tasks_List; - while C /= null loop - Dummy := STPO.Suspend_Task (C, Thread_Self); - C := C.Common.All_Tasks_Link; - end loop; - - STPO.Unlock_RTS; - end Suspend_All_Tasks; - - ------------------------ - -- Task_Creation_Hook -- - ------------------------ - - procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is - pragma Inspection_Point (Thread); - -- gdb needs to access the thread parameter in order to implement - -- the multitask mode under VxWorks. - - begin - null; - end Task_Creation_Hook; - - --------------------------- - -- Task_Termination_Hook -- - --------------------------- - - procedure Task_Termination_Hook is - begin - null; - end Task_Termination_Hook; - - ----------- - -- Trace -- - ----------- - - procedure Trace - (Self_Id : Task_Id; - Msg : String; - Flag : Character; - Other_Id : Task_Id := null) - is - begin - if Trace_On (Flag) then - Put_Task_Id_Image (Self_Id); - Put (":" & Flag & ":"); - Put_Task_Image (Self_Id); - Put (":"); - - if Other_Id /= null then - Put_Task_Id_Image (Other_Id); - Put (":"); - end if; - - Put_Line (Msg); - end if; - end Trace; - - ----------- - -- Write -- - ----------- - - procedure Write (Fd : Integer; S : String; Count : Integer) is - Discard : System.CRTL.ssize_t; - -- Ignore write errors here; this is just debugging output, and there's - -- nothing to be done about errors anyway. - begin - Discard := - System.CRTL.write - (Fd, S'Address, System.CRTL.size_t (Count)); - end Write; - - ----------------- - -- Master_Hook -- - ----------------- - - procedure Master_Hook - (Dependent : Task_Id; - Parent : Task_Id; - Master_Level : Integer) - is - pragma Inspection_Point (Dependent); - pragma Inspection_Point (Parent); - pragma Inspection_Point (Master_Level); - begin - null; - end Master_Hook; - - --------------------------- - -- Master_Completed_Hook -- - --------------------------- - - procedure Master_Completed_Hook - (Self_ID : Task_Id; - Master_Level : Integer) - is - pragma Inspection_Point (Self_ID); - pragma Inspection_Point (Master_Level); - begin - null; - end Master_Completed_Hook; - -end System.Tasking.Debug; diff --git a/gcc/ada/s-tasdeb.ads b/gcc/ada/s-tasdeb.ads deleted file mode 100644 index e0bd0c1e01a..00000000000 --- a/gcc/ada/s-tasdeb.ads +++ /dev/null @@ -1,165 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . D E B U G -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-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 package encapsulates all direct interfaces to task debugging services --- that are needed by gdb with gnat mode. - -with System.Tasking; -with System.OS_Interface; - -package System.Tasking.Debug is - pragma Preelaborate; - - ------------------------------------------ - -- Application-level debugging routines -- - ------------------------------------------ - - procedure List_Tasks; - -- Print a list of all the known Ada tasks with abbreviated state - -- information, one-per-line, to the standard error file. - - procedure Print_Current_Task; - -- Write information about current task, in hexadecimal, as one line, to - -- the standard error file. - - procedure Print_Task_Info (T : Task_Id); - -- Similar to Print_Current_Task, for a given task - - procedure Set_User_State (Value : Long_Integer); - -- Set user state value in the current task. This state will be displayed - -- when calling List_Tasks or Print_Current_Task. It is useful for setting - -- task specific state. - - function Get_User_State return Long_Integer; - -- Return the user state for the current task - - ------------------------- - -- General GDB support -- - ------------------------- - - Known_Tasks : array (0 .. 999) of Task_Id := (others => null); - -- Global array of tasks read by gdb, and updated by Create_Task and - -- Finalize_TCB - - Debug_Event_Activating : constant := 1; - Debug_Event_Run : constant := 2; - Debug_Event_Suspended : constant := 3; - Debug_Event_Preempted : constant := 4; - Debug_Event_Terminated : constant := 5; - Debug_Event_Abort_Terminated : constant := 6; - Debug_Event_Exception_Terminated : constant := 7; - Debug_Event_Rendezvous_Exception : constant := 8; - Debug_Event_Handled : constant := 9; - Debug_Event_Dependents_Exception : constant := 10; - Debug_Event_Handled_Others : constant := 11; - - subtype Event_Kind_Type is Positive range 1 .. 11; - -- Event kinds currently defined for debugging, used globally - -- below and on a per task basis. - - procedure Signal_Debug_Event - (Event_Kind : Event_Kind_Type; - Task_Value : Task_Id); - - ---------------------------------- - -- VxWorks specific GDB support -- - ---------------------------------- - - -- Although the following routines are implemented in a target independent - -- manner, only VxWorks currently uses them. - - procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id); - -- This procedure is used to notify GDB of task's creation. It must be - -- called by the task's creator. - - procedure Task_Termination_Hook; - -- This procedure is used to notify GDB of task's termination - - procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id); - -- Suspend all the tasks except the one whose associated thread is - -- Thread_Self by traversing All_Tasks_List and calling - -- System.Task_Primitives.Operations.Suspend_Task. - - procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id); - -- Resume all the tasks except the one whose associated thread is - -- Thread_Self by traversing All_Tasks_List and calling - -- System.Task_Primitives.Operations.Continue_Task. - - procedure Stop_All_Tasks_Handler; - -- Stop all the tasks by traversing All_Tasks_List and calling - -- System.Task_Primitives.Operations.Stop_All_Task. This function - -- can be used in an interrupt handler. - - procedure Stop_All_Tasks; - -- Stop all the tasks by traversing All_Tasks_List and calling - -- System.Task_Primitives.Operations.Stop_Task. - - procedure Continue_All_Tasks; - -- Continue all the tasks by traversing All_Tasks_List and calling - -- System.Task_Primitives.Operations.Continue_Task. - - ------------------------------- - -- Run-time tracing routines -- - ------------------------------- - - procedure Trace - (Self_Id : Task_Id; - Msg : String; - Flag : Character; - Other_Id : Task_Id := null); - -- If traces for Flag are enabled, display on Standard_Error a given - -- message for the current task. Other_Id is an optional second task id - -- to display. - - procedure Set_Trace - (Flag : Character; - Value : Boolean := True); - -- Enable or disable tracing for Flag. By default, flags in the range - -- 'A' .. 'Z' are disabled, others are enabled. - - --------------------------------- - -- Hooks for Valgrind/Helgrind -- - --------------------------------- - - procedure Master_Hook - (Dependent : Task_Id; - Parent : Task_Id; - Master_Level : Integer); - -- Indicate to Valgrind/Helgrind that the master of Dependent is - -- Parent + Master_Level. - - procedure Master_Completed_Hook - (Self_ID : Task_Id; - Master_Level : Integer); - -- Indicate to Valgrind/Helgrind that Self_ID has completed the master - -- Master_Level. - -end System.Tasking.Debug; diff --git a/gcc/ada/s-tasinf-linux.adb b/gcc/ada/s-tasinf-linux.adb deleted file mode 100644 index d194cfb93dd..00000000000 --- a/gcc/ada/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, 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/s-tasinf-linux.ads b/gcc/ada/s-tasinf-linux.ads deleted file mode 100644 index 94bcac1a638..00000000000 --- a/gcc/ada/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-2014, 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/s-tasinf-mingw.adb b/gcc/ada/s-tasinf-mingw.adb deleted file mode 100644 index 14c68dcb87a..00000000000 --- a/gcc/ada/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-2009, 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/s-tasinf-mingw.ads b/gcc/ada/s-tasinf-mingw.ads deleted file mode 100644 index f4892d76a26..00000000000 --- a/gcc/ada/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-2014, 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/s-tasinf-solaris.adb b/gcc/ada/s-tasinf-solaris.adb deleted file mode 100644 index ac0645dcd0a..00000000000 --- a/gcc/ada/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-2009, 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/s-tasinf-solaris.ads b/gcc/ada/s-tasinf-solaris.ads deleted file mode 100644 index 2b457bc68ec..00000000000 --- a/gcc/ada/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-2014, 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/s-tasinf-vxworks.ads b/gcc/ada/s-tasinf-vxworks.ads deleted file mode 100644 index 2c57c2b22e7..00000000000 --- a/gcc/ada/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-2014, 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/s-tasinf.adb b/gcc/ada/s-tasinf.adb deleted file mode 100644 index d48d163a13e..00000000000 --- a/gcc/ada/s-tasinf.adb +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T A S K _ I N F O -- --- -- --- B o d y -- --- (Compiler Interface) -- --- -- --- Copyright (C) 1998-2014, 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 a dummy version of this package that is needed to solve bootstrap --- problems when compiling a library that doesn't require s-tasinf.adb from --- a compiler that contains one. - --- This package contains the definitions and routines associated with the --- implementation of the Task_Info pragma. - -package body System.Task_Info is -end System.Task_Info; diff --git a/gcc/ada/s-tasinf.ads b/gcc/ada/s-tasinf.ads deleted file mode 100644 index adad387f2da..00000000000 --- a/gcc/ada/s-tasinf.ads +++ /dev/null @@ -1,93 +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-2014, 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. - -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 -- - ------------------ - - type Scope_Type is - (Process_Scope, - -- Contend only with threads in same process - - System_Scope, - -- Contend with all threads on same CPU - - Default_Scope); - - type Task_Info_Type is new Scope_Type; - -- Type used for passing information to task create call, using the - -- Task_Info pragma. This type may be specialized for individual - -- implementations, but it must be a type that can be used as a - -- discriminant (i.e. a scalar or access type). - - Unspecified_Task_Info : constant Task_Info_Type := Default_Scope; - -- Value passed to task in the absence of a Task_Info pragma - -end System.Task_Info; diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb deleted file mode 100644 index 21404d0cd52..00000000000 --- a/gcc/ada/s-tasini.adb +++ /dev/null @@ -1,785 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . I N I T I A L I Z A T I O N -- --- -- --- 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. -- --- -- ------------------------------------------------------------------------------- - -pragma Style_Checks (All_Checks); --- Turn off subprogram alpha ordering check, since we group soft link bodies --- and dummy soft link bodies together separately in this unit. - -pragma Polling (Off); --- Turn polling off for this package. We don't need polling during any of the --- routines in this package, and more to the point, if we try to poll it can --- cause infinite loops. - -with System.Task_Primitives; -with System.Task_Primitives.Operations; -with System.Soft_Links; -with System.Soft_Links.Tasking; -with System.Tasking.Debug; -with System.Tasking.Task_Attributes; -with System.Parameters; - -with System.Secondary_Stack; -pragma Elaborate_All (System.Secondary_Stack); -pragma Unreferenced (System.Secondary_Stack); --- Make sure the body of Secondary_Stack is elaborated before calling --- Init_Tasking_Soft_Links. See comments for this routine for explanation. - -package body System.Tasking.Initialization is - - package STPO renames System.Task_Primitives.Operations; - package SSL renames System.Soft_Links; - - use Parameters; - use Task_Primitives.Operations; - - Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock; - -- This is a global lock; it is used to execute in mutual exclusion from - -- all other tasks. It is only used by Task_Lock, Task_Unlock, and - -- Final_Task_Unlock. - - ---------------------------------------------------------------------- - -- Tasking versions of some services needed by non-tasking programs -- - ---------------------------------------------------------------------- - - procedure Abort_Defer; - -- NON-INLINE versions without Self_ID for soft links - - procedure Abort_Undefer; - -- NON-INLINE versions without Self_ID for soft links - - procedure Task_Lock; - -- Locks out other tasks. Preceding a section of code by Task_Lock and - -- following it by Task_Unlock creates a critical region. This is used - -- for ensuring that a region of non-tasking code (such as code used to - -- allocate memory) is tasking safe. Note that it is valid for calls to - -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e. - -- only the corresponding outer level Task_Unlock will actually unlock. - - procedure Task_Unlock; - -- Releases lock previously set by call to Task_Lock. In the nested case, - -- all nested locks must be released before other tasks competing for the - -- tasking lock are released. - - function Get_Current_Excep return SSL.EOA; - -- Task-safe version of SSL.Get_Current_Excep - - function Task_Name return String; - -- Returns current task's name - - ------------------------ - -- Local Subprograms -- - ------------------------ - - ---------------------------- - -- Tasking Initialization -- - ---------------------------- - - procedure Init_RTS; - -- This procedure completes the initialization of the GNARL. The first part - -- of the initialization is done in the body of System.Tasking. It consists - -- of initializing global locks, and installing tasking versions of certain - -- operations used by the compiler. Init_RTS is called during elaboration. - - -------------------------- - -- Change_Base_Priority -- - -------------------------- - - -- Call only with abort deferred and holding Self_ID locked - - procedure Change_Base_Priority (T : Task_Id) is - begin - if T.Common.Base_Priority /= T.New_Base_Priority then - T.Common.Base_Priority := T.New_Base_Priority; - Set_Priority (T, T.Common.Base_Priority); - end if; - end Change_Base_Priority; - - ------------------------ - -- Check_Abort_Status -- - ------------------------ - - function Check_Abort_Status return Integer is - Self_ID : constant Task_Id := Self; - begin - if Self_ID /= null - and then Self_ID.Deferral_Level = 0 - and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - then - return 1; - else - return 0; - end if; - end Check_Abort_Status; - - ----------------- - -- Defer_Abort -- - ----------------- - - procedure Defer_Abort (Self_ID : Task_Id) is - begin - if No_Abort then - return; - end if; - - pragma Assert (Self_ID.Deferral_Level = 0); - - -- pragma Assert - -- (Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level); - - -- The above check has been useful in detecting mismatched defer/undefer - -- pairs. You may uncomment it when testing on systems that support - -- preemptive abort. - - -- If the OS supports preemptive abort (e.g. pthread_kill), it should - -- have happened already. A problem is with systems that do not support - -- preemptive abort, and so rely on polling. On such systems we may get - -- false failures of the assertion, since polling for pending abort does - -- no occur until the abort undefer operation. - - -- Even on systems that only poll for abort, the assertion may be useful - -- for catching missed abort completion polling points. The operations - -- that undefer abort poll for pending aborts. This covers most of the - -- places where the core Ada semantics require abort to be caught, - -- without any special attention. However, this generally happens on - -- exit from runtime system call, which means a pending abort will not - -- be noticed on the way into the runtime system. We considered adding a - -- check for pending aborts at this point, but chose not to, because of - -- the overhead. Instead, we searched for RTS calls where abort - -- completion is required and a task could go farther than Ada allows - -- before undeferring abort; we then modified the code to ensure the - -- abort would be detected. - - Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; - end Defer_Abort; - - -------------------------- - -- Defer_Abort_Nestable -- - -------------------------- - - procedure Defer_Abort_Nestable (Self_ID : Task_Id) is - begin - if No_Abort then - return; - end if; - - -- The following assertion is by default disabled. See the comment in - -- Defer_Abort on the situations in which it may be useful to uncomment - -- this assertion and enable the test. - - -- pragma Assert - -- (Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level or else - -- Self_ID.Deferral_Level > 0); - - Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; - end Defer_Abort_Nestable; - - ----------------- - -- Abort_Defer -- - ----------------- - - procedure Abort_Defer is - Self_ID : Task_Id; - begin - if No_Abort then - return; - end if; - - Self_ID := STPO.Self; - Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; - end Abort_Defer; - - ----------------------- - -- Get_Current_Excep -- - ----------------------- - - function Get_Current_Excep return SSL.EOA is - begin - return STPO.Self.Common.Compiler_Data.Current_Excep'Access; - end Get_Current_Excep; - - ----------------------- - -- Do_Pending_Action -- - ----------------------- - - -- Call only when holding no locks - - procedure Do_Pending_Action (Self_ID : Task_Id) is - - begin - pragma Assert (Self_ID = Self and then Self_ID.Deferral_Level = 0); - - -- Needs loop to recheck for pending action in case a new one occurred - -- while we had abort deferred below. - - loop - -- Temporarily defer abort so that we can lock Self_ID - - Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - Self_ID.Pending_Action := False; - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - -- Restore the original Deferral value - - Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; - - if not Self_ID.Pending_Action then - if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then - if not Self_ID.Aborting then - Self_ID.Aborting := True; - pragma Debug - (Debug.Trace (Self_ID, "raise Abort_Signal", 'B')); - raise Standard'Abort_Signal; - - pragma Assert (not Self_ID.ATC_Hack); - - elsif Self_ID.ATC_Hack then - - -- The solution really belongs in the Abort_Signal handler - -- for async. entry calls. The present hack is very - -- fragile. It relies that the very next point after - -- Exit_One_ATC_Level at which the task becomes abortable - -- will be the call to Undefer_Abort in the - -- Abort_Signal handler. - - Self_ID.ATC_Hack := False; - - pragma Debug - (Debug.Trace - (Self_ID, "raise Abort_Signal (ATC hack)", 'B')); - raise Standard'Abort_Signal; - end if; - end if; - - return; - end if; - end loop; - end Do_Pending_Action; - - ----------------------- - -- Final_Task_Unlock -- - ----------------------- - - -- This version is only for use in Terminate_Task, when the task is - -- relinquishing further rights to its own ATCB. - - -- There is a very interesting potential race condition there, where the - -- old task may run concurrently with a new task that is allocated the old - -- tasks (now reused) ATCB. The critical thing here is to not make any - -- reference to the ATCB after the lock is released. See also comments on - -- Terminate_Task and Unlock. - - procedure Final_Task_Unlock (Self_ID : Task_Id) is - begin - pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting = 1); - Unlock (Global_Task_Lock'Access, Global_Lock => True); - end Final_Task_Unlock; - - -------------- - -- Init_RTS -- - -------------- - - procedure Init_RTS is - Self_Id : Task_Id; - begin - Tasking.Initialize; - - -- Terminate run time (regular vs restricted) specific initialization - -- of the environment task. - - Self_Id := Environment_Task; - Self_Id.Master_of_Task := Environment_Task_Level; - Self_Id.Master_Within := Self_Id.Master_of_Task + 1; - - for L in Self_Id.Entry_Calls'Range loop - Self_Id.Entry_Calls (L).Self := Self_Id; - Self_Id.Entry_Calls (L).Level := L; - end loop; - - Self_Id.Awake_Count := 1; - Self_Id.Alive_Count := 1; - - -- Normally, a task starts out with internal master nesting level one - -- larger than external master nesting level. It is incremented to one - -- by Enter_Master, which is called in the task body only if the - -- compiler thinks the task may have dependent tasks. There is no - -- corresponding call to Enter_Master for the environment task, so we - -- would need to increment it to 2 here. Instead, we set it to 3. By - -- doing this we reserve the level 2 for server tasks of the runtime - -- system. The environment task does not need to wait for these server - - Self_Id.Master_Within := Library_Task_Level; - - -- Initialize lock used to implement mutual exclusion between all tasks - - Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level); - - -- Notify that the tasking run time has been elaborated so that - -- the tasking version of the soft links can be used. - - if not No_Abort then - SSL.Abort_Defer := Abort_Defer'Access; - SSL.Abort_Undefer := Abort_Undefer'Access; - end if; - - SSL.Lock_Task := Task_Lock'Access; - SSL.Unlock_Task := Task_Unlock'Access; - SSL.Check_Abort_Status := Check_Abort_Status'Access; - SSL.Task_Name := Task_Name'Access; - SSL.Get_Current_Excep := Get_Current_Excep'Access; - - -- Initialize the tasking soft links (if not done yet) that are common - -- to the full and the restricted run times. - - SSL.Tasking.Init_Tasking_Soft_Links; - - -- Abort is deferred in a new ATCB, so we need to undefer abort at this - -- stage to make the environment task abortable. - - Undefer_Abort (Environment_Task); - end Init_RTS; - - --------------------------- - -- Locked_Abort_To_Level-- - --------------------------- - - -- Abort a task to the specified ATC nesting level. - -- Call this only with T locked. - - -- An earlier version of this code contained a call to Wakeup. That should - -- not be necessary here, if Abort_Task is implemented correctly, since - -- Abort_Task should include the effect of Wakeup. However, the above call - -- was in earlier versions of this file, and at least for some targets - -- Abort_Task has not been doing Wakeup. It should not hurt to uncomment - -- the above call, until the error is corrected for all targets. - - -- See extended comments in package body System.Tasking.Abort for the - -- overall design of the implementation of task abort. - -- ??? there is no such package ??? - - -- If the task is sleeping it will be in an abort-deferred region, and will - -- not have Abort_Signal raised by Abort_Task. Such an "abort deferral" is - -- just to protect the RTS internals, and not necessarily required to - -- enforce Ada semantics. Abort_Task should wake the task up and let it - -- decide if it wants to complete the aborted construct immediately. - - -- Note that the effect of the low-level Abort_Task is not persistent. - -- If the target task is not blocked, this wakeup will be missed. - - -- We don't bother calling Abort_Task if this task is aborting itself, - -- since we are inside the RTS and have abort deferred. Similarly, We don't - -- bother to call Abort_Task if T is terminated, since there is no need to - -- abort a terminated task, and it could be dangerous to try if the task - -- has stopped executing. - - -- Note that an earlier version of this code had some false reasoning about - -- being able to reliably wake up a task that had suspended on a blocking - -- system call that does not atomically release the task's lock (e.g., UNIX - -- nanosleep, which we once thought could be used to implement delays). - -- That still left the possibility of missed wakeups. - - -- We cannot safely call Vulnerable_Complete_Activation here, since that - -- requires locking Self_ID.Parent. The anti-deadlock lock ordering rules - -- would then require us to release the lock on Self_ID first, which would - -- create a timing window for other tasks to lock Self_ID. This is - -- significant for tasks that may be aborted before their execution can - -- enter the task body, and so they do not get a chance to call - -- Complete_Task. The actual work for this case is done in Terminate_Task. - - procedure Locked_Abort_To_Level - (Self_ID : Task_Id; - T : Task_Id; - L : ATC_Level) - is - begin - if not T.Aborting and then T /= Self_ID then - case T.Common.State is - when Terminated - | Unactivated - => - pragma Assert (False); - null; - - when Activating - | Runnable - => - -- This is needed to cancel an asynchronous protected entry - -- call during a requeue with abort. - - T.Entry_Calls - (T.ATC_Nesting_Level).Cancellation_Attempted := True; - - when Interrupt_Server_Blocked_On_Event_Flag => - null; - - when AST_Server_Sleep - | Async_Select_Sleep - | Delay_Sleep - | Interrupt_Server_Blocked_Interrupt_Sleep - | Interrupt_Server_Idle_Sleep - | Timer_Server_Sleep - => - Wakeup (T, T.Common.State); - - when Acceptor_Delay_Sleep - | Acceptor_Sleep - => - T.Open_Accepts := null; - Wakeup (T, T.Common.State); - - when Entry_Caller_Sleep => - T.Entry_Calls - (T.ATC_Nesting_Level).Cancellation_Attempted := True; - Wakeup (T, T.Common.State); - - when Activator_Sleep - | Asynchronous_Hold - | Master_Completion_Sleep - | Master_Phase_2_Sleep - => - null; - end case; - end if; - - if T.Pending_ATC_Level > L then - T.Pending_ATC_Level := L; - T.Pending_Action := True; - - if L = 0 then - T.Callable := False; - end if; - - -- This prevents aborted task from accepting calls - - if T.Aborting then - - -- The test above is just a heuristic, to reduce wasteful - -- calls to Abort_Task. We are holding T locked, and this - -- value will not be set to False except with T also locked, - -- inside Exit_One_ATC_Level, so we should not miss wakeups. - - if T.Common.State = Acceptor_Sleep - or else - T.Common.State = Acceptor_Delay_Sleep - then - T.Open_Accepts := null; - end if; - - elsif T /= Self_ID and then - (T.Common.State = Runnable - or else T.Common.State = Interrupt_Server_Blocked_On_Event_Flag) - - -- The task is blocked on a system call waiting for the - -- completion event. In this case Abort_Task may need to take - -- special action in order to succeed. - - then - Abort_Task (T); - end if; - end if; - end Locked_Abort_To_Level; - - -------------------------------- - -- Remove_From_All_Tasks_List -- - -------------------------------- - - procedure Remove_From_All_Tasks_List (T : Task_Id) is - C : Task_Id; - Previous : Task_Id; - - begin - pragma Debug - (Debug.Trace (Self, "Remove_From_All_Tasks_List", 'C')); - - Previous := Null_Task; - C := All_Tasks_List; - while C /= Null_Task loop - if C = T then - if Previous = Null_Task then - All_Tasks_List := All_Tasks_List.Common.All_Tasks_Link; - else - Previous.Common.All_Tasks_Link := C.Common.All_Tasks_Link; - end if; - - return; - end if; - - Previous := C; - C := C.Common.All_Tasks_Link; - end loop; - - pragma Assert (False); - end Remove_From_All_Tasks_List; - - --------------- - -- Task_Lock -- - --------------- - - procedure Task_Lock (Self_ID : Task_Id) is - begin - Self_ID.Common.Global_Task_Lock_Nesting := - Self_ID.Common.Global_Task_Lock_Nesting + 1; - - if Self_ID.Common.Global_Task_Lock_Nesting = 1 then - Defer_Abort_Nestable (Self_ID); - Write_Lock (Global_Task_Lock'Access, Global_Lock => True); - end if; - end Task_Lock; - - procedure Task_Lock is - begin - Task_Lock (STPO.Self); - end Task_Lock; - - --------------- - -- Task_Name -- - --------------- - - function Task_Name return String is - Self_Id : constant Task_Id := STPO.Self; - begin - return Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len); - end Task_Name; - - ----------------- - -- Task_Unlock -- - ----------------- - - procedure Task_Unlock (Self_ID : Task_Id) is - begin - pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting > 0); - Self_ID.Common.Global_Task_Lock_Nesting := - Self_ID.Common.Global_Task_Lock_Nesting - 1; - - if Self_ID.Common.Global_Task_Lock_Nesting = 0 then - Unlock (Global_Task_Lock'Access, Global_Lock => True); - Undefer_Abort_Nestable (Self_ID); - end if; - end Task_Unlock; - - procedure Task_Unlock is - begin - Task_Unlock (STPO.Self); - end Task_Unlock; - - ------------------- - -- Undefer_Abort -- - ------------------- - - -- Precondition : Self does not hold any locks - - -- Undefer_Abort is called on any abort completion point (aka. - -- synchronization point). It performs the following actions if they - -- are pending: (1) change the base priority, (2) abort the task. - - -- The priority change has to occur before abort. Otherwise, it would - -- take effect no earlier than the next abort completion point. - - procedure Undefer_Abort (Self_ID : Task_Id) is - begin - if No_Abort then - return; - end if; - - pragma Assert (Self_ID.Deferral_Level = 1); - - Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; - - if Self_ID.Deferral_Level = 0 then - pragma Assert (Check_No_Locks (Self_ID)); - - if Self_ID.Pending_Action then - Do_Pending_Action (Self_ID); - end if; - end if; - end Undefer_Abort; - - ---------------------------- - -- Undefer_Abort_Nestable -- - ---------------------------- - - -- An earlier version would re-defer abort if an abort is in progress. - -- Then, we modified the effect of the raise statement so that it defers - -- abort until control reaches a handler. That was done to prevent - -- "skipping over" a handler if another asynchronous abort occurs during - -- the propagation of the abort to the handler. - - -- There has been talk of reversing that decision, based on a newer - -- implementation of exception propagation. Care must be taken to evaluate - -- how such a change would interact with the above code and all the places - -- where abort-deferral is used to bridge over critical transitions, such - -- as entry to the scope of a region with a finalizer and entry into the - -- body of an accept-procedure. - - procedure Undefer_Abort_Nestable (Self_ID : Task_Id) is - begin - if No_Abort then - return; - end if; - - pragma Assert (Self_ID.Deferral_Level > 0); - - Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; - - if Self_ID.Deferral_Level = 0 then - - pragma Assert (Check_No_Locks (Self_ID)); - - if Self_ID.Pending_Action then - Do_Pending_Action (Self_ID); - end if; - end if; - end Undefer_Abort_Nestable; - - ------------------- - -- Abort_Undefer -- - ------------------- - - procedure Abort_Undefer is - Self_ID : Task_Id; - begin - if No_Abort then - return; - end if; - - Self_ID := STPO.Self; - - if Self_ID.Deferral_Level = 0 then - - -- In case there are different views on whether Abort is supported - -- between the expander and the run time, we may end up with - -- Self_ID.Deferral_Level being equal to zero, when called from - -- the procedure created by the expander that corresponds to a - -- task body. In this case, there's nothing to be done. - - -- See related code in System.Tasking.Stages.Create_Task resetting - -- Deferral_Level when System.Restrictions.Abort_Allowed is False. - - return; - end if; - - pragma Assert (Self_ID.Deferral_Level > 0); - Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; - - if Self_ID.Deferral_Level = 0 then - pragma Assert (Check_No_Locks (Self_ID)); - - if Self_ID.Pending_Action then - Do_Pending_Action (Self_ID); - end if; - end if; - end Abort_Undefer; - - -------------------------- - -- Wakeup_Entry_Caller -- - -------------------------- - - -- This is called at the end of service of an entry call, to abort the - -- caller if he is in an abortable part, and to wake up the caller if it - -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue. - - -- (This enforces the rule that a task must be off-queue if its state is - -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self. - - -- Timed_Call or Simple_Call: - -- The caller is waiting on Entry_Caller_Sleep, in - -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. - - -- Conditional_Call: - -- The caller might be in Wait_For_Completion, - -- waiting for a rendezvous (possibly requeued without abort) - -- to complete. - - -- Asynchronous_Call: - -- The caller may be executing in the abortable part o - -- an async. select, or on a time delay, - -- if Entry_Call.State >= Was_Abortable. - - procedure Wakeup_Entry_Caller - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link; - New_State : Entry_Call_State) - is - Caller : constant Task_Id := Entry_Call.Self; - - begin - pragma Debug (Debug.Trace - (Self_ID, "Wakeup_Entry_Caller", 'E', Caller)); - pragma Assert (New_State = Done or else New_State = Cancelled); - - pragma Assert (Caller.Common.State /= Unactivated); - - Entry_Call.State := New_State; - - if Entry_Call.Mode = Asynchronous_Call then - - -- Abort the caller in his abortable part, but do so only if call has - -- been queued abortably. - - if Entry_Call.State >= Was_Abortable or else New_State = Done then - Locked_Abort_To_Level (Self_ID, Caller, Entry_Call.Level - 1); - end if; - - elsif Caller.Common.State = Entry_Caller_Sleep then - Wakeup (Caller, Entry_Caller_Sleep); - end if; - end Wakeup_Entry_Caller; - - ------------------------- - -- Finalize_Attributes -- - ------------------------- - - procedure Finalize_Attributes (T : Task_Id) is - Attr : Atomic_Address; - - begin - for J in T.Attributes'Range loop - Attr := T.Attributes (J); - - if Attr /= 0 and then Task_Attributes.Require_Finalization (J) then - Task_Attributes.To_Attribute (Attr).Free (Attr); - T.Attributes (J) := 0; - end if; - end loop; - end Finalize_Attributes; - -begin - Init_RTS; -end System.Tasking.Initialization; diff --git a/gcc/ada/s-tasini.ads b/gcc/ada/s-tasini.ads deleted file mode 100644 index 29f10e06133..00000000000 --- a/gcc/ada/s-tasini.ads +++ /dev/null @@ -1,178 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . I N I T I A L I Z A T I O N -- --- -- --- S p e c -- --- -- --- 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. -- --- -- ------------------------------------------------------------------------------- - --- This package provides overall initialization of the tasking portion of the --- RTS. This package must be elaborated before any tasking features are used. - -package System.Tasking.Initialization is - - procedure Remove_From_All_Tasks_List (T : Task_Id); - -- Remove T from All_Tasks_List. Call this function with RTS_Lock taken - - procedure Finalize_Attributes (T : Task_Id); - -- Finalize all attributes from T. This is to be called just before the - -- ATCB is deallocated. It relies on the caller holding T.L write-lock - -- on entry. - - --------------------------------- - -- Tasking-Specific Soft Links -- - --------------------------------- - - ------------------------- - -- Abort Defer/Undefer -- - ------------------------- - - -- Defer_Abort defers the effects of low-level abort and priority change - -- in the calling task until a matching Undefer_Abort call is executed. - - -- Undefer_Abort DOES MORE than just undo the effects of one call to - -- Defer_Abort. It is the universal "polling point" for deferred - -- processing, including the following: - - -- 1) base priority changes - - -- 2) abort/ATC - - -- Abort deferral MAY be nested (Self_ID.Deferral_Level is a count), but - -- to avoid waste and undetected errors, it generally SHOULD NOT be - -- nested. The symptom of over-deferring abort is that an exception may - -- fail to be raised, or an abort may fail to take place. - - -- Therefore, there are two sets of the inlineable defer/undefer routines, - -- which are the ones to be used inside GNARL. One set allows nesting. The - -- other does not. People who maintain the GNARL should try to avoid using - -- the nested versions, or at least look very critically at the places - -- where they are used. - - -- In general, any GNARL call that is potentially blocking, or whose - -- semantics require that it sometimes raise an exception, or that is - -- required to be an abort completion point, must be made with abort - -- Deferral_Level = 1. - - -- In general, non-blocking GNARL calls, which may be made from inside a - -- protected action, are likely to need to allow nested abort deferral. - - -- With some critical exceptions (which are supposed to be documented), - -- internal calls to the tasking runtime system assume abort is already - -- deferred, and do not modify the deferral level. - - -- There is also a set of non-inlineable defer/undefer routines, for direct - -- call from the compiler. These are not inlineable because they may need - -- to be called via pointers ("soft links"). For the sake of efficiency, - -- the version with Self_ID as parameter should used wherever possible. - -- These are all nestable. - - -- Non-nestable inline versions - - procedure Defer_Abort (Self_ID : Task_Id); - pragma Inline (Defer_Abort); - - procedure Undefer_Abort (Self_ID : Task_Id); - pragma Inline (Undefer_Abort); - - -- Nestable inline versions - - procedure Defer_Abort_Nestable (Self_ID : Task_Id); - pragma Inline (Defer_Abort_Nestable); - - procedure Undefer_Abort_Nestable (Self_ID : Task_Id); - pragma Inline (Undefer_Abort_Nestable); - - procedure Do_Pending_Action (Self_ID : Task_Id); - -- Only call with no locks, and when Self_ID.Pending_Action = True Perform - -- necessary pending actions (e.g. abort, priority change). This procedure - -- is usually called when needed as a result of calling Undefer_Abort, - -- although in the case of e.g. No_Abort restriction, it can be necessary - -- to force execution of pending actions. - - function Check_Abort_Status return Integer; - -- Returns Boolean'Pos (True) iff abort signal should raise - -- Standard'Abort_Signal. Only used by IRIX currently. - - -------------------------- - -- Change Base Priority -- - -------------------------- - - procedure Change_Base_Priority (T : Task_Id); - -- Change the base priority of T. Has to be called with the affected - -- task's ATCB write-locked. May temporarily release the lock. - - ---------------------- - -- Task Lock/Unlock -- - ---------------------- - - procedure Task_Lock (Self_ID : Task_Id); - pragma Inline (Task_Lock); - - procedure Task_Unlock (Self_ID : Task_Id); - pragma Inline (Task_Unlock); - -- These are versions of Lock_Task and Unlock_Task created for use - -- within the GNARL. - - procedure Final_Task_Unlock (Self_ID : Task_Id); - -- This version is only for use in Terminate_Task, when the task is - -- relinquishing further rights to its own ATCB. There is a very - -- interesting potential race condition there, where the old task may run - -- concurrently with a new task that is allocated the old tasks (now - -- reused) ATCB. The critical thing here is to not make any reference to - -- the ATCB after the lock is released. See also comments on - -- Terminate_Task and Unlock. - - procedure Wakeup_Entry_Caller - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link; - New_State : Entry_Call_State); - pragma Inline (Wakeup_Entry_Caller); - -- This is called at the end of service of an entry call, to abort the - -- caller if he is in an abortable part, and to wake up the caller if he - -- is on Entry_Caller_Sleep. Call it holding the lock of Entry_Call.Self. - -- - -- Timed_Call or Simple_Call: - -- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion, - -- or Wait_For_Completion_With_Timeout. - -- - -- Conditional_Call: - -- The caller might be in Wait_For_Completion, - -- waiting for a rendezvous (possibly requeued without abort) to - -- complete. - -- - -- Asynchronous_Call: - -- The caller may be executing in the abortable part an async. select, - -- or on a time delay, if Entry_Call.State >= Was_Abortable. - - procedure Locked_Abort_To_Level - (Self_ID : Task_Id; - T : Task_Id; - L : ATC_Level); - pragma Inline (Locked_Abort_To_Level); - -- Abort a task to a specified ATC level. Call this only with T locked - -end System.Tasking.Initialization; diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb deleted file mode 100644 index bddbe115b83..00000000000 --- a/gcc/ada/s-taskin.adb +++ /dev/null @@ -1,278 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - -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.Task_Primitives.Operations; -with System.Storage_Elements; - -package body System.Tasking is - - package STPO renames System.Task_Primitives.Operations; - - --------------------- - -- Detect_Blocking -- - --------------------- - - function Detect_Blocking return Boolean is - GL_Detect_Blocking : Integer; - pragma Import (C, GL_Detect_Blocking, "__gl_detect_blocking"); - -- Global variable exported by the binder generated file. A value equal - -- to 1 indicates that pragma Detect_Blocking is active, while 0 is used - -- for the pragma not being present. - - begin - return GL_Detect_Blocking = 1; - end Detect_Blocking; - - ----------------------- - -- Number_Of_Entries -- - ----------------------- - - function Number_Of_Entries (Self_Id : Task_Id) return Entry_Index is - begin - return Entry_Index (Self_Id.Entry_Num); - end Number_Of_Entries; - - ---------- - -- Self -- - ---------- - - function Self return Task_Id renames STPO.Self; - - ------------------ - -- Storage_Size -- - ------------------ - - function Storage_Size (T : Task_Id) return System.Parameters.Size_Type is - begin - return - System.Parameters.Size_Type - (T.Common.Compiler_Data.Pri_Stack_Info.Size); - end Storage_Size; - - --------------------- - -- Initialize_ATCB -- - --------------------- - - procedure Initialize_ATCB - (Self_ID : Task_Id; - Task_Entry_Point : Task_Procedure_Access; - Task_Arg : System.Address; - Parent : Task_Id; - Elaborated : Access_Boolean; - Base_Priority : System.Any_Priority; - Base_CPU : System.Multiprocessors.CPU_Range; - Domain : Dispatching_Domain_Access; - Task_Info : System.Task_Info.Task_Info_Type; - Stack_Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - T : Task_Id; - Success : out Boolean) - is - begin - T.Common.State := Unactivated; - - -- Initialize T.Common.LL - - STPO.Initialize_TCB (T, Success); - - if not Success then - return; - end if; - - -- Note that use of an aggregate here for this assignment - -- would be illegal, because Common_ATCB is limited because - -- Task_Primitives.Private_Data is limited. - - T.Common.Parent := Parent; - T.Common.Base_Priority := Base_Priority; - T.Common.Base_CPU := Base_CPU; - - -- The Domain defaults to that of the activator. But that can be null in - -- the case of foreign threads (see Register_Foreign_Thread), in which - -- case we default to the System_Domain. - - if Domain /= null then - T.Common.Domain := Domain; - elsif Self_ID.Common.Domain /= null then - T.Common.Domain := Self_ID.Common.Domain; - else - T.Common.Domain := System_Domain; - end if; - pragma Assert (T.Common.Domain /= null); - - T.Common.Current_Priority := 0; - T.Common.Protected_Action_Nesting := 0; - T.Common.Call := null; - T.Common.Task_Arg := Task_Arg; - T.Common.Task_Entry_Point := Task_Entry_Point; - T.Common.Activator := Self_ID; - T.Common.Wait_Count := 0; - T.Common.Elaborated := Elaborated; - T.Common.Activation_Failed := False; - T.Common.Task_Info := Task_Info; - T.Common.Global_Task_Lock_Nesting := 0; - T.Common.Fall_Back_Handler := null; - T.Common.Specific_Handler := null; - T.Common.Debug_Events := (others => False); - T.Common.Task_Image_Len := 0; - T.Common.Secondary_Stack_Size := Secondary_Stack_Size; - - if T.Common.Parent = null then - - -- For the environment task, the adjusted stack size is meaningless. - -- For example, an unspecified Stack_Size means that the stack size - -- is determined by the environment, or can grow dynamically. The - -- Stack_Checking algorithm therefore needs to use the requested - -- size, or 0 in case of an unknown size. - - T.Common.Compiler_Data.Pri_Stack_Info.Size := - Storage_Elements.Storage_Offset (Stack_Size); - - else - T.Common.Compiler_Data.Pri_Stack_Info.Size := - Storage_Elements.Storage_Offset - (Parameters.Adjust_Storage_Size (Stack_Size)); - end if; - - -- Link the task into the list of all tasks - - T.Common.All_Tasks_Link := All_Tasks_List; - All_Tasks_List := T; - end Initialize_ATCB; - - ---------------- - -- Initialize -- - ---------------- - - Main_Task_Image : constant String := "main_task"; - -- Image of environment task - - Main_Priority : Integer; - pragma Import (C, Main_Priority, "__gl_main_priority"); - -- Priority for main task. Note that this is of type Integer, not Priority, - -- because we use the value -1 to indicate the default main priority, and - -- that is of course not in Priority'range. - - Main_CPU : Integer; - pragma Import (C, Main_CPU, "__gl_main_cpu"); - -- Affinity for main task. Note that this is of type Integer, not - -- CPU_Range, because we use the value -1 to indicate the unassigned - -- affinity, and that is of course not in CPU_Range'Range. - - Initialized : Boolean := False; - -- Used to prevent multiple calls to Initialize - - procedure Initialize is - T : Task_Id; - Base_Priority : Any_Priority; - Base_CPU : System.Multiprocessors.CPU_Range; - Success : Boolean; - - use type System.Multiprocessors.CPU_Range; - - begin - if Initialized then - return; - end if; - - Initialized := True; - - -- Initialize Environment Task - - Base_Priority := - (if Main_Priority = Unspecified_Priority - then Default_Priority - else Priority (Main_Priority)); - - Base_CPU := - (if Main_CPU = Unspecified_CPU - then System.Multiprocessors.Not_A_Specific_CPU - else System.Multiprocessors.CPU_Range (Main_CPU)); - - -- At program start-up the environment task is allocated to the default - -- system dispatching domain. - -- Make sure that the processors which are not available are not taken - -- into account. Use Number_Of_CPUs to know the exact number of - -- processors in the system at execution time. - - System_Domain := - new Dispatching_Domain' - (Multiprocessors.CPU'First .. Multiprocessors.Number_Of_CPUs => - True); - - T := STPO.New_ATCB (0); - Initialize_ATCB - (Self_ID => null, - Task_Entry_Point => null, - Task_Arg => Null_Address, - Parent => Null_Task, - Elaborated => null, - Base_Priority => Base_Priority, - Base_CPU => Base_CPU, - Domain => System_Domain, - Task_Info => Task_Info.Unspecified_Task_Info, - Stack_Size => 0, - Secondary_Stack_Size => Parameters.Unspecified_Size, - T => T, - Success => Success); - pragma Assert (Success); - - STPO.Initialize (T); - STPO.Set_Priority (T, T.Common.Base_Priority); - T.Common.State := Runnable; - T.Common.Task_Image_Len := Main_Task_Image'Length; - T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image; - - Dispatching_Domain_Tasks := - new Array_Allocated_Tasks' - (Multiprocessors.CPU'First .. Multiprocessors.Number_Of_CPUs => 0); - - -- Signal that this task is being allocated to a processor - - if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then - - -- Increase the number of tasks attached to the CPU to which this - -- task is allocated. - - Dispatching_Domain_Tasks (Base_CPU) := - Dispatching_Domain_Tasks (Base_CPU) + 1; - end if; - - -- Only initialize the first element since others are not relevant - -- in ravenscar mode. Rest of the initialization is done in Init_RTS. - - T.Entry_Calls (1).Self := T; - end Initialize; -end System.Tasking; diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads deleted file mode 100644 index a0b5879048a..00000000000 --- a/gcc/ada/s-taskin.ads +++ /dev/null @@ -1,1200 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - --- This package provides necessary type definitions for compiler interface - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes. - -with Ada.Exceptions; -with Ada.Unchecked_Conversion; - -with System.Parameters; -with System.Task_Info; -with System.Soft_Links; -with System.Task_Primitives; -with System.Stack_Usage; -with System.Multiprocessors; - -package System.Tasking is - pragma Preelaborate; - - ------------------- - -- Locking Rules -- - ------------------- - - -- The following rules must be followed at all times, to prevent - -- deadlock and generally ensure correct operation of locking. - - -- Never lock a lock unless abort is deferred - - -- Never undefer abort while holding a lock - - -- Overlapping critical sections must be properly nested, and locks must - -- be released in LIFO order. E.g., the following is not allowed: - - -- Lock (X); - -- ... - -- Lock (Y); - -- ... - -- Unlock (X); - -- ... - -- Unlock (Y); - - -- Locks with lower (smaller) level number cannot be locked - -- while holding a lock with a higher level number. (The level - - -- 1. System.Tasking.PO_Simple.Protection.L (any PO lock) - -- 2. System.Tasking.Initialization.Global_Task_Lock (in body) - -- 3. System.Task_Primitives.Operations.Single_RTS_Lock - -- 4. System.Tasking.Ada_Task_Control_Block.LL.L (any TCB lock) - - -- Clearly, there can be no circular chain of hold-and-wait - -- relationships involving locks in different ordering levels. - - -- We used to have Global_Task_Lock before Protection.L but this was - -- clearly wrong since there can be calls to "new" inside protected - -- operations. The new ordering prevents these failures. - - -- Sometimes we need to hold two ATCB locks at the same time. To allow us - -- to order the locking, each ATCB is given a unique serial number. If one - -- needs to hold locks on two ATCBs at once, the lock with lower serial - -- number must be locked first. We avoid holding three or more ATCB locks, - -- because that can easily lead to complications that cause race conditions - -- and deadlocks. - - -- We don't always need to check the serial numbers, since the serial - -- numbers are assigned sequentially, and so: - - -- . The parent of a task always has a lower serial number. - -- . The activator of a task always has a lower serial number. - -- . The environment task has a lower serial number than any other task. - -- . If the activator of a task is different from the task's parent, - -- the parent always has a lower serial number than the activator. - - --------------------------------- - -- Task_Id related definitions -- - --------------------------------- - - type Ada_Task_Control_Block; - - type Task_Id is access all Ada_Task_Control_Block; - for Task_Id'Size use System.Task_Primitives.Task_Address_Size; - - Null_Task : constant Task_Id; - - type Task_List is array (Positive range <>) of Task_Id; - - function Self return Task_Id; - pragma Inline (Self); - -- This is the compiler interface version of this function. Do not call - -- from the run-time system. - - function To_Task_Id is - new Ada.Unchecked_Conversion - (System.Task_Primitives.Task_Address, Task_Id); - function To_Address is - new Ada.Unchecked_Conversion - (Task_Id, System.Task_Primitives.Task_Address); - - ----------------------- - -- Enumeration types -- - ----------------------- - - type Task_States is - (Unactivated, - -- TCB initialized but not task has not been created. - -- It cannot be executing. - --- Activating, --- -- ??? Temporarily at end of list for GDB compatibility --- -- Task has been created and is being made Runnable. - - -- Active states - -- For all states from here down, the task has been activated. - -- For all states from here down, except for Terminated, the task - -- may be executing. - -- Activator = null iff it has not yet completed activating. - - Runnable, - -- Task is not blocked for any reason known to Ada. - -- (It may be waiting for a mutex, though.) - -- It is conceptually "executing" in normal mode. - - Terminated, - -- The task is terminated, in the sense of ARM 9.3 (5). - -- Any dependents that were waiting on terminate - -- alternatives have been awakened and have terminated themselves. - - Activator_Sleep, - -- Task is waiting for created tasks to complete activation - - Acceptor_Sleep, - -- Task is waiting on an accept or select with terminate - --- Acceptor_Delay_Sleep, --- -- ??? Temporarily at end of list for GDB compatibility --- -- Task is waiting on an selective wait statement - - Entry_Caller_Sleep, - -- Task is waiting on an entry call - - Async_Select_Sleep, - -- Task is waiting to start the abortable part of an - -- asynchronous select statement. - - Delay_Sleep, - -- Task is waiting on a select statement with only a delay - -- alternative open. - - Master_Completion_Sleep, - -- Master completion has two phases. - -- In Phase 1 the task is sleeping in Complete_Master - -- having completed a master within itself, - -- and is waiting for the tasks dependent on that master to become - -- terminated or waiting on a terminate Phase. - - Master_Phase_2_Sleep, - -- In Phase 2 the task is sleeping in Complete_Master - -- waiting for tasks on terminate alternatives to finish - -- terminating. - - -- The following are special uses of sleep, for server tasks - -- within the run-time system. - - Interrupt_Server_Idle_Sleep, - Interrupt_Server_Blocked_Interrupt_Sleep, - Timer_Server_Sleep, - AST_Server_Sleep, - - Asynchronous_Hold, - -- The task has been held by Asynchronous_Task_Control.Hold_Task - - Interrupt_Server_Blocked_On_Event_Flag, - -- The task has been blocked on a system call waiting for a - -- completion event/signal to occur. - - Activating, - -- Task has been created and is being made Runnable - - Acceptor_Delay_Sleep - -- Task is waiting on an selective wait statement - ); - - type Call_Modes is - (Simple_Call, Conditional_Call, Asynchronous_Call, Timed_Call); - - type Select_Modes is (Simple_Mode, Else_Mode, Terminate_Mode, Delay_Mode); - - subtype Delay_Modes is Integer; - - ------------------------------- - -- Entry related definitions -- - ------------------------------- - - Null_Entry : constant := 0; - - Max_Entry : constant := Integer'Last; - - Interrupt_Entry : constant := -2; - - Cancelled_Entry : constant := -1; - - type Entry_Index is range Interrupt_Entry .. Max_Entry; - - Null_Task_Entry : constant := Null_Entry; - - Max_Task_Entry : constant := Max_Entry; - - type Task_Entry_Index is new Entry_Index - range Null_Task_Entry .. Max_Task_Entry; - - type Entry_Call_Record; - - type Entry_Call_Link is access all Entry_Call_Record; - - type Entry_Queue is record - Head : Entry_Call_Link; - Tail : Entry_Call_Link; - end record; - - type Task_Entry_Queue_Array is - array (Task_Entry_Index range <>) of Entry_Queue; - - -- A data structure which contains the string names of entries and entry - -- family members. - - type String_Access is access all String; - - ---------------------------------- - -- Entry_Call_Record definition -- - ---------------------------------- - - type Entry_Call_State is - (Never_Abortable, - -- the call is not abortable, and never can be - - Not_Yet_Abortable, - -- the call is not abortable, but may become so - - Was_Abortable, - -- the call is not abortable, but once was - - Now_Abortable, - -- the call is abortable - - Done, - -- the call has been completed - - Cancelled - -- the call was asynchronous, and was cancelled - ); - pragma Ordered (Entry_Call_State); - - -- Never_Abortable is used for calls that are made in a abort deferred - -- region (see ARM 9.8(5-11), 9.8 (20)). Such a call is never abortable. - - -- The Was_ vs. Not_Yet_ distinction is needed to decide whether it is OK - -- to advance into the abortable part of an async. select stmt. That is - -- allowed iff the mode is Now_ or Was_. - - -- Done indicates the call has been completed, without cancellation, or no - -- call has been made yet at this ATC nesting level, and so aborting the - -- call is no longer an issue. Completion of the call does not necessarily - -- indicate "success"; the call may be returning an exception if - -- Exception_To_Raise is non-null. - - -- Cancelled indicates the call was cancelled, and so aborting the call is - -- no longer an issue. - - -- The call is on an entry queue unless State >= Done, in which case it may - -- or may not be still Onqueue. - - -- Please do not modify the order of the values, without checking all uses - -- of this type. We rely on partial "monotonicity" of - -- Entry_Call_Record.State to avoid locking when we access this value for - -- certain tests. In particular: - - -- 1) Once State >= Done, we can rely that the call has been - -- completed. If State >= Done, it will not - -- change until the task does another entry call at this level. - - -- 2) Once State >= Was_Abortable, we can rely that the call has - -- been queued abortably at least once, and so the check for - -- whether it is OK to advance to the abortable part of an - -- async. select statement does not need to lock anything. - - type Restricted_Entry_Call_Record is record - Self : Task_Id; - -- ID of the caller - - Mode : Call_Modes; - - State : Entry_Call_State; - pragma Atomic (State); - -- Indicates part of the state of the call. - -- - -- Protection: If the call is not on a queue, it should only be - -- accessed by Self, and Self does not need any lock to modify this - -- field. - -- - -- Once the call is on a queue, the value should be something other - -- than Done unless it is cancelled, and access is controller by the - -- "server" of the queue -- i.e., the lock of Checked_To_Protection - -- (Call_Target) if the call record is on the queue of a PO, or the - -- lock of Called_Target if the call is on the queue of a task. See - -- comments on type declaration for more details. - - Uninterpreted_Data : System.Address; - -- Data passed by the compiler - - Exception_To_Raise : Ada.Exceptions.Exception_Id; - -- The exception to raise once this call has been completed without - -- being aborted. - end record; - pragma Suppress_Initialization (Restricted_Entry_Call_Record); - - ------------------------------------------- - -- Task termination procedure definition -- - ------------------------------------------- - - -- We need to redefine here these types (already defined in - -- Ada.Task_Termination) for avoiding circular dependencies. - - type Cause_Of_Termination is (Normal, Abnormal, Unhandled_Exception); - -- Possible causes for task termination: - -- - -- Normal means that the task terminates due to completing the - -- last sentence of its body, or as a result of waiting on a - -- terminate alternative. - - -- Abnormal means that the task terminates because it is being aborted - - -- handled_Exception means that the task terminates because of exception - -- raised by the execution of its task_body. - - type Termination_Handler is access protected procedure - (Cause : Cause_Of_Termination; - T : Task_Id; - X : Ada.Exceptions.Exception_Occurrence); - -- Used to represent protected procedures to be executed when task - -- terminates. - - ------------------------------------ - -- Dispatching domain definitions -- - ------------------------------------ - - -- We need to redefine here these types (already defined in - -- System.Multiprocessor.Dispatching_Domains) for avoiding circular - -- dependencies. - - type Dispatching_Domain is - array (System.Multiprocessors.CPU range <>) of Boolean; - -- A dispatching domain needs to contain the set of processors belonging - -- to it. This is a processor mask where a True indicates that the - -- processor belongs to the dispatching domain. - -- Do not use the full range of CPU_Range because it would create a very - -- long array. This way we can use the exact range of processors available - -- in the system. - - type Dispatching_Domain_Access is access Dispatching_Domain; - - System_Domain : Dispatching_Domain_Access; - -- All processors belong to default system dispatching domain at start up. - -- We use a pointer which creates the actual variable for the reasons - -- explained bellow in Dispatching_Domain_Tasks. - - Dispatching_Domains_Frozen : Boolean := False; - -- True when the main procedure has been called. Hence, no new dispatching - -- domains can be created when this flag is True. - - type Array_Allocated_Tasks is - array (System.Multiprocessors.CPU range <>) of Natural; - -- At start-up time, we need to store the number of tasks attached to - -- concrete processors within the system domain (we can only create - -- dispatching domains with processors belonging to the system domain and - -- without tasks allocated). - - type Array_Allocated_Tasks_Access is access Array_Allocated_Tasks; - - Dispatching_Domain_Tasks : Array_Allocated_Tasks_Access; - -- We need to store whether there are tasks allocated to concrete - -- processors in the default system dispatching domain because we need to - -- check it before creating a new dispatching domain. Two comments about - -- why we use a pointer here and not in package Dispatching_Domains: - -- - -- 1) We use an array created dynamically in procedure Initialize which - -- is called at the beginning of the initialization of the run-time - -- library. Declaring a static array here in the spec would not work - -- across different installations because it would get the value of - -- Number_Of_CPUs from the machine where the run-time library is built, - -- and not from the machine where the application is executed. That is - -- the reason why we create the array (CPU'First .. Number_Of_CPUs) at - -- execution time in the procedure body, ensuring that the function - -- Number_Of_CPUs is executed at execution time (the same trick as we - -- use for System_Domain). - -- - -- 2) We have moved this declaration from package Dispatching_Domains - -- because when we use a pragma CPU, the affinity is passed through the - -- call to Create_Task. Hence, at this point, we may need to update the - -- number of tasks associated to the processor, but we do not want to - -- force a dependency from this package on Dispatching_Domains. - - ------------------------------------ - -- Task related other definitions -- - ------------------------------------ - - type Activation_Chain is limited private; - -- Linked list of to-be-activated tasks, linked through - -- Activation_Link. The order of tasks on the list is irrelevant, because - -- the priority rules will ensure that they actually start activating in - -- priority order. - - type Activation_Chain_Access is access all Activation_Chain; - - type Task_Procedure_Access is access procedure (Arg : System.Address); - - type Access_Boolean is access all Boolean; - - function Detect_Blocking return Boolean; - pragma Inline (Detect_Blocking); - -- Return whether the Detect_Blocking pragma is enabled - - function Storage_Size (T : Task_Id) return System.Parameters.Size_Type; - -- Retrieve from the TCB of the task the allocated size of its stack, - -- either the system default or the size specified by a pragma. This is in - -- general a non-static value that can depend on discriminants of the task. - - type Bit_Array is array (Integer range <>) of Boolean; - pragma Pack (Bit_Array); - - subtype Debug_Event_Array is Bit_Array (1 .. 16); - - Global_Task_Debug_Event_Set : Boolean := False; - -- Set True when running under debugger control and a task debug event - -- signal has been requested. - - ---------------------------------------------- - -- Ada_Task_Control_Block (ATCB) definition -- - ---------------------------------------------- - - -- Notes on protection (synchronization) of TRTS data structures - - -- Any field of the TCB can be written by the activator of a task when the - -- task is created, since no other task can access the new task's - -- state until creation is complete. - - -- The protection for each field is described in a comment starting with - -- "Protection:". - - -- When a lock is used to protect an ATCB field, this lock is simply named - - -- Some protection is described in terms of tasks related to the - -- ATCB being protected. These are: - - -- Self: The task which is controlled by this ATCB - -- Acceptor: A task accepting a call from Self - -- Caller: A task calling an entry of Self - -- Parent: The task executing the master on which Self depends - -- Dependent: A task dependent on Self - -- Activator: The task that created Self and initiated its activation - -- Created: A task created and activated by Self - - -- Note: The order of the fields is important to implement efficiently - -- tasking support under gdb. - -- Currently gdb relies on the order of the State, Parent, Base_Priority, - -- Task_Image, Task_Image_Len, Call and LL fields. - - ------------------------- - -- Common ATCB section -- - ------------------------- - - -- Section used by all GNARL implementations (regular and restricted) - - type Common_ATCB is limited record - State : Task_States; - pragma Atomic (State); - -- Encodes some basic information about the state of a task, - -- including whether it has been activated, whether it is sleeping, - -- and whether it is terminated. - -- - -- Protection: Self.L - - Parent : Task_Id; - -- The task on which this task depends. - -- See also Master_Level and Master_Within. - - Base_Priority : System.Any_Priority; - -- Base priority, not changed during entry calls, only changed - -- via dynamic priorities package. - -- - -- Protection: Only written by Self, accessed by anyone - - Base_CPU : System.Multiprocessors.CPU_Range; - -- Base CPU, only changed via dispatching domains package. - -- - -- Protection: Self.L - - Current_Priority : System.Any_Priority; - -- Active priority, except that the effects of protected object - -- priority ceilings are not reflected. This only reflects explicit - -- priority changes and priority inherited through task activation - -- and rendezvous. - -- - -- Ada 95 notes: In Ada 95, this field will be transferred to the - -- Priority field of an Entry_Calls component when an entry call is - -- initiated. The Priority of the Entry_Calls component will not change - -- for the duration of the call. The accepting task can use it to boost - -- its own priority without fear of its changing in the meantime. - -- - -- This can safely be used in the priority ordering of entry queues. - -- Once a call is queued, its priority does not change. - -- - -- Since an entry call cannot be made while executing a protected - -- action, the priority of a task will never reflect a priority ceiling - -- change at the point of an entry call. - -- - -- Protection: Only written by Self, and only accessed when Acceptor - -- accepts an entry or when Created activates, at which points Self is - -- suspended. - - Protected_Action_Nesting : Natural; - pragma Atomic (Protected_Action_Nesting); - -- The dynamic level of protected action nesting for this task. This - -- field is needed for checking whether potentially blocking operations - -- are invoked from protected actions. pragma Atomic is used because it - -- can be read/written from protected interrupt handlers. - - Task_Image : String (1 .. System.Parameters.Max_Task_Image_Length); - -- Hold a string that provides a readable id for task, built from the - -- variable of which it is a value or component. - - Task_Image_Len : Natural; - -- Actual length of Task_Image - - Call : Entry_Call_Link; - -- The entry call that has been accepted by this task. - -- - -- Protection: Self.L. Self will modify this field when Self.Accepting - -- is False, and will not need the mutex to do so. Once a task sets - -- Pending_ATC_Level = 0, no other task can access this field. - - LL : aliased Task_Primitives.Private_Data; - -- Control block used by the underlying low-level tasking service - -- (GNULLI). - -- - -- Protection: This is used only by the GNULLI implementation, which - -- takes care of all of its synchronization. - - Task_Arg : System.Address; - -- The argument to task procedure. Provide a handle for discriminant - -- information. - -- - -- Protection: Part of the synchronization between Self and Activator. - -- Activator writes it, once, before Self starts executing. Thereafter, - -- Self only reads it. - - Task_Alternate_Stack : System.Address; - -- The address of the alternate signal stack for this task, if any - -- - -- Protection: Only accessed by Self - - Task_Entry_Point : Task_Procedure_Access; - -- Information needed to call the procedure containing the code for - -- the body of this task. - -- - -- Protection: Part of the synchronization between Self and Activator. - -- Activator writes it, once, before Self starts executing. Self reads - -- it, once, as part of its execution. - - Compiler_Data : System.Soft_Links.TSD; - -- Task-specific data needed by the compiler to store per-task - -- structures. - -- - -- Protection: Only accessed by Self - - All_Tasks_Link : Task_Id; - -- Used to link this task to the list of all tasks in the system - -- - -- Protection: RTS_Lock - - Activation_Link : Task_Id; - -- Used to link this task to a list of tasks to be activated - -- - -- Protection: Only used by Activator - - Activator : Task_Id; - pragma Atomic (Activator); - -- The task that created this task, either by declaring it as a task - -- object or by executing a task allocator. The value is null iff Self - -- has completed activation. - -- - -- Protection: Set by Activator before Self is activated, and - -- only modified by Self after that. Can be read by any task via - -- Ada.Task_Identification.Activation_Is_Complete; hence Atomic. - - Wait_Count : Natural; - -- This count is used by a task that is waiting for other tasks. At all - -- other times, the value should be zero. It is used differently in - -- several different states. Since a task cannot be in more than one of - -- these states at the same time, a single counter suffices. - -- - -- Protection: Self.L - - -- Activator_Sleep - - -- This is the number of tasks that this task is activating, i.e. the - -- children that have started activation but have not completed it. - -- - -- Protection: Self.L and Created.L. Both mutexes must be locked, since - -- Self.Activation_Count and Created.State must be synchronized. - - -- Master_Completion_Sleep (phase 1) - - -- This is the number dependent tasks of a master being completed by - -- Self that are activated, but have not yet terminated, and are not - -- waiting on a terminate alternative. - - -- Master_Completion_2_Sleep (phase 2) - - -- This is the count of tasks dependent on a master being completed by - -- Self which are waiting on a terminate alternative. - - Elaborated : Access_Boolean; - -- Pointer to a flag indicating that this task's body has been - -- elaborated. The flag is created and managed by the - -- compiler-generated code. - -- - -- Protection: The field itself is only accessed by Activator. The flag - -- that it points to is updated by Master and read by Activator; access - -- is assumed to be atomic. - - Activation_Failed : Boolean; - -- Set to True if activation of a chain of tasks fails, - -- so that the activator should raise Tasking_Error. - - Task_Info : System.Task_Info.Task_Info_Type; - -- System-specific attributes of the task as specified by the - -- Task_Info pragma. - - Analyzer : System.Stack_Usage.Stack_Analyzer; - -- For storing information used to measure the stack usage - - Global_Task_Lock_Nesting : Natural; - -- This is the current nesting level of calls to - -- System.Tasking.Initialization.Lock_Task. This allows a task to call - -- Lock_Task multiple times without deadlocking. A task only locks - -- Global_Task_Lock when its Global_Task_Lock_Nesting goes from 0 to 1, - -- and only unlocked when it goes from 1 to 0. - -- - -- Protection: Only accessed by Self - - Fall_Back_Handler : Termination_Handler; - -- This is the fall-back handler that applies to the dependent tasks of - -- the task. - -- - -- Protection: Self.L - - Specific_Handler : Termination_Handler; - -- This is the specific handler that applies only to this task, and not - -- any of its dependent tasks. - -- - -- Protection: Self.L - - Debug_Events : Debug_Event_Array; - -- Word length array of per task debug events, of which 11 kinds are - -- currently defined in System.Tasking.Debugging package. - - Domain : Dispatching_Domain_Access; - -- Domain is the dispatching domain to which the task belongs. It is - -- only changed via dispatching domains package. This field is made - -- part of the Common_ATCB, even when restricted run-times (namely - -- Ravenscar) do not use it, because this way the field is always - -- available to the underlying layers to set the affinity and we do not - -- need to do different things depending on the situation. - -- - -- Protection: Self.L - - Secondary_Stack_Size : System.Parameters.Size_Type; - -- Secondary_Stack_Size is the size of the secondary stack for the - -- task. Defined here since it is the responsibility of the task to - -- creates its own secondary stack. - -- - -- Protected: Only accessed by Self - end record; - - --------------------------------------- - -- Restricted_Ada_Task_Control_Block -- - --------------------------------------- - - -- This type should only be used by the restricted GNARLI and by restricted - -- GNULL implementations to allocate an ATCB (see System.Task_Primitives. - -- Operations.New_ATCB) that will take significantly less memory. - - -- Note that the restricted GNARLI should only access fields that are - -- present in the Restricted_Ada_Task_Control_Block structure. - - type Restricted_Ada_Task_Control_Block (Entry_Num : Task_Entry_Index) is - limited record - Common : Common_ATCB; - -- The common part between various tasking implementations - - Entry_Call : aliased Restricted_Entry_Call_Record; - -- Protection: This field is used on entry call "queues" associated - -- with protected objects, and is protected by the protected object - -- lock. - end record; - pragma Suppress_Initialization (Restricted_Ada_Task_Control_Block); - - Interrupt_Manager_ID : Task_Id; - -- This task ID is declared here to break circular dependencies. - -- Also declare Interrupt_Manager_ID after Task_Id is known, to avoid - -- generating unneeded finalization code. - - ----------------------- - -- List of all Tasks -- - ----------------------- - - All_Tasks_List : Task_Id; - -- Global linked list of all tasks - - ------------------------------------------ - -- Regular (non restricted) definitions -- - ------------------------------------------ - - -------------------------------- - -- Master Related Definitions -- - -------------------------------- - - subtype Master_Level is Integer; - subtype Master_ID is Master_Level; - - -- Normally, a task starts out with internal master nesting level one - -- larger than external master nesting level. It is incremented by one by - -- Enter_Master, which is called in the task body only if the compiler - -- thinks the task may have dependent tasks. It is set to 1 for the - -- environment task, the level 2 is reserved for server tasks of the - -- run-time system (the so called "independent tasks"), and the level 3 is - -- for the library level tasks. Foreign threads which are detected by - -- the run-time have a level of 0, allowing these tasks to be easily - -- distinguished if needed. - - Foreign_Task_Level : constant Master_Level := 0; - Environment_Task_Level : constant Master_Level := 1; - Independent_Task_Level : constant Master_Level := 2; - Library_Task_Level : constant Master_Level := 3; - - ------------------- - -- Priority info -- - ------------------- - - Unspecified_Priority : constant Integer := System.Priority'First - 1; - - Priority_Not_Boosted : constant Integer := System.Priority'First - 1; - -- Definition of Priority actually has to come from the RTS configuration - - subtype Rendezvous_Priority is Integer - range Priority_Not_Boosted .. System.Any_Priority'Last; - - ------------------- - -- Affinity info -- - ------------------- - - Unspecified_CPU : constant := -1; - -- No affinity specified - - ------------------------------------ - -- Rendezvous related definitions -- - ------------------------------------ - - No_Rendezvous : constant := 0; - - Max_Select : constant Integer := Integer'Last; - -- RTS-defined - - subtype Select_Index is Integer range No_Rendezvous .. Max_Select; - -- type Select_Index is range No_Rendezvous .. Max_Select; - - subtype Positive_Select_Index is - Select_Index range 1 .. Select_Index'Last; - - type Accept_Alternative is record - Null_Body : Boolean; - S : Task_Entry_Index; - end record; - - type Accept_List is - array (Positive_Select_Index range <>) of Accept_Alternative; - - type Accept_List_Access is access constant Accept_List; - - ----------------------------------- - -- ATC_Level related definitions -- - ----------------------------------- - - Max_ATC_Nesting : constant Natural := 20; - - subtype ATC_Level_Base is Integer range 0 .. Max_ATC_Nesting; - - ATC_Level_Infinity : constant ATC_Level_Base := ATC_Level_Base'Last; - - subtype ATC_Level is ATC_Level_Base range 0 .. ATC_Level_Base'Last - 1; - - subtype ATC_Level_Index is ATC_Level range 1 .. ATC_Level'Last; - - ---------------------------------- - -- Entry_Call_Record definition -- - ---------------------------------- - - type Entry_Call_Record is record - Self : Task_Id; - -- ID of the caller - - Mode : Call_Modes; - - State : Entry_Call_State; - pragma Atomic (State); - -- Indicates part of the state of the call - -- - -- Protection: If the call is not on a queue, it should only be - -- accessed by Self, and Self does not need any lock to modify this - -- field. Once the call is on a queue, the value should be something - -- other than Done unless it is cancelled, and access is controller by - -- the "server" of the queue -- i.e., the lock of Checked_To_Protection - -- (Call_Target) if the call record is on the queue of a PO, or the - -- lock of Called_Target if the call is on the queue of a task. See - -- comments on type declaration for more details. - - Uninterpreted_Data : System.Address; - -- Data passed by the compiler - - Exception_To_Raise : Ada.Exceptions.Exception_Id; - -- The exception to raise once this call has been completed without - -- being aborted. - - Prev : Entry_Call_Link; - - Next : Entry_Call_Link; - - Level : ATC_Level; - -- One of Self and Level are redundant in this implementation, since - -- each Entry_Call_Record is at Self.Entry_Calls (Level). Since we must - -- have access to the entry call record to be reading this, we could - -- get Self from Level, or Level from Self. However, this requires - -- non-portable address arithmetic. - - E : Entry_Index; - - Prio : System.Any_Priority; - - -- The above fields are those that there may be some hope of packing. - -- They are gathered together to allow for compilers that lay records - -- out contiguously, to allow for such packing. - - Called_Task : Task_Id; - pragma Atomic (Called_Task); - -- Use for task entry calls. The value is null if the call record is - -- not in use. Conversely, unless State is Done and Onqueue is false, - -- Called_Task points to an ATCB. - -- - -- Protection: Called_Task.L - - Called_PO : System.Address; - pragma Atomic (Called_PO); - -- Similar to Called_Task but for protected objects - -- - -- Note that the previous implementation tried to merge both - -- Called_Task and Called_PO but this ended up in many unexpected - -- complications (e.g having to add a magic number in the ATCB, which - -- caused gdb lots of confusion) with no real gain since the - -- Lock_Server implementation still need to loop around chasing for - -- pointer changes even with a single pointer. - - Acceptor_Prev_Call : Entry_Call_Link; - -- For task entry calls only - - Acceptor_Prev_Priority : Rendezvous_Priority := Priority_Not_Boosted; - -- For task entry calls only. The priority of the most recent prior - -- call being serviced. For protected entry calls, this function should - -- be performed by GNULLI ceiling locking. - - Cancellation_Attempted : Boolean := False; - pragma Atomic (Cancellation_Attempted); - -- Cancellation of the call has been attempted. - -- Consider merging this into State??? - - With_Abort : Boolean := False; - -- Tell caller whether the call may be aborted - -- ??? consider merging this with Was_Abortable state - - Needs_Requeue : Boolean := False; - -- Temporary to tell acceptor of task entry call that - -- Exceptional_Complete_Rendezvous needs to do requeue. - end record; - - ------------------------------------ - -- Task related other definitions -- - ------------------------------------ - - type Access_Address is access all System.Address; - -- Anonymous pointer used to implement task attributes (see s-tataat.adb - -- and a-tasatt.adb) - - pragma No_Strict_Aliasing (Access_Address); - -- This type is used in contexts where aliasing may be an issue (see - -- for example s-tataat.adb), so we avoid any incorrect aliasing - -- assumptions. - - ---------------------------------------------- - -- Ada_Task_Control_Block (ATCB) definition -- - ---------------------------------------------- - - type Entry_Call_Array is array (ATC_Level_Index) of - aliased Entry_Call_Record; - - type Atomic_Address is mod Memory_Size; - pragma Atomic (Atomic_Address); - type Attribute_Array is - array (1 .. Parameters.Max_Attribute_Count) of Atomic_Address; - -- Array of task attributes. The value (Atomic_Address) will either be - -- converted to a task attribute if it fits, or to a pointer to a record - -- by Ada.Task_Attributes. - - type Task_Serial_Number is mod 2 ** Long_Long_Integer'Size; - -- Used to give each task a unique serial number. We want 64-bits for this - -- type to get as much uniqueness as possible (2**64 is operationally - -- infinite in this context, but 2**32 perhaps could recycle). We use - -- Long_Long_Integer (which in the normal case is always 64-bits) rather - -- than 64-bits explicitly to allow codepeer to analyze this unit when - -- a target configuration file forces the maximum integer size to 32. - - type Ada_Task_Control_Block (Entry_Num : Task_Entry_Index) is limited record - Common : Common_ATCB; - -- The common part between various tasking implementations - - Entry_Calls : Entry_Call_Array; - -- An array of entry calls - -- - -- Protection: The elements of this array are on entry call queues - -- associated with protected objects or task entries, and are protected - -- by the protected object lock or Acceptor.L, respectively. - - New_Base_Priority : System.Any_Priority; - -- New value for Base_Priority (for dynamic priorities package) - -- - -- Protection: Self.L - - Open_Accepts : Accept_List_Access; - -- This points to the Open_Accepts array of accept alternatives passed - -- to the RTS by the compiler-generated code to Selective_Wait. It is - -- non-null iff this task is ready to accept an entry call. - -- - -- Protection: Self.L - - Chosen_Index : Select_Index; - -- The index in Open_Accepts of the entry call accepted by a selective - -- wait executed by this task. - -- - -- Protection: Written by both Self and Caller. Usually protected by - -- Self.L. However, once the selection is known to have been written it - -- can be accessed without protection. This happens after Self has - -- updated it itself using information from a suspended Caller, or - -- after Caller has updated it and awakened Self. - - Master_of_Task : Master_Level; - -- The task executing the master of this task, and the ID of this task's - -- master (unique only among masters currently active within Parent). - -- - -- Protection: Set by Activator before Self is activated, and read - -- after Self is activated. - - Master_Within : Master_Level; - -- The ID of the master currently executing within this task; that is, - -- the most deeply nested currently active master. - -- - -- Protection: Only written by Self, and only read by Self or by - -- dependents when Self is attempting to exit a master. Since Self will - -- not write this field until the master is complete, the - -- synchronization should be adequate to prevent races. - - Alive_Count : Natural := 0; - -- Number of tasks directly dependent on this task (including itself) - -- that are still "alive", i.e. not terminated. - -- - -- Protection: Self.L - - Awake_Count : Natural := 0; - -- Number of tasks directly dependent on this task (including itself) - -- still "awake", i.e., are not terminated and not waiting on a - -- terminate alternative. - -- - -- Invariant: Awake_Count <= Alive_Count - - -- Protection: Self.L - - -- Beginning of flags - - Aborting : Boolean := False; - pragma Atomic (Aborting); - -- Self is in the process of aborting. While set, prevents multiple - -- abort signals from being sent by different aborter while abort - -- is acted upon. This is essential since an aborter which calls - -- Abort_To_Level could set the Pending_ATC_Level to yet a lower level - -- (than the current level), may be preempted and would send the - -- abort signal when resuming execution. At this point, the abortee - -- may have completed abort to the proper level such that the - -- signal (and resulting abort exception) are not handled any more. - -- In other words, the flag prevents a race between multiple aborters - -- - -- Protection: protected by atomic access. - - ATC_Hack : Boolean := False; - pragma Atomic (ATC_Hack); - -- ????? - -- Temporary fix, to allow Undefer_Abort to reset Aborting in the - -- handler for Abort_Signal that encloses an async. entry call. - -- For the longer term, this should be done via code in the - -- handler itself. - - Callable : Boolean := True; - -- It is OK to call entries of this task - - Dependents_Aborted : Boolean := False; - -- This is set to True by whichever task takes responsibility for - -- aborting the dependents of this task. - -- - -- Protection: Self.L - - Interrupt_Entry : Boolean := False; - -- Indicates if one or more Interrupt Entries are attached to the task. - -- This flag is needed for cleaning up the Interrupt Entry bindings. - - Pending_Action : Boolean := False; - -- Unified flag indicating some action needs to be take when abort - -- next becomes undeferred. Currently set if: - -- . Pending_Priority_Change is set - -- . Pending_ATC_Level is changed - -- . Requeue involving POs - -- (Abortable field may have changed and the Wait_Until_Abortable - -- has to recheck the abortable status of the call.) - -- . Exception_To_Raise is non-null - -- - -- Protection: Self.L - -- - -- This should never be reset back to False outside of the procedure - -- Do_Pending_Action, which is called by Undefer_Abort. It should only - -- be set to True by Set_Priority and Abort_To_Level. - - Pending_Priority_Change : Boolean := False; - -- Flag to indicate pending priority change (for dynamic priorities - -- package). The base priority is updated on the next abort - -- completion point (aka. synchronization point). - -- - -- Protection: Self.L - - Terminate_Alternative : Boolean := False; - -- Task is accepting Select with Terminate Alternative - -- - -- Protection: Self.L - - -- End of flags - - -- Beginning of counts - - ATC_Nesting_Level : ATC_Level := 1; - -- The dynamic level of ATC nesting (currently executing nested - -- asynchronous select statements) in this task. - - -- Protection: Self_ID.L. Only Self reads or updates this field. - -- Decrementing it deallocates an Entry_Calls component, and care must - -- be taken that all references to that component are eliminated before - -- doing the decrement. This in turn will require locking a protected - -- object (for a protected entry call) or the Acceptor's lock (for a - -- task entry call). No other task should attempt to read or modify - -- this value. - - Deferral_Level : Natural := 1; - -- This is the number of times that Defer_Abort has been called by - -- this task without a matching Undefer_Abort call. Abortion is only - -- allowed when this zero. It is initially 1, to protect the task at - -- startup. - - -- Protection: Only updated by Self; access assumed to be atomic - - Pending_ATC_Level : ATC_Level_Base := ATC_Level_Infinity; - -- The ATC level to which this task is currently being aborted. If the - -- value is zero, the entire task has "completed". That may be via - -- abort, exception propagation, or normal exit. If the value is - -- ATC_Level_Infinity, the task is not being aborted to any level. If - -- the value is positive, the task has not completed. This should ONLY - -- be modified by Abort_To_Level and Exit_One_ATC_Level. - -- - -- Protection: Self.L - - Serial_Number : Task_Serial_Number; - -- Monotonic counter to provide some way to check locking rules/ordering - - Known_Tasks_Index : Integer := -1; - -- Index in the System.Tasking.Debug.Known_Tasks array - - User_State : Long_Integer := 0; - -- User-writeable location, for use in debugging tasks; also provides a - -- simple task specific data. - - Free_On_Termination : Boolean := False; - -- Deallocate the ATCB when the task terminates. This flag is normally - -- False, and is set True when Unchecked_Deallocation is called on a - -- non-terminated task so that the associated storage is automatically - -- reclaimed when the task terminates. - - Attributes : Attribute_Array := (others => 0); - -- Task attributes - - -- IMPORTANT Note: the Entry_Queues field is last for efficiency of - -- access to other fields, do not put new fields after this one. - - Entry_Queues : Task_Entry_Queue_Array (1 .. Entry_Num); - -- An array of task entry queues - -- - -- Protection: Self.L. Once a task has set Self.Stage to Completing, it - -- has exclusive access to this field. - end record; - - -------------------- - -- Initialization -- - -------------------- - - procedure Initialize; - -- This procedure constitutes the first part of the initialization of the - -- GNARL. This includes creating data structures to make the initial thread - -- into the environment task. The last part of the initialization is done - -- in System.Tasking.Initialization or System.Tasking.Restricted.Stages. - -- All the initializations used to be in Tasking.Initialization, but this - -- is no longer possible with the run time simplification (including - -- optimized PO and the restricted run time) since one cannot rely on - -- System.Tasking.Initialization being present, as was done before. - - procedure Initialize_ATCB - (Self_ID : Task_Id; - Task_Entry_Point : Task_Procedure_Access; - Task_Arg : System.Address; - Parent : Task_Id; - Elaborated : Access_Boolean; - Base_Priority : System.Any_Priority; - Base_CPU : System.Multiprocessors.CPU_Range; - Domain : Dispatching_Domain_Access; - Task_Info : System.Task_Info.Task_Info_Type; - Stack_Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - T : Task_Id; - Success : out Boolean); - -- Initialize fields of the TCB for task T, and link into global TCB - -- structures. Call this only with abort deferred and holding RTS_Lock. - -- Self_ID is the calling task (normally the activator of T). Success is - -- set to indicate whether the TCB was successfully initialized. - -private - - Null_Task : constant Task_Id := null; - - type Activation_Chain is limited record - T_ID : Task_Id; - end record; - - -- Activation_Chain is an in-out parameter of initialization procedures and - -- it must be passed by reference because the init proc may terminate - -- abnormally after creating task components, and these must be properly - -- registered for removal (Expunge_Unactivated_Tasks). The "limited" forces - -- Activation_Chain to be a by-reference type; see RM-6.2(4). - - function Number_Of_Entries (Self_Id : Task_Id) return Entry_Index; - -- Given a task, return the number of entries it contains -end System.Tasking; diff --git a/gcc/ada/s-taspri-dummy.ads b/gcc/ada/s-taspri-dummy.ads deleted file mode 100644 index a6adf196dcd..00000000000 --- a/gcc/ada/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-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 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/s-taspri-hpux-dce.ads b/gcc/ada/s-taspri-hpux-dce.ads deleted file mode 100644 index 137f34b8aed..00000000000 --- a/gcc/ada/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/s-taspri-mingw.ads b/gcc/ada/s-taspri-mingw.ads deleted file mode 100644 index 64b115f3393..00000000000 --- a/gcc/ada/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-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 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/s-taspri-posix-noaltstack.ads b/gcc/ada/s-taspri-posix-noaltstack.ads deleted file mode 100644 index 92c22b6926e..00000000000 --- a/gcc/ada/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-1994, 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/s-taspri-posix.ads b/gcc/ada/s-taspri-posix.ads deleted file mode 100644 index 8eb481ffa14..00000000000 --- a/gcc/ada/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-1994, 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/s-taspri-solaris.ads b/gcc/ada/s-taspri-solaris.ads deleted file mode 100644 index e06d4d4dbbe..00000000000 --- a/gcc/ada/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-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 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/s-taspri-vxworks.ads b/gcc/ada/s-taspri-vxworks.ads deleted file mode 100644 index 833bf9822f2..00000000000 --- a/gcc/ada/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-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 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/s-tasque.adb b/gcc/ada/s-tasque.adb deleted file mode 100644 index 5116c88c0e4..00000000000 --- a/gcc/ada/s-tasque.adb +++ /dev/null @@ -1,625 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . Q U E U I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - --- This version of the body implements queueing policy according to the policy --- specified by the pragma Queuing_Policy. When no such pragma is specified --- FIFO policy is used as default. - -with System.Task_Primitives.Operations; -with System.Tasking.Initialization; -with System.Parameters; - -package body System.Tasking.Queuing is - - use Parameters; - use Task_Primitives.Operations; - use Protected_Objects; - use Protected_Objects.Entries; - - -- Entry Queues implemented as doubly linked list - - Queuing_Policy : Character; - pragma Import (C, Queuing_Policy, "__gl_queuing_policy"); - - Priority_Queuing : constant Boolean := Queuing_Policy = 'P'; - - procedure Send_Program_Error - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link); - -- Raise Program_Error in the caller of the specified entry call - - function Check_Queue (E : Entry_Queue) return Boolean; - -- Check the validity of E. - -- Return True if E is valid, raise Assert_Failure if assertions are - -- enabled and False otherwise. - - ----------------------------- - -- Broadcast_Program_Error -- - ----------------------------- - - procedure Broadcast_Program_Error - (Self_ID : Task_Id; - Object : Protection_Entries_Access; - Pending_Call : Entry_Call_Link; - RTS_Locked : Boolean := False) - is - Entry_Call : Entry_Call_Link; - begin - if Single_Lock and then not RTS_Locked then - Lock_RTS; - end if; - - if Pending_Call /= null then - Send_Program_Error (Self_ID, Pending_Call); - end if; - - for E in Object.Entry_Queues'Range loop - Dequeue_Head (Object.Entry_Queues (E), Entry_Call); - - while Entry_Call /= null loop - pragma Assert (Entry_Call.Mode /= Conditional_Call); - - Send_Program_Error (Self_ID, Entry_Call); - Dequeue_Head (Object.Entry_Queues (E), Entry_Call); - end loop; - end loop; - - if Single_Lock and then not RTS_Locked then - Unlock_RTS; - end if; - end Broadcast_Program_Error; - - ----------------- - -- Check_Queue -- - ----------------- - - function Check_Queue (E : Entry_Queue) return Boolean is - Valid : Boolean := True; - C, Prev : Entry_Call_Link; - - begin - if E.Head = null then - if E.Tail /= null then - Valid := False; - pragma Assert (Valid); - end if; - else - if E.Tail = null - or else E.Tail.Next /= E.Head - then - Valid := False; - pragma Assert (Valid); - - else - C := E.Head; - - loop - Prev := C; - C := C.Next; - - if C = null then - Valid := False; - pragma Assert (Valid); - exit; - end if; - - if Prev /= C.Prev then - Valid := False; - pragma Assert (Valid); - exit; - end if; - - exit when C = E.Head; - end loop; - - if Prev /= E.Tail then - Valid := False; - pragma Assert (Valid); - end if; - end if; - end if; - - return Valid; - end Check_Queue; - - ------------------- - -- Count_Waiting -- - ------------------- - - -- Return number of calls on the waiting queue of E - - function Count_Waiting (E : Entry_Queue) return Natural is - Count : Natural; - Temp : Entry_Call_Link; - - begin - pragma Assert (Check_Queue (E)); - - Count := 0; - - if E.Head /= null then - Temp := E.Head; - - loop - Count := Count + 1; - exit when E.Tail = Temp; - Temp := Temp.Next; - end loop; - end if; - - return Count; - end Count_Waiting; - - ------------- - -- Dequeue -- - ------------- - - -- Dequeue call from entry_queue E - - procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is - begin - pragma Assert (Check_Queue (E)); - pragma Assert (Call /= null); - - -- If empty queue, simply return - - if E.Head = null then - return; - end if; - - pragma Assert (Call.Prev /= null); - pragma Assert (Call.Next /= null); - - Call.Prev.Next := Call.Next; - Call.Next.Prev := Call.Prev; - - if E.Head = Call then - - -- Case of one element - - if E.Tail = Call then - E.Head := null; - E.Tail := null; - - -- More than one element - - else - E.Head := Call.Next; - end if; - - elsif E.Tail = Call then - E.Tail := Call.Prev; - end if; - - -- Successfully dequeued - - Call.Prev := null; - Call.Next := null; - pragma Assert (Check_Queue (E)); - end Dequeue; - - ------------------ - -- Dequeue_Call -- - ------------------ - - procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is - Called_PO : Protection_Entries_Access; - - begin - pragma Assert (Entry_Call /= null); - - if Entry_Call.Called_Task /= null then - Dequeue - (Entry_Call.Called_Task.Entry_Queues - (Task_Entry_Index (Entry_Call.E)), - Entry_Call); - - else - Called_PO := To_Protection (Entry_Call.Called_PO); - Dequeue (Called_PO.Entry_Queues - (Protected_Entry_Index (Entry_Call.E)), - Entry_Call); - end if; - end Dequeue_Call; - - ------------------ - -- Dequeue_Head -- - ------------------ - - -- Remove and return the head of entry_queue E - - procedure Dequeue_Head - (E : in out Entry_Queue; - Call : out Entry_Call_Link) - is - Temp : Entry_Call_Link; - - begin - pragma Assert (Check_Queue (E)); - -- If empty queue, return null pointer - - if E.Head = null then - Call := null; - return; - end if; - - Temp := E.Head; - - -- Case of one element - - if E.Head = E.Tail then - E.Head := null; - E.Tail := null; - - -- More than one element - - else - pragma Assert (Temp /= null); - pragma Assert (Temp.Next /= null); - pragma Assert (Temp.Prev /= null); - - E.Head := Temp.Next; - Temp.Prev.Next := Temp.Next; - Temp.Next.Prev := Temp.Prev; - end if; - - -- Successfully dequeued - - Temp.Prev := null; - Temp.Next := null; - Call := Temp; - pragma Assert (Check_Queue (E)); - end Dequeue_Head; - - ------------- - -- Enqueue -- - ------------- - - -- Enqueue call at the end of entry_queue E, for FIFO queuing policy. - -- Enqueue call priority ordered, FIFO at same priority level, for - -- Priority queuing policy. - - procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is - Temp : Entry_Call_Link := E.Head; - - begin - pragma Assert (Check_Queue (E)); - pragma Assert (Call /= null); - - -- Priority Queuing - - if Priority_Queuing then - if Temp = null then - Call.Prev := Call; - Call.Next := Call; - E.Head := Call; - E.Tail := Call; - - else - loop - -- Find the entry that the new guy should precede - - exit when Call.Prio > Temp.Prio; - Temp := Temp.Next; - - if Temp = E.Head then - Temp := null; - exit; - end if; - end loop; - - if Temp = null then - -- Insert at tail - - Call.Prev := E.Tail; - Call.Next := E.Head; - E.Tail := Call; - - else - Call.Prev := Temp.Prev; - Call.Next := Temp; - - -- Insert at head - - if Temp = E.Head then - E.Head := Call; - end if; - end if; - - pragma Assert (Call.Prev /= null); - pragma Assert (Call.Next /= null); - - Call.Prev.Next := Call; - Call.Next.Prev := Call; - end if; - - pragma Assert (Check_Queue (E)); - return; - end if; - - -- FIFO Queuing - - if E.Head = null then - E.Head := Call; - else - E.Tail.Next := Call; - Call.Prev := E.Tail; - end if; - - E.Head.Prev := Call; - E.Tail := Call; - Call.Next := E.Head; - pragma Assert (Check_Queue (E)); - end Enqueue; - - ------------------ - -- Enqueue_Call -- - ------------------ - - procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is - Called_PO : Protection_Entries_Access; - - begin - pragma Assert (Entry_Call /= null); - - if Entry_Call.Called_Task /= null then - Enqueue - (Entry_Call.Called_Task.Entry_Queues - (Task_Entry_Index (Entry_Call.E)), - Entry_Call); - - else - Called_PO := To_Protection (Entry_Call.Called_PO); - Enqueue (Called_PO.Entry_Queues - (Protected_Entry_Index (Entry_Call.E)), - Entry_Call); - end if; - end Enqueue_Call; - - ---------- - -- Head -- - ---------- - - -- Return the head of entry_queue E - - function Head (E : Entry_Queue) return Entry_Call_Link is - begin - pragma Assert (Check_Queue (E)); - return E.Head; - end Head; - - ------------- - -- Onqueue -- - ------------- - - -- Return True if Call is on any entry_queue at all - - function Onqueue (Call : Entry_Call_Link) return Boolean is - begin - pragma Assert (Call /= null); - - -- Utilize the fact that every queue is circular, so if Call - -- is on any queue at all, Call.Next must NOT be null. - - return Call.Next /= null; - end Onqueue; - - -------------------------------- - -- Requeue_Call_With_New_Prio -- - -------------------------------- - - procedure Requeue_Call_With_New_Prio - (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is - begin - pragma Assert (Entry_Call /= null); - - -- Perform a queue reordering only when the policy being used is the - -- Priority Queuing. - - if Priority_Queuing then - if Onqueue (Entry_Call) then - Dequeue_Call (Entry_Call); - Entry_Call.Prio := Prio; - Enqueue_Call (Entry_Call); - end if; - end if; - end Requeue_Call_With_New_Prio; - - --------------------------------- - -- Select_Protected_Entry_Call -- - --------------------------------- - - -- Select an entry of a protected object. Selection depends on the - -- queuing policy being used. - - procedure Select_Protected_Entry_Call - (Self_ID : Task_Id; - Object : Protection_Entries_Access; - Call : out Entry_Call_Link) - is - Entry_Call : Entry_Call_Link; - Temp_Call : Entry_Call_Link; - Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning - - begin - Entry_Call := null; - - begin - -- Priority queuing case - - if Priority_Queuing then - for J in Object.Entry_Queues'Range loop - Temp_Call := Head (Object.Entry_Queues (J)); - - if Temp_Call /= null - and then - Object.Entry_Bodies - (Object.Find_Body_Index - (Object.Compiler_Info, J)). - Barrier (Object.Compiler_Info, J) - then - if Entry_Call = null - or else Entry_Call.Prio < Temp_Call.Prio - then - Entry_Call := Temp_Call; - Entry_Index := J; - end if; - end if; - end loop; - - -- FIFO queueing case - - else - for J in Object.Entry_Queues'Range loop - Temp_Call := Head (Object.Entry_Queues (J)); - - if Temp_Call /= null - and then - Object.Entry_Bodies - (Object.Find_Body_Index - (Object.Compiler_Info, J)). - Barrier (Object.Compiler_Info, J) - then - Entry_Call := Temp_Call; - Entry_Index := J; - exit; - end if; - end loop; - end if; - - exception - when others => - Broadcast_Program_Error (Self_ID, Object, null); - end; - - -- If a call was selected, dequeue it and return it for service - - if Entry_Call /= null then - Temp_Call := Entry_Call; - Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call); - pragma Assert (Temp_Call = Entry_Call); - end if; - - Call := Entry_Call; - end Select_Protected_Entry_Call; - - ---------------------------- - -- Select_Task_Entry_Call -- - ---------------------------- - - -- Select an entry for rendezvous. Selection depends on the queuing policy - -- being used. - - procedure Select_Task_Entry_Call - (Acceptor : Task_Id; - Open_Accepts : Accept_List_Access; - Call : out Entry_Call_Link; - Selection : out Select_Index; - Open_Alternative : out Boolean) - is - Entry_Call : Entry_Call_Link; - Temp_Call : Entry_Call_Link; - Entry_Index : Task_Entry_Index := Task_Entry_Index'First; - Temp_Entry : Task_Entry_Index; - - begin - Open_Alternative := False; - Entry_Call := null; - Selection := No_Rendezvous; - - if Priority_Queuing then - -- Priority queueing case - - for J in Open_Accepts'Range loop - Temp_Entry := Open_Accepts (J).S; - - if Temp_Entry /= Null_Task_Entry then - Open_Alternative := True; - Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); - - if Temp_Call /= null - and then (Entry_Call = null - or else Entry_Call.Prio < Temp_Call.Prio) - then - Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); - Entry_Index := Temp_Entry; - Selection := J; - end if; - end if; - end loop; - - else - -- FIFO Queuing case - - for J in Open_Accepts'Range loop - Temp_Entry := Open_Accepts (J).S; - - if Temp_Entry /= Null_Task_Entry then - Open_Alternative := True; - Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); - - if Temp_Call /= null then - Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); - Entry_Index := Temp_Entry; - Selection := J; - exit; - end if; - end if; - end loop; - end if; - - if Entry_Call /= null then - Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call); - - -- Guard is open - end if; - - Call := Entry_Call; - end Select_Task_Entry_Call; - - ------------------------ - -- Send_Program_Error -- - ------------------------ - - procedure Send_Program_Error - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link) - is - Caller : Task_Id; - begin - Caller := Entry_Call.Self; - Entry_Call.Exception_To_Raise := Program_Error'Identity; - Write_Lock (Caller); - Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); - Unlock (Caller); - end Send_Program_Error; - -end System.Tasking.Queuing; diff --git a/gcc/ada/s-tasque.ads b/gcc/ada/s-tasque.ads deleted file mode 100644 index e75af73e137..00000000000 --- a/gcc/ada/s-tasque.ads +++ /dev/null @@ -1,99 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . Q U E U I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - -with System.Tasking.Protected_Objects.Entries; - -package System.Tasking.Queuing is - - package POE renames System.Tasking.Protected_Objects.Entries; - - procedure Broadcast_Program_Error - (Self_ID : Task_Id; - Object : POE.Protection_Entries_Access; - Pending_Call : Entry_Call_Link; - RTS_Locked : Boolean := False); - -- Raise Program_Error in all tasks calling the protected entries of Object - -- The exception will not be raised immediately for the calling task; it - -- will be deferred until it calls Check_Exception. - -- RTS_Locked indicates whether the global RTS lock is taken (only - -- relevant if Single_Lock is True). - - procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link); - -- Enqueue Call at the end of entry_queue E - - procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link); - -- Dequeue Call from entry_queue E - - function Head (E : Entry_Queue) return Entry_Call_Link; - pragma Inline (Head); - -- Return the head of entry_queue E - - procedure Dequeue_Head - (E : in out Entry_Queue; - Call : out Entry_Call_Link); - -- Remove and return the head of entry_queue E - - function Onqueue (Call : Entry_Call_Link) return Boolean; - pragma Inline (Onqueue); - -- Return True if Call is on any entry_queue at all - - function Count_Waiting (E : Entry_Queue) return Natural; - -- Return number of calls on the waiting queue of E - - procedure Select_Task_Entry_Call - (Acceptor : Task_Id; - Open_Accepts : Accept_List_Access; - Call : out Entry_Call_Link; - Selection : out Select_Index; - Open_Alternative : out Boolean); - -- Select an entry for rendezvous. On exit: - -- Call will contain a pointer to the entry call record selected; - -- Selection will contain the index of the alternative selected - -- Open_Alternative will be True if there were any open alternatives - - procedure Select_Protected_Entry_Call - (Self_ID : Task_Id; - Object : POE.Protection_Entries_Access; - Call : out Entry_Call_Link); - -- Select an entry of a protected object - - procedure Enqueue_Call (Entry_Call : Entry_Call_Link); - procedure Dequeue_Call (Entry_Call : Entry_Call_Link); - -- Enqueue (dequeue) the call to (from) whatever server they are - -- calling, whether a task or a protected object. - - procedure Requeue_Call_With_New_Prio - (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority); - -- Change Priority of the call and re insert to the queue when priority - -- queueing is in effect. When FIFO is enforced, this routine - -- should not have any effect. - -end System.Tasking.Queuing; diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb deleted file mode 100644 index c1b35482c41..00000000000 --- a/gcc/ada/s-tasren.adb +++ /dev/null @@ -1,1732 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . R E N D E Z V O U 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. -- --- -- ------------------------------------------------------------------------------- - -with System.Task_Primitives.Operations; -with System.Tasking.Entry_Calls; -with System.Tasking.Initialization; -with System.Tasking.Queuing; -with System.Tasking.Utilities; -with System.Tasking.Protected_Objects.Operations; -with System.Tasking.Debug; -with System.Restrictions; -with System.Parameters; - -package body System.Tasking.Rendezvous is - - package STPO renames System.Task_Primitives.Operations; - package POO renames Protected_Objects.Operations; - package POE renames Protected_Objects.Entries; - - use Parameters; - use Task_Primitives.Operations; - - type Select_Treatment is ( - Accept_Alternative_Selected, -- alternative with non-null body - Accept_Alternative_Completed, -- alternative with null body - Else_Selected, - Terminate_Selected, - Accept_Alternative_Open, - No_Alternative_Open); - - ---------------- - -- Local Data -- - ---------------- - - Default_Treatment : constant array (Select_Modes) of Select_Treatment := - (Simple_Mode => No_Alternative_Open, - Else_Mode => Else_Selected, - Terminate_Mode => Terminate_Selected, - Delay_Mode => No_Alternative_Open); - - New_State : constant array (Boolean, Entry_Call_State) - of Entry_Call_State := - (True => - (Never_Abortable => Never_Abortable, - Not_Yet_Abortable => Now_Abortable, - Was_Abortable => Now_Abortable, - Now_Abortable => Now_Abortable, - Done => Done, - Cancelled => Cancelled), - False => - (Never_Abortable => Never_Abortable, - Not_Yet_Abortable => Not_Yet_Abortable, - Was_Abortable => Was_Abortable, - Now_Abortable => Now_Abortable, - Done => Done, - Cancelled => Cancelled) - ); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Local_Defer_Abort (Self_Id : Task_Id) renames - System.Tasking.Initialization.Defer_Abort_Nestable; - - procedure Local_Undefer_Abort (Self_Id : Task_Id) renames - System.Tasking.Initialization.Undefer_Abort_Nestable; - - -- Florist defers abort around critical sections that make entry calls - -- to the Interrupt_Manager task, which violates the general rule about - -- top-level runtime system calls from abort-deferred regions. It is not - -- that this is unsafe, but when it occurs in "normal" programs it usually - -- means either the user is trying to do a potentially blocking operation - -- from within a protected object, or there is a runtime system/compiler - -- error that has failed to undefer an earlier abort deferral. Thus, for - -- debugging it may be wise to modify the above renamings to the - -- non-nestable forms. - - procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id); - -- Internal version of Complete_Rendezvous, used to implement - -- Complete_Rendezvous and Exceptional_Complete_Rendezvous. - -- Should be called holding no locks, generally with abort - -- not yet deferred. - - procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id); - pragma Inline (Boost_Priority); - -- Call this only with abort deferred and holding lock of Acceptor - - procedure Call_Synchronous - (Acceptor : Task_Id; - E : Task_Entry_Index; - Uninterpreted_Data : System.Address; - Mode : Call_Modes; - Rendezvous_Successful : out Boolean); - pragma Inline (Call_Synchronous); - -- This call is used to make a simple or conditional entry call. - -- Called from Call_Simple and Task_Entry_Call. - - procedure Setup_For_Rendezvous_With_Body - (Entry_Call : Entry_Call_Link; - Acceptor : Task_Id); - pragma Inline (Setup_For_Rendezvous_With_Body); - -- Call this only with abort deferred and holding lock of Acceptor. When - -- a rendezvous selected (ready for rendezvous) we need to save previous - -- caller and adjust the priority. Also we need to make this call not - -- Abortable (Cancellable) since the rendezvous has already been started. - - procedure Wait_For_Call (Self_Id : Task_Id); - pragma Inline (Wait_For_Call); - -- Call this only with abort deferred and holding lock of Self_Id. An - -- accepting task goes into Sleep by calling this routine waiting for a - -- call from the caller or waiting for an abort. Make sure Self_Id is - -- locked before calling this routine. - - ----------------- - -- Accept_Call -- - ----------------- - - procedure Accept_Call - (E : Task_Entry_Index; - Uninterpreted_Data : out System.Address) - is - Self_Id : constant Task_Id := STPO.Self; - Caller : Task_Id := null; - Open_Accepts : aliased Accept_List (1 .. 1); - Entry_Call : Entry_Call_Link; - - begin - Initialization.Defer_Abort (Self_Id); - - if Single_Lock then - Lock_RTS; - end if; - - STPO.Write_Lock (Self_Id); - - if not Self_Id.Callable then - pragma Assert (Self_Id.Pending_ATC_Level = 0); - - pragma Assert (Self_Id.Pending_Action); - - STPO.Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort (Self_Id); - - -- Should never get here ??? - - pragma Assert (False); - raise Standard'Abort_Signal; - end if; - - Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); - - if Entry_Call /= null then - Caller := Entry_Call.Self; - Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); - Uninterpreted_Data := Entry_Call.Uninterpreted_Data; - - else - -- Wait for a caller - - Open_Accepts (1).Null_Body := False; - Open_Accepts (1).S := E; - Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; - - -- Wait for normal call - - pragma Debug - (Debug.Trace (Self_Id, "Accept_Call: wait", 'R')); - Wait_For_Call (Self_Id); - - pragma Assert (Self_Id.Open_Accepts = null); - - if Self_Id.Common.Call /= null then - Caller := Self_Id.Common.Call.Self; - Uninterpreted_Data := - Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data; - else - -- Case of an aborted task - - Uninterpreted_Data := System.Null_Address; - end if; - end if; - - -- Self_Id.Common.Call should already be updated by the Caller. On - -- return, we will start the rendezvous. - - STPO.Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort (Self_Id); - - end Accept_Call; - - -------------------- - -- Accept_Trivial -- - -------------------- - - procedure Accept_Trivial (E : Task_Entry_Index) is - Self_Id : constant Task_Id := STPO.Self; - Caller : Task_Id := null; - Open_Accepts : aliased Accept_List (1 .. 1); - Entry_Call : Entry_Call_Link; - - begin - Initialization.Defer_Abort_Nestable (Self_Id); - - if Single_Lock then - Lock_RTS; - end if; - - STPO.Write_Lock (Self_Id); - - if not Self_Id.Callable then - pragma Assert (Self_Id.Pending_ATC_Level = 0); - - pragma Assert (Self_Id.Pending_Action); - - STPO.Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort_Nestable (Self_Id); - - -- Should never get here ??? - - pragma Assert (False); - raise Standard'Abort_Signal; - end if; - - Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); - - if Entry_Call = null then - - -- Need to wait for entry call - - Open_Accepts (1).Null_Body := True; - Open_Accepts (1).S := E; - Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; - - pragma Debug - (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R')); - - Wait_For_Call (Self_Id); - - pragma Assert (Self_Id.Open_Accepts = null); - - -- No need to do anything special here for pending abort. - -- Abort_Signal will be raised by Undefer on exit. - - STPO.Unlock (Self_Id); - - -- Found caller already waiting - - else - pragma Assert (Entry_Call.State < Done); - - STPO.Unlock (Self_Id); - Caller := Entry_Call.Self; - - STPO.Write_Lock (Caller); - Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); - STPO.Unlock (Caller); - end if; - - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort_Nestable (Self_Id); - end Accept_Trivial; - - -------------------- - -- Boost_Priority -- - -------------------- - - procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id) is - Caller : constant Task_Id := Call.Self; - Caller_Prio : constant System.Any_Priority := Get_Priority (Caller); - Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor); - begin - if Caller_Prio > Acceptor_Prio then - Call.Acceptor_Prev_Priority := Acceptor_Prio; - Set_Priority (Acceptor, Caller_Prio); - else - Call.Acceptor_Prev_Priority := Priority_Not_Boosted; - end if; - end Boost_Priority; - - ----------------- - -- Call_Simple -- - ----------------- - - procedure Call_Simple - (Acceptor : Task_Id; - E : Task_Entry_Index; - Uninterpreted_Data : System.Address) - is - Rendezvous_Successful : Boolean; - pragma Unreferenced (Rendezvous_Successful); - - begin - -- If pragma Detect_Blocking is active then Program_Error must be - -- raised if this potentially blocking operation is called from a - -- protected action. - - if System.Tasking.Detect_Blocking - and then STPO.Self.Common.Protected_Action_Nesting > 0 - then - raise Program_Error with - "potentially blocking operation"; - end if; - - Call_Synchronous - (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful); - end Call_Simple; - - ---------------------- - -- Call_Synchronous -- - ---------------------- - - procedure Call_Synchronous - (Acceptor : Task_Id; - E : Task_Entry_Index; - Uninterpreted_Data : System.Address; - Mode : Call_Modes; - Rendezvous_Successful : out Boolean) - is - Self_Id : constant Task_Id := STPO.Self; - Level : ATC_Level; - Entry_Call : Entry_Call_Link; - - begin - pragma Assert (Mode /= Asynchronous_Call); - - Local_Defer_Abort (Self_Id); - Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; - pragma Debug - (Debug.Trace (Self_Id, "CS: entered ATC level: " & - ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); - Level := Self_Id.ATC_Nesting_Level; - Entry_Call := Self_Id.Entry_Calls (Level)'Access; - Entry_Call.Next := null; - Entry_Call.Mode := Mode; - Entry_Call.Cancellation_Attempted := False; - - -- If this is a call made inside of an abort deferred region, - -- the call should be never abortable. - - Entry_Call.State := - (if Self_Id.Deferral_Level > 1 - then Never_Abortable - else Now_Abortable); - - Entry_Call.E := Entry_Index (E); - Entry_Call.Prio := Get_Priority (Self_Id); - Entry_Call.Uninterpreted_Data := Uninterpreted_Data; - Entry_Call.Called_Task := Acceptor; - Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; - Entry_Call.With_Abort := True; - - -- Note: the caller will undefer abort on return (see WARNING above) - - if Single_Lock then - Lock_RTS; - end if; - - if not Task_Do_Or_Queue (Self_Id, Entry_Call) then - STPO.Write_Lock (Self_Id); - Utilities.Exit_One_ATC_Level (Self_Id); - STPO.Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - Local_Undefer_Abort (Self_Id); - raise Tasking_Error; - end if; - - STPO.Write_Lock (Self_Id); - pragma Debug - (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R')); - Entry_Calls.Wait_For_Completion (Entry_Call); - pragma Debug - (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R')); - Rendezvous_Successful := Entry_Call.State = Done; - STPO.Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - Local_Undefer_Abort (Self_Id); - Entry_Calls.Check_Exception (Self_Id, Entry_Call); - end Call_Synchronous; - - -------------- - -- Callable -- - -------------- - - function Callable (T : Task_Id) return Boolean is - Result : Boolean; - Self_Id : constant Task_Id := STPO.Self; - - begin - Initialization.Defer_Abort_Nestable (Self_Id); - - if Single_Lock then - Lock_RTS; - end if; - - STPO.Write_Lock (T); - Result := T.Callable; - STPO.Unlock (T); - - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort_Nestable (Self_Id); - return Result; - end Callable; - - ---------------------------- - -- Cancel_Task_Entry_Call -- - ---------------------------- - - procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is - begin - Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled); - end Cancel_Task_Entry_Call; - - ------------------------- - -- Complete_Rendezvous -- - ------------------------- - - procedure Complete_Rendezvous is - begin - Local_Complete_Rendezvous (Ada.Exceptions.Null_Id); - end Complete_Rendezvous; - - ------------------------------------- - -- Exceptional_Complete_Rendezvous -- - ------------------------------------- - - procedure Exceptional_Complete_Rendezvous - (Ex : Ada.Exceptions.Exception_Id) - is - procedure Internal_Reraise; - pragma No_Return (Internal_Reraise); - pragma Import (C, Internal_Reraise, "__gnat_reraise"); - - begin - Local_Complete_Rendezvous (Ex); - Internal_Reraise; - - -- ??? Do we need to give precedence to Program_Error that might be - -- raised due to failure of finalization, over Tasking_Error from - -- failure of requeue? - end Exceptional_Complete_Rendezvous; - - ------------------------------- - -- Local_Complete_Rendezvous -- - ------------------------------- - - procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id) is - Self_Id : constant Task_Id := STPO.Self; - Entry_Call : Entry_Call_Link := Self_Id.Common.Call; - Caller : Task_Id; - Called_PO : STPE.Protection_Entries_Access; - Acceptor_Prev_Priority : Integer; - - Ceiling_Violation : Boolean; - - use type Ada.Exceptions.Exception_Id; - procedure Transfer_Occurrence - (Target : Ada.Exceptions.Exception_Occurrence_Access; - Source : Ada.Exceptions.Exception_Occurrence); - pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); - - begin - -- The deferral level is critical here, since we want to raise an - -- exception or allow abort to take place, if there is an exception or - -- abort pending. - - pragma Debug - (Debug.Trace (Self_Id, "Local_Complete_Rendezvous", 'R')); - - if Ex = Ada.Exceptions.Null_Id then - - -- The call came from normal end-of-rendezvous, so abort is not yet - -- deferred. - - Initialization.Defer_Abort (Self_Id); - - elsif ZCX_By_Default then - - -- With ZCX, aborts are not automatically deferred in handlers - - Initialization.Defer_Abort (Self_Id); - end if; - - -- We need to clean up any accepts which Self may have been serving when - -- it was aborted. - - if Ex = Standard'Abort_Signal'Identity then - if Single_Lock then - Lock_RTS; - end if; - - while Entry_Call /= null loop - Entry_Call.Exception_To_Raise := Tasking_Error'Identity; - - -- All forms of accept make sure that the acceptor is not - -- completed, before accepting further calls, so that we - -- can be sure that no further calls are made after the - -- current calls are purged. - - Caller := Entry_Call.Self; - - -- Take write lock. This follows the lock precedence rule that - -- Caller may be locked while holding lock of Acceptor. Complete - -- the call abnormally, with exception. - - STPO.Write_Lock (Caller); - Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); - STPO.Unlock (Caller); - Entry_Call := Entry_Call.Acceptor_Prev_Call; - end loop; - - if Single_Lock then - Unlock_RTS; - end if; - - else - Caller := Entry_Call.Self; - - if Entry_Call.Needs_Requeue then - - -- We dare not lock Self_Id at the same time as Caller, for fear - -- of deadlock. - - Entry_Call.Needs_Requeue := False; - Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; - - if Entry_Call.Called_Task /= null then - - -- Requeue to another task entry - - if Single_Lock then - Lock_RTS; - end if; - - if not Task_Do_Or_Queue (Self_Id, Entry_Call) then - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort (Self_Id); - raise Tasking_Error; - end if; - - if Single_Lock then - Unlock_RTS; - end if; - - else - -- Requeue to a protected entry - - Called_PO := POE.To_Protection (Entry_Call.Called_PO); - STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation); - - if Ceiling_Violation then - pragma Assert (Ex = Ada.Exceptions.Null_Id); - Entry_Call.Exception_To_Raise := Program_Error'Identity; - - if Single_Lock then - Lock_RTS; - end if; - - STPO.Write_Lock (Caller); - Initialization.Wakeup_Entry_Caller - (Self_Id, Entry_Call, Done); - STPO.Unlock (Caller); - - if Single_Lock then - Unlock_RTS; - end if; - - else - POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call); - POO.PO_Service_Entries (Self_Id, Called_PO); - end if; - end if; - - Entry_Calls.Reset_Priority - (Self_Id, Entry_Call.Acceptor_Prev_Priority); - - else - -- The call does not need to be requeued - - Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; - Entry_Call.Exception_To_Raise := Ex; - - if Single_Lock then - Lock_RTS; - end if; - - STPO.Write_Lock (Caller); - - -- Done with Caller locked to make sure that Wakeup is not lost - - if Ex /= Ada.Exceptions.Null_Id then - Transfer_Occurrence - (Caller.Common.Compiler_Data.Current_Excep'Access, - Self_Id.Common.Compiler_Data.Current_Excep); - end if; - - Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority; - Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); - - STPO.Unlock (Caller); - - if Single_Lock then - Unlock_RTS; - end if; - - Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority); - end if; - end if; - - Initialization.Undefer_Abort (Self_Id); - end Local_Complete_Rendezvous; - - ------------------------------------- - -- Requeue_Protected_To_Task_Entry -- - ------------------------------------- - - procedure Requeue_Protected_To_Task_Entry - (Object : STPE.Protection_Entries_Access; - Acceptor : Task_Id; - E : Task_Entry_Index; - With_Abort : Boolean) - is - Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; - begin - pragma Assert (STPO.Self.Deferral_Level > 0); - - Entry_Call.E := Entry_Index (E); - Entry_Call.Called_Task := Acceptor; - Entry_Call.Called_PO := Null_Address; - Entry_Call.With_Abort := With_Abort; - Object.Call_In_Progress := null; - end Requeue_Protected_To_Task_Entry; - - ------------------------ - -- Requeue_Task_Entry -- - ------------------------ - - procedure Requeue_Task_Entry - (Acceptor : Task_Id; - E : Task_Entry_Index; - With_Abort : Boolean) - is - Self_Id : constant Task_Id := STPO.Self; - Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call; - begin - Initialization.Defer_Abort (Self_Id); - Entry_Call.Needs_Requeue := True; - Entry_Call.With_Abort := With_Abort; - Entry_Call.E := Entry_Index (E); - Entry_Call.Called_Task := Acceptor; - Initialization.Undefer_Abort (Self_Id); - end Requeue_Task_Entry; - - -------------------- - -- Selective_Wait -- - -------------------- - - procedure Selective_Wait - (Open_Accepts : Accept_List_Access; - Select_Mode : Select_Modes; - Uninterpreted_Data : out System.Address; - Index : out Select_Index) - is - Self_Id : constant Task_Id := STPO.Self; - Entry_Call : Entry_Call_Link; - Treatment : Select_Treatment; - Caller : Task_Id; - Selection : Select_Index; - Open_Alternative : Boolean; - - begin - Initialization.Defer_Abort (Self_Id); - - if Single_Lock then - Lock_RTS; - end if; - - STPO.Write_Lock (Self_Id); - - if not Self_Id.Callable then - pragma Assert (Self_Id.Pending_ATC_Level = 0); - - pragma Assert (Self_Id.Pending_Action); - - STPO.Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - -- ??? In some cases abort is deferred more than once. Need to - -- figure out why this happens. - - if Self_Id.Deferral_Level > 1 then - Self_Id.Deferral_Level := 1; - end if; - - Initialization.Undefer_Abort (Self_Id); - - -- Should never get here ??? - - pragma Assert (False); - raise Standard'Abort_Signal; - end if; - - pragma Assert (Open_Accepts /= null); - - Uninterpreted_Data := Null_Address; - - Queuing.Select_Task_Entry_Call - (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); - - -- Determine the kind and disposition of the select - - Treatment := Default_Treatment (Select_Mode); - Self_Id.Chosen_Index := No_Rendezvous; - - if Open_Alternative then - if Entry_Call /= null then - if Open_Accepts (Selection).Null_Body then - Treatment := Accept_Alternative_Completed; - else - Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); - Treatment := Accept_Alternative_Selected; - end if; - - Self_Id.Chosen_Index := Selection; - - elsif Treatment = No_Alternative_Open then - Treatment := Accept_Alternative_Open; - end if; - end if; - - -- Handle the select according to the disposition selected above - - case Treatment is - when Accept_Alternative_Selected => - - -- Ready to rendezvous - - Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - - -- In this case the accept body is not Null_Body. Defer abort - -- until it gets into the accept body. The compiler has inserted - -- a call to Abort_Undefer as part of the entry expansion. - - pragma Assert (Self_Id.Deferral_Level = 1); - - Initialization.Defer_Abort_Nestable (Self_Id); - STPO.Unlock (Self_Id); - - when Accept_Alternative_Completed => - - -- Accept body is null, so rendezvous is over immediately - - STPO.Unlock (Self_Id); - Caller := Entry_Call.Self; - - STPO.Write_Lock (Caller); - Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); - STPO.Unlock (Caller); - - when Accept_Alternative_Open => - - -- Wait for caller - - Self_Id.Open_Accepts := Open_Accepts; - pragma Debug - (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R')); - - Wait_For_Call (Self_Id); - - pragma Assert (Self_Id.Open_Accepts = null); - - -- Self_Id.Common.Call should already be updated by the Caller if - -- not aborted. It might also be ready to do rendezvous even if - -- this wakes up due to an abort. Therefore, if the call is not - -- empty we need to do the rendezvous if the accept body is not - -- Null_Body. - - -- Aren't the first two conditions below redundant??? - - if Self_Id.Chosen_Index /= No_Rendezvous - and then Self_Id.Common.Call /= null - and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body - then - Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - - pragma Assert - (Self_Id.Deferral_Level = 1 - or else - (Self_Id.Deferral_Level = 0 - and then not Restrictions.Abort_Allowed)); - - Initialization.Defer_Abort_Nestable (Self_Id); - - -- Leave abort deferred until the accept body - -- The compiler has inserted a call to Abort_Undefer as part of - -- the entry expansion. - end if; - - STPO.Unlock (Self_Id); - - when Else_Selected => - pragma Assert (Self_Id.Open_Accepts = null); - - STPO.Unlock (Self_Id); - - when Terminate_Selected => - - -- Terminate alternative is open - - Self_Id.Open_Accepts := Open_Accepts; - Self_Id.Common.State := Acceptor_Sleep; - - -- Notify ancestors that this task is on a terminate alternative - - STPO.Unlock (Self_Id); - Utilities.Make_Passive (Self_Id, Task_Completed => False); - STPO.Write_Lock (Self_Id); - - -- Wait for normal entry call or termination - - Wait_For_Call (Self_Id); - - pragma Assert (Self_Id.Open_Accepts = null); - - if Self_Id.Terminate_Alternative then - - -- An entry call should have reset this to False, so we must be - -- aborted. We cannot be in an async. select, since that is not - -- legal, so the abort must be of the entire task. Therefore, - -- we do not need to cancel the terminate alternative. The - -- cleanup will be done in Complete_Master. - - pragma Assert (Self_Id.Pending_ATC_Level = 0); - pragma Assert (Self_Id.Awake_Count = 0); - - STPO.Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - Index := Self_Id.Chosen_Index; - Initialization.Undefer_Abort_Nestable (Self_Id); - - if Self_Id.Pending_Action then - Initialization.Do_Pending_Action (Self_Id); - end if; - - return; - - else - -- Self_Id.Common.Call and Self_Id.Chosen_Index - -- should already be updated by the Caller. - - if Self_Id.Chosen_Index /= No_Rendezvous - and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body - then - Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - - pragma Assert (Self_Id.Deferral_Level = 1); - - -- We need an extra defer here, to keep abort - -- deferred until we get into the accept body - -- The compiler has inserted a call to Abort_Undefer as part - -- of the entry expansion. - - Initialization.Defer_Abort_Nestable (Self_Id); - end if; - end if; - - STPO.Unlock (Self_Id); - - when No_Alternative_Open => - - -- In this case, Index will be No_Rendezvous on return, which - -- should cause a Program_Error if it is not a Delay_Mode. - - -- If delay alternative exists (Delay_Mode) we should suspend - -- until the delay expires. - - Self_Id.Open_Accepts := null; - - if Select_Mode = Delay_Mode then - Self_Id.Common.State := Delay_Sleep; - - loop - exit when - Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level; - Sleep (Self_Id, Delay_Sleep); - end loop; - - Self_Id.Common.State := Runnable; - STPO.Unlock (Self_Id); - - else - STPO.Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort (Self_Id); - raise Program_Error with - "entry call not a delay mode"; - end if; - end case; - - if Single_Lock then - Unlock_RTS; - end if; - - -- Caller has been chosen - - -- Self_Id.Common.Call should already be updated by the Caller. - - -- Self_Id.Chosen_Index should either be updated by the Caller - -- or by Test_Selective_Wait. - - -- On return, we sill start rendezvous unless the accept body is - -- null. In the latter case, we will have already completed the RV. - - Index := Self_Id.Chosen_Index; - Initialization.Undefer_Abort_Nestable (Self_Id); - end Selective_Wait; - - ------------------------------------ - -- Setup_For_Rendezvous_With_Body -- - ------------------------------------ - - procedure Setup_For_Rendezvous_With_Body - (Entry_Call : Entry_Call_Link; - Acceptor : Task_Id) is - begin - Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call; - Acceptor.Common.Call := Entry_Call; - - if Entry_Call.State = Now_Abortable then - Entry_Call.State := Was_Abortable; - end if; - - Boost_Priority (Entry_Call, Acceptor); - end Setup_For_Rendezvous_With_Body; - - ---------------- - -- Task_Count -- - ---------------- - - function Task_Count (E : Task_Entry_Index) return Natural is - Self_Id : constant Task_Id := STPO.Self; - Return_Count : Natural; - - begin - Initialization.Defer_Abort (Self_Id); - - if Single_Lock then - Lock_RTS; - end if; - - STPO.Write_Lock (Self_Id); - Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E)); - STPO.Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort (Self_Id); - - return Return_Count; - end Task_Count; - - ---------------------- - -- Task_Do_Or_Queue -- - ---------------------- - - function Task_Do_Or_Queue - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link) return Boolean - is - E : constant Task_Entry_Index := - Task_Entry_Index (Entry_Call.E); - Old_State : constant Entry_Call_State := Entry_Call.State; - Acceptor : constant Task_Id := Entry_Call.Called_Task; - Parent : constant Task_Id := Acceptor.Common.Parent; - Null_Body : Boolean; - - begin - -- Find out whether Entry_Call can be accepted immediately - - -- If the Acceptor is not callable, return False. - -- If the rendezvous can start, initiate it. - -- If the accept-body is trivial, also complete the rendezvous. - -- If the acceptor is not ready, enqueue the call. - - -- This should have a special case for Accept_Call and Accept_Trivial, - -- so that we don't have the loop setup overhead, below. - - -- The call state Done is used here and elsewhere to include both the - -- case of normal successful completion, and the case of an exception - -- being raised. The difference is that if an exception is raised no one - -- will pay attention to the fact that State = Done. Instead the - -- exception will be raised in Undefer_Abort, and control will skip past - -- the place where we normally would resume from an entry call. - - pragma Assert (not Queuing.Onqueue (Entry_Call)); - - -- We rely that the call is off-queue for protection, that the caller - -- will not exit the Entry_Caller_Sleep, and so will not reuse the call - -- record for another call. We rely on the Caller's lock for call State - -- mod's. - - -- If Acceptor.Terminate_Alternative is True, we need to lock Parent and - -- Acceptor, in that order; otherwise, we only need a lock on Acceptor. - -- However, we can't check Acceptor.Terminate_Alternative until Acceptor - -- is locked. Therefore, we need to lock both. Attempts to avoid locking - -- Parent tend to result in race conditions. It would work to unlock - -- Parent immediately upon finding Acceptor.Terminate_Alternative to be - -- False, but that violates the rule of properly nested locking (see - -- System.Tasking). - - STPO.Write_Lock (Parent); - STPO.Write_Lock (Acceptor); - - -- If the acceptor is not callable, abort the call and return False - - if not Acceptor.Callable then - STPO.Unlock (Acceptor); - STPO.Unlock (Parent); - - pragma Assert (Entry_Call.State < Done); - - -- In case we are not the caller, set up the caller - -- to raise Tasking_Error when it wakes up. - - STPO.Write_Lock (Entry_Call.Self); - Entry_Call.Exception_To_Raise := Tasking_Error'Identity; - Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); - STPO.Unlock (Entry_Call.Self); - - return False; - end if; - - -- Try to serve the call immediately - - if Acceptor.Open_Accepts /= null then - for J in Acceptor.Open_Accepts'Range loop - if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then - - -- Commit acceptor to rendezvous with us - - Acceptor.Chosen_Index := J; - Null_Body := Acceptor.Open_Accepts (J).Null_Body; - Acceptor.Open_Accepts := null; - - -- Prevent abort while call is being served - - if Entry_Call.State = Now_Abortable then - Entry_Call.State := Was_Abortable; - end if; - - if Acceptor.Terminate_Alternative then - - -- Cancel terminate alternative. See matching code in - -- Selective_Wait and Vulnerable_Complete_Master. - - Acceptor.Terminate_Alternative := False; - Acceptor.Awake_Count := Acceptor.Awake_Count + 1; - - if Acceptor.Awake_Count = 1 then - - -- Notify parent that acceptor is awake - - pragma Assert (Parent.Awake_Count > 0); - - Parent.Awake_Count := Parent.Awake_Count + 1; - - if Parent.Common.State = Master_Completion_Sleep - and then Acceptor.Master_of_Task = Parent.Master_Within - then - Parent.Common.Wait_Count := - Parent.Common.Wait_Count + 1; - end if; - end if; - end if; - - if Null_Body then - - -- Rendezvous is over immediately - - STPO.Wakeup (Acceptor, Acceptor_Sleep); - STPO.Unlock (Acceptor); - STPO.Unlock (Parent); - - STPO.Write_Lock (Entry_Call.Self); - Initialization.Wakeup_Entry_Caller - (Self_ID, Entry_Call, Done); - STPO.Unlock (Entry_Call.Self); - - else - Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor); - - -- For terminate_alternative, acceptor may not be asleep - -- yet, so we skip the wakeup - - if Acceptor.Common.State /= Runnable then - STPO.Wakeup (Acceptor, Acceptor_Sleep); - end if; - - STPO.Unlock (Acceptor); - STPO.Unlock (Parent); - end if; - - return True; - end if; - end loop; - - -- The acceptor is accepting, but not this entry - end if; - - -- If the acceptor was ready to accept this call, - -- we would not have gotten this far, so now we should - -- (re)enqueue the call, if the mode permits that. - - -- If the call is timed, it may have timed out before the requeue, - -- in the unusual case where the current accept has taken longer than - -- the given delay. In that case the requeue is cancelled, and the - -- outer timed call will be aborted. - - if Entry_Call.Mode = Conditional_Call - or else - (Entry_Call.Mode = Timed_Call - and then Entry_Call.With_Abort - and then Entry_Call.Cancellation_Attempted) - then - STPO.Unlock (Acceptor); - STPO.Unlock (Parent); - - STPO.Write_Lock (Entry_Call.Self); - - pragma Assert (Entry_Call.State >= Was_Abortable); - - Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); - STPO.Unlock (Entry_Call.Self); - - else - -- Timed_Call, Simple_Call, or Asynchronous_Call - - Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call); - - -- Update abortability of call - - pragma Assert (Old_State < Done); - - Entry_Call.State := - New_State (Entry_Call.With_Abort, Entry_Call.State); - - STPO.Unlock (Acceptor); - STPO.Unlock (Parent); - - if Old_State /= Entry_Call.State - and then Entry_Call.State = Now_Abortable - and then Entry_Call.Mode /= Simple_Call - and then Entry_Call.Self /= Self_ID - - -- Asynchronous_Call or Conditional_Call - - then - -- Because of ATCB lock ordering rule - - STPO.Write_Lock (Entry_Call.Self); - - if Entry_Call.Self.Common.State = Async_Select_Sleep then - - -- Caller may not yet have reached wait-point - - STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); - end if; - - STPO.Unlock (Entry_Call.Self); - end if; - end if; - - return True; - end Task_Do_Or_Queue; - - --------------------- - -- Task_Entry_Call -- - --------------------- - - procedure Task_Entry_Call - (Acceptor : Task_Id; - E : Task_Entry_Index; - Uninterpreted_Data : System.Address; - Mode : Call_Modes; - Rendezvous_Successful : out Boolean) - is - Self_Id : constant Task_Id := STPO.Self; - Entry_Call : Entry_Call_Link; - - begin - -- If pragma Detect_Blocking is active then Program_Error must be - -- raised if this potentially blocking operation is called from a - -- protected action. - - if System.Tasking.Detect_Blocking - and then Self_Id.Common.Protected_Action_Nesting > 0 - then - raise Program_Error with - "potentially blocking operation"; - end if; - - if Mode = Simple_Call or else Mode = Conditional_Call then - Call_Synchronous - (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful); - - else - -- This is an asynchronous call - - -- Abort must already be deferred by the compiler-generated code. - -- Without this, an abort that occurs between the time that this - -- call is made and the time that the abortable part's cleanup - -- handler is set up might miss the cleanup handler and leave the - -- call pending. - - Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; - pragma Debug - (Debug.Trace (Self_Id, "TEC: entered ATC level: " & - ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); - Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; - Entry_Call.Next := null; - Entry_Call.Mode := Mode; - Entry_Call.Cancellation_Attempted := False; - Entry_Call.State := Not_Yet_Abortable; - Entry_Call.E := Entry_Index (E); - Entry_Call.Prio := Get_Priority (Self_Id); - Entry_Call.Uninterpreted_Data := Uninterpreted_Data; - Entry_Call.Called_Task := Acceptor; - Entry_Call.Called_PO := Null_Address; - Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; - Entry_Call.With_Abort := True; - - if Single_Lock then - Lock_RTS; - end if; - - if not Task_Do_Or_Queue (Self_Id, Entry_Call) then - STPO.Write_Lock (Self_Id); - Utilities.Exit_One_ATC_Level (Self_Id); - STPO.Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort (Self_Id); - - raise Tasking_Error; - end if; - - -- The following is special for async. entry calls. If the call was - -- not queued abortably, we need to wait until it is before - -- proceeding with the abortable part. - - -- Wait_Until_Abortable can be called unconditionally here, but it is - -- expensive. - - if Entry_Call.State < Was_Abortable then - Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call); - end if; - - if Single_Lock then - Unlock_RTS; - end if; - - -- Note: following assignment needs to be atomic - - Rendezvous_Successful := Entry_Call.State = Done; - end if; - end Task_Entry_Call; - - ----------------------- - -- Task_Entry_Caller -- - ----------------------- - - function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is - Self_Id : constant Task_Id := STPO.Self; - Entry_Call : Entry_Call_Link; - - begin - Entry_Call := Self_Id.Common.Call; - - for Depth in 1 .. D loop - Entry_Call := Entry_Call.Acceptor_Prev_Call; - pragma Assert (Entry_Call /= null); - end loop; - - return Entry_Call.Self; - end Task_Entry_Caller; - - -------------------------- - -- Timed_Selective_Wait -- - -------------------------- - - procedure Timed_Selective_Wait - (Open_Accepts : Accept_List_Access; - Select_Mode : Select_Modes; - Uninterpreted_Data : out System.Address; - Timeout : Duration; - Mode : Delay_Modes; - Index : out Select_Index) - is - Self_Id : constant Task_Id := STPO.Self; - Treatment : Select_Treatment; - Entry_Call : Entry_Call_Link; - Caller : Task_Id; - Selection : Select_Index; - Open_Alternative : Boolean; - Timedout : Boolean := False; - Yielded : Boolean := True; - - begin - pragma Assert (Select_Mode = Delay_Mode); - - Initialization.Defer_Abort (Self_Id); - - -- If we are aborted here, the effect will be pending - - if Single_Lock then - Lock_RTS; - end if; - - STPO.Write_Lock (Self_Id); - - if not Self_Id.Callable then - pragma Assert (Self_Id.Pending_ATC_Level = 0); - - pragma Assert (Self_Id.Pending_Action); - - STPO.Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort (Self_Id); - - -- Should never get here ??? - - pragma Assert (False); - raise Standard'Abort_Signal; - end if; - - Uninterpreted_Data := Null_Address; - - pragma Assert (Open_Accepts /= null); - - Queuing.Select_Task_Entry_Call - (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); - - -- Determine the kind and disposition of the select - - Treatment := Default_Treatment (Select_Mode); - Self_Id.Chosen_Index := No_Rendezvous; - - if Open_Alternative then - if Entry_Call /= null then - if Open_Accepts (Selection).Null_Body then - Treatment := Accept_Alternative_Completed; - - else - Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); - Treatment := Accept_Alternative_Selected; - end if; - - Self_Id.Chosen_Index := Selection; - - elsif Treatment = No_Alternative_Open then - Treatment := Accept_Alternative_Open; - end if; - end if; - - -- Handle the select according to the disposition selected above - - case Treatment is - when Accept_Alternative_Selected => - - -- Ready to rendezvous. In this case the accept body is not - -- Null_Body. Defer abort until it gets into the accept body. - - Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - Initialization.Defer_Abort_Nestable (Self_Id); - STPO.Unlock (Self_Id); - - when Accept_Alternative_Completed => - - -- Rendezvous is over - - STPO.Unlock (Self_Id); - Caller := Entry_Call.Self; - - STPO.Write_Lock (Caller); - Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); - STPO.Unlock (Caller); - - when Accept_Alternative_Open => - - -- Wait for caller - - Self_Id.Open_Accepts := Open_Accepts; - - -- Wait for a normal call and a pending action until the - -- Wakeup_Time is reached. - - Self_Id.Common.State := Acceptor_Delay_Sleep; - - -- Try to remove calls to Sleep in the loop below by letting the - -- caller a chance of getting ready immediately, using Unlock - -- Yield. See similar action in Wait_For_Completion/Wait_For_Call. - - if Single_Lock then - Unlock_RTS; - else - Unlock (Self_Id); - end if; - - if Self_Id.Open_Accepts /= null then - Yield; - end if; - - if Single_Lock then - Lock_RTS; - else - Write_Lock (Self_Id); - end if; - - -- Check if this task has been aborted while the lock was released - - if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then - Self_Id.Open_Accepts := null; - end if; - - loop - exit when Self_Id.Open_Accepts = null; - - if Timedout then - Sleep (Self_Id, Acceptor_Delay_Sleep); - else - STPO.Timed_Sleep (Self_Id, Timeout, Mode, - Acceptor_Delay_Sleep, Timedout, Yielded); - end if; - - if Timedout then - Self_Id.Open_Accepts := null; - end if; - end loop; - - Self_Id.Common.State := Runnable; - - -- Self_Id.Common.Call should already be updated by the Caller if - -- not aborted. It might also be ready to do rendezvous even if - -- this wakes up due to an abort. Therefore, if the call is not - -- empty we need to do the rendezvous if the accept body is not - -- Null_Body. - - if Self_Id.Chosen_Index /= No_Rendezvous - and then Self_Id.Common.Call /= null - and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body - then - Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - - pragma Assert (Self_Id.Deferral_Level = 1); - - Initialization.Defer_Abort_Nestable (Self_Id); - - -- Leave abort deferred until the accept body - end if; - - STPO.Unlock (Self_Id); - - when No_Alternative_Open => - - -- In this case, Index will be No_Rendezvous on return. We sleep - -- for the time we need to. - - -- Wait for a signal or timeout. A wakeup can be made - -- for several reasons: - -- 1) Delay is expired - -- 2) Pending_Action needs to be checked - -- (Abort, Priority change) - -- 3) Spurious wakeup - - Self_Id.Open_Accepts := null; - Self_Id.Common.State := Acceptor_Delay_Sleep; - - STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep, - Timedout, Yielded); - - Self_Id.Common.State := Runnable; - - STPO.Unlock (Self_Id); - - when others => - - -- Should never get here - - pragma Assert (False); - null; - end case; - - if Single_Lock then - Unlock_RTS; - end if; - - if not Yielded then - Yield; - end if; - - -- Caller has been chosen - - -- Self_Id.Common.Call should already be updated by the Caller - - -- Self_Id.Chosen_Index should either be updated by the Caller - -- or by Test_Selective_Wait - - Index := Self_Id.Chosen_Index; - Initialization.Undefer_Abort_Nestable (Self_Id); - - -- Start rendezvous, if not already completed - end Timed_Selective_Wait; - - --------------------------- - -- Timed_Task_Entry_Call -- - --------------------------- - - procedure Timed_Task_Entry_Call - (Acceptor : Task_Id; - E : Task_Entry_Index; - Uninterpreted_Data : System.Address; - Timeout : Duration; - Mode : Delay_Modes; - Rendezvous_Successful : out Boolean) - is - Self_Id : constant Task_Id := STPO.Self; - Level : ATC_Level; - Entry_Call : Entry_Call_Link; - - Yielded : Boolean; - pragma Unreferenced (Yielded); - - begin - -- If pragma Detect_Blocking is active then Program_Error must be - -- raised if this potentially blocking operation is called from a - -- protected action. - - if System.Tasking.Detect_Blocking - and then Self_Id.Common.Protected_Action_Nesting > 0 - then - raise Program_Error with - "potentially blocking operation"; - end if; - - Initialization.Defer_Abort (Self_Id); - Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; - - pragma Debug - (Debug.Trace (Self_Id, "TTEC: entered ATC level: " & - ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); - - Level := Self_Id.ATC_Nesting_Level; - Entry_Call := Self_Id.Entry_Calls (Level)'Access; - Entry_Call.Next := null; - Entry_Call.Mode := Timed_Call; - Entry_Call.Cancellation_Attempted := False; - - -- If this is a call made inside of an abort deferred region, - -- the call should be never abortable. - - Entry_Call.State := - (if Self_Id.Deferral_Level > 1 - then Never_Abortable - else Now_Abortable); - - Entry_Call.E := Entry_Index (E); - Entry_Call.Prio := Get_Priority (Self_Id); - Entry_Call.Uninterpreted_Data := Uninterpreted_Data; - Entry_Call.Called_Task := Acceptor; - Entry_Call.Called_PO := Null_Address; - Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; - Entry_Call.With_Abort := True; - - -- Note: the caller will undefer abort on return (see WARNING above) - - if Single_Lock then - Lock_RTS; - end if; - - if not Task_Do_Or_Queue (Self_Id, Entry_Call) then - STPO.Write_Lock (Self_Id); - Utilities.Exit_One_ATC_Level (Self_Id); - STPO.Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort (Self_Id); - - raise Tasking_Error; - end if; - - Write_Lock (Self_Id); - Entry_Calls.Wait_For_Completion_With_Timeout - (Entry_Call, Timeout, Mode, Yielded); - Unlock (Self_Id); - - if Single_Lock then - Unlock_RTS; - end if; - - -- ??? Do we need to yield in case Yielded is False - - Rendezvous_Successful := Entry_Call.State = Done; - Initialization.Undefer_Abort (Self_Id); - Entry_Calls.Check_Exception (Self_Id, Entry_Call); - end Timed_Task_Entry_Call; - - ------------------- - -- Wait_For_Call -- - ------------------- - - procedure Wait_For_Call (Self_Id : Task_Id) is - begin - Self_Id.Common.State := Acceptor_Sleep; - - -- Try to remove calls to Sleep in the loop below by letting the caller - -- a chance of getting ready immediately, using Unlock & Yield. - -- See similar action in Wait_For_Completion & Timed_Selective_Wait. - - if Single_Lock then - Unlock_RTS; - else - Unlock (Self_Id); - end if; - - if Self_Id.Open_Accepts /= null then - Yield; - end if; - - if Single_Lock then - Lock_RTS; - else - Write_Lock (Self_Id); - end if; - - -- Check if this task has been aborted while the lock was released - - if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then - Self_Id.Open_Accepts := null; - end if; - - loop - exit when Self_Id.Open_Accepts = null; - Sleep (Self_Id, Acceptor_Sleep); - end loop; - - Self_Id.Common.State := Runnable; - end Wait_For_Call; - -end System.Tasking.Rendezvous; diff --git a/gcc/ada/s-tasren.ads b/gcc/ada/s-tasren.ads deleted file mode 100644 index ea98fe3ccce..00000000000 --- a/gcc/ada/s-tasren.ads +++ /dev/null @@ -1,330 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . R E N D E Z V O U S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License 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. -- --- -- ------------------------------------------------------------------------------- - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes. - -with Ada.Exceptions; - -with System.Tasking.Protected_Objects.Entries; - -package System.Tasking.Rendezvous is - - package STPE renames System.Tasking.Protected_Objects.Entries; - - procedure Task_Entry_Call - (Acceptor : Task_Id; - E : Task_Entry_Index; - Uninterpreted_Data : System.Address; - Mode : Call_Modes; - Rendezvous_Successful : out Boolean); - -- General entry call used to implement ATC or conditional entry calls. - -- Compiler interface only. Do not call from within the RTS. - -- Acceptor is the ID of the acceptor task. - -- E is the entry index requested. - -- Uninterpreted_Data represents the parameters of the entry. It is - -- constructed by the compiler for the caller and the callee; therefore, - -- the run time never needs to decode this data. - -- Mode can be either Asynchronous_Call (ATC) or Conditional_Call. - -- Rendezvous_Successful is set to True on return if the call was serviced. - - procedure Timed_Task_Entry_Call - (Acceptor : Task_Id; - E : Task_Entry_Index; - Uninterpreted_Data : System.Address; - Timeout : Duration; - Mode : Delay_Modes; - Rendezvous_Successful : out Boolean); - -- Timed entry call without using ATC. - -- Compiler interface only. Do not call from within the RTS. - -- See Task_Entry_Call for details on Acceptor, E and Uninterpreted_Data. - -- Timeout is the value of the time out. - -- Mode determines whether the delay is relative or absolute. - - procedure Call_Simple - (Acceptor : Task_Id; - E : Task_Entry_Index; - Uninterpreted_Data : System.Address); - -- Simple entry call. - -- Compiler interface only. Do not call from within the RTS. - -- - -- source: - -- T.E1 (Params); - -- - -- expansion: - -- declare - -- P : parms := (parm1, parm2, parm3); - -- X : Task_Entry_Index := 1; - -- begin - -- Call_Simple (t._task_id, X, P'Address); - -- parm1 := P.param1; - -- parm2 := P.param2; - -- ... - -- end; - - procedure Cancel_Task_Entry_Call (Cancelled : out Boolean); - -- Cancel pending asynchronous task entry call. - -- Compiler interface only. Do not call from within the RTS. - -- See Exp_Ch9.Expand_N_Asynchronous_Select for code expansion. - - procedure Requeue_Task_Entry - (Acceptor : Task_Id; - E : Task_Entry_Index; - With_Abort : Boolean); - -- Requeue from a task entry to a task entry. - -- Compiler interface only. Do not call from within the RTS. - -- The code generation for task entry requeues is different from that for - -- protected entry requeues. There is a "goto" that skips around the call - -- to Complete_Rendezvous, so that Requeue_Task_Entry must also do the work - -- of Complete_Rendezvous. The difference is that it does not report that - -- the call's State = Done. - -- - -- source: - -- accept e1 do - -- ...A... - -- requeue e2; - -- ...B... - -- end e1; - -- - -- expansion: - -- A62b : address; - -- L61b : label - -- begin - -- accept_call (1, A62b); - -- ...A... - -- requeue_task_entry (tTV!(t)._task_id, 2, false); - -- goto L61b; - -- ...B... - -- complete_rendezvous; - -- <> - -- exception - -- when others => - -- exceptional_complete_rendezvous (current_exception); - -- end; - - procedure Requeue_Protected_To_Task_Entry - (Object : STPE.Protection_Entries_Access; - Acceptor : Task_Id; - E : Task_Entry_Index; - With_Abort : Boolean); - -- Requeue from a protected entry to a task entry. - -- Compiler interface only. Do not call from within the RTS. - -- - -- source: - -- entry e2 when b is - -- begin - -- b := false; - -- ...A... - -- requeue t.e2; - -- end e2; - -- - -- expansion: - -- procedure rPT__E14b (O : address; P : address; E : - -- protected_entry_index) is - -- type rTVP is access rTV; - -- freeze rTVP [] - -- _object : rTVP := rTVP!(O); - -- begin - -- declare - -- rR : protection renames _object._object; - -- vP : integer renames _object.v; - -- bP : boolean renames _object.b; - -- begin - -- b := false; - -- ...A... - -- requeue_protected_to_task_entry (rR'unchecked_access, tTV!(t). - -- _task_id, 2, false); - -- return; - -- end; - -- complete_entry_body (_object._object'unchecked_access, objectF => - -- 0); - -- return; - -- exception - -- when others => - -- abort_undefer.all; - -- exceptional_complete_entry_body (_object._object' - -- unchecked_access, current_exception, objectF => 0); - -- return; - -- end rPT__E14b; - - procedure Selective_Wait - (Open_Accepts : Accept_List_Access; - Select_Mode : Select_Modes; - Uninterpreted_Data : out System.Address; - Index : out Select_Index); - -- Implement select statement. - -- Compiler interface only. Do not call from within the RTS. - -- See comments on Accept_Call. - -- - -- source: - -- select accept e1 do - -- ...A... - -- end e1; - -- ...B... - -- or accept e2; - -- ...C... - -- end select; - -- - -- expansion: - -- A32b : address; - -- declare - -- A37b : T36b; - -- A37b (1) := (null_body => false, s => 1); - -- A37b (2) := (null_body => true, s => 2); - -- S0 : aliased T36b := accept_list'A37b; - -- J1 : select_index := 0; - -- procedure e1A is - -- begin - -- abort_undefer.all; - -- ...A... - -- <> - -- complete_rendezvous; - -- exception - -- when all others => - -- exceptional_complete_rendezvous (get_gnat_exception); - -- end e1A; - -- begin - -- selective_wait (S0'unchecked_access, simple_mode, A32b, J1); - -- case J1 is - -- when 0 => - -- goto L3; - -- when 1 => - -- e1A; - -- goto L1; - -- when 2 => - -- goto L2; - -- when others => - -- goto L3; - -- end case; - -- <> - -- ...B... - -- goto L3; - -- <> - -- ...C... - -- goto L3; - -- <> - -- end; - - procedure Timed_Selective_Wait - (Open_Accepts : Accept_List_Access; - Select_Mode : Select_Modes; - Uninterpreted_Data : out System.Address; - Timeout : Duration; - Mode : Delay_Modes; - Index : out Select_Index); - -- Selective wait with timeout without using ATC. - -- Compiler interface only. Do not call from within the RTS. - - procedure Accept_Call - (E : Task_Entry_Index; - Uninterpreted_Data : out System.Address); - -- Accept an entry call. - -- Compiler interface only. Do not call from within the RTS. - -- - -- source: - -- accept E do ...A... end E; - -- expansion: - -- A27b : address; - -- L26b : label - -- begin - -- accept_call (1, A27b); - -- ...A... - -- complete_rendezvous; - -- <> - -- exception - -- when all others => - -- exceptional_complete_rendezvous (get_gnat_exception); - -- end; - -- - -- The handler for Abort_Signal (*all* others) is to handle the case when - -- the acceptor is aborted between Accept_Call and the corresponding - -- Complete_Rendezvous call. We need to wake up the caller in this case. - -- - -- See also Selective_Wait - - procedure Accept_Trivial (E : Task_Entry_Index); - -- Accept an entry call that has no parameters and no body. - -- Compiler interface only. Do not call from within the RTS. - -- This should only be called when there is no accept body, or the accept - -- body is empty. - -- - -- source: - -- accept E; - -- expansion: - -- accept_trivial (1); - -- - -- The compiler is also able to recognize the following and - -- translate it the same way. - -- - -- accept E do null; end E; - - function Task_Count (E : Task_Entry_Index) return Natural; - -- Return number of tasks waiting on the entry E (of current task) - -- Compiler interface only. Do not call from within the RTS. - - function Callable (T : Task_Id) return Boolean; - -- Return T'Callable - -- Compiler interface. Do not call from within the RTS, except for body of - -- Ada.Task_Identification. - - type Task_Entry_Nesting_Depth is new Task_Entry_Index - range 0 .. Max_Task_Entry; - - function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id; - -- Return E'Caller. This will only work if called from within an - -- accept statement that is handling E, as required by the LRM (C.7.1(14)). - -- Compiler interface only. Do not call from within the RTS. - - procedure Complete_Rendezvous; - -- Called by acceptor to wake up caller - - procedure Exceptional_Complete_Rendezvous - (Ex : Ada.Exceptions.Exception_Id); - pragma No_Return (Exceptional_Complete_Rendezvous); - -- Called by acceptor to mark the end of the current rendezvous and - -- propagate an exception to the caller. - - -- For internal use only: - - function Task_Do_Or_Queue - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link) return Boolean; - -- Call this only with abort deferred and holding no locks, except - -- the global RTS lock when Single_Lock is True which must be owned. - -- Returns False iff the call cannot be served or queued, as is the - -- case if the caller is not callable; i.e., a False return value - -- indicates that Tasking_Error should be raised. - -- Either initiate the entry call, such that the accepting task is - -- free to execute the rendezvous, queue the call on the acceptor's - -- queue, or cancel the call. Conditional calls that cannot be - -- accepted immediately are cancelled. - -end System.Tasking.Rendezvous; diff --git a/gcc/ada/s-tasres.ads b/gcc/ada/s-tasres.ads deleted file mode 100644 index 9445744da17..00000000000 --- a/gcc/ada/s-tasres.ads +++ /dev/null @@ -1,35 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . R E S T R I C T E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-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. -- --- -- ------------------------------------------------------------------------------- - --- This is the parent package of the GNAT restricted tasking run time - -package System.Tasking.Restricted is -end System.Tasking.Restricted; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb deleted file mode 100644 index 346e5bfe142..00000000000 --- a/gcc/ada/s-tassta.adb +++ /dev/null @@ -1,2128 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . S T A G E 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. -- --- -- ------------------------------------------------------------------------------- - -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. - -pragma Partition_Elaboration_Policy (Concurrent); --- This package only implements the concurrent elaboration policy. This pragma --- will enforce it (and detect conflicts with user specified policy). - -with Ada.Exceptions; -with Ada.Unchecked_Deallocation; - -with System.Interrupt_Management; -with System.Tasking.Debug; -with System.Address_Image; -with System.Task_Primitives; -with System.Task_Primitives.Operations; -with System.Tasking.Utilities; -with System.Tasking.Queuing; -with System.Tasking.Rendezvous; -with System.OS_Primitives; -with System.Secondary_Stack; -with System.Restrictions; -with System.Standard_Library; -with System.Stack_Usage; -with System.Storage_Elements; - -with System.Soft_Links; --- These are procedure pointers to non-tasking routines that use task --- specific data. In the absence of tasking, these routines refer to global --- data. In the presence of tasking, they must be replaced with pointers to --- task-specific versions. Also used for Create_TSD, Destroy_TSD, Get_Current --- _Excep, Finalize_Library_Objects, Task_Termination, Handler. - -with System.Tasking.Initialization; -pragma Elaborate_All (System.Tasking.Initialization); --- This insures that tasking is initialized if any tasks are created - -package body System.Tasking.Stages is - - package STPO renames System.Task_Primitives.Operations; - package SSL renames System.Soft_Links; - package SSE renames System.Storage_Elements; - package SST renames System.Secondary_Stack; - - use Ada.Exceptions; - - use Parameters; - use Task_Primitives; - use Task_Primitives.Operations; - use Task_Info; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - - procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id); - -- This procedure outputs the task specific message for exception - -- tracing purposes. - - procedure Task_Wrapper (Self_ID : Task_Id); - pragma Convention (C, Task_Wrapper); - -- This is the procedure that is called by the GNULL from the new context - -- when a task is created. It waits for activation and then calls the task - -- body procedure. When the task body procedure completes, it terminates - -- the task. - -- - -- The Task_Wrapper's address will be provided to the underlying threads - -- library as the task entry point. Convention C is what makes most sense - -- for that purpose (Export C would make the function globally visible, - -- and affect the link name on which GDB depends). This will in addition - -- trigger an automatic stack alignment suitable for GCC's assumptions if - -- need be. - - -- "Vulnerable_..." in the procedure names below means they must be called - -- with abort deferred. - - procedure Vulnerable_Complete_Task (Self_ID : Task_Id); - -- Complete the calling task. This procedure must be called with - -- abort deferred. It should only be called by Complete_Task and - -- Finalize_Global_Tasks (for the environment task). - - procedure Vulnerable_Complete_Master (Self_ID : Task_Id); - -- Complete the current master of the calling task. This procedure - -- must be called with abort deferred. It should only be called by - -- Vulnerable_Complete_Task and Complete_Master. - - procedure Vulnerable_Complete_Activation (Self_ID : Task_Id); - -- Signal to Self_ID's activator that Self_ID has completed activation. - -- This procedure must be called with abort deferred. - - procedure Abort_Dependents (Self_ID : Task_Id); - -- Abort all the direct dependents of Self at its current master nesting - -- level, plus all of their dependents, transitively. RTS_Lock should be - -- locked by the caller. - - procedure Vulnerable_Free_Task (T : Task_Id); - -- Recover all runtime system storage associated with the task T. This - -- should only be called after T has terminated and will no longer be - -- referenced. - -- - -- For tasks created by an allocator that fails, due to an exception, it is - -- called from Expunge_Unactivated_Tasks. - -- - -- Different code is used at master completion, in Terminate_Dependents, - -- due to a need for tighter synchronization with the master. - - ---------------------- - -- Abort_Dependents -- - ---------------------- - - procedure Abort_Dependents (Self_ID : Task_Id) is - C : Task_Id; - P : Task_Id; - - -- Each task C will take care of its own dependents, so there is no - -- need to worry about them here. In fact, it would be wrong to abort - -- indirect dependents here, because we can't distinguish between - -- duplicate master ids. For example, suppose we have three nested - -- task bodies T1,T2,T3. And suppose T1 also calls P which calls Q (and - -- both P and Q are task masters). Q will have the same master id as - -- Master_of_Task of T3. Previous versions of this would abort T3 when - -- Q calls Complete_Master, which was completely wrong. - - begin - C := All_Tasks_List; - while C /= null loop - P := C.Common.Parent; - - if P = Self_ID then - if C.Master_of_Task = Self_ID.Master_Within then - pragma Debug - (Debug.Trace (Self_ID, "Aborting", 'X', C)); - Utilities.Abort_One_Task (Self_ID, C); - C.Dependents_Aborted := True; - end if; - end if; - - C := C.Common.All_Tasks_Link; - end loop; - - Self_ID.Dependents_Aborted := True; - end Abort_Dependents; - - ----------------- - -- Abort_Tasks -- - ----------------- - - procedure Abort_Tasks (Tasks : Task_List) is - begin - Utilities.Abort_Tasks (Tasks); - end Abort_Tasks; - - -------------------- - -- Activate_Tasks -- - -------------------- - - -- Note that locks of activator and activated task are both locked here. - -- This is necessary because C.Common.State and Self.Common.Wait_Count have - -- to be synchronized. This is safe from deadlock because the activator is - -- always created before the activated task. That satisfies our - -- in-order-of-creation ATCB locking policy. - - -- At one point, we may also lock the parent, if the parent is different - -- from the activator. That is also consistent with the lock ordering - -- policy, since the activator cannot be created before the parent. - - -- Since we are holding both the activator's lock, and Task_Wrapper locks - -- that before it does anything more than initialize the low-level ATCB - -- components, it should be safe to wait to update the counts until we see - -- that the thread creation is successful. - - -- If the thread creation fails, we do need to close the entries of the - -- task. The first phase, of dequeuing calls, only requires locking the - -- acceptor's ATCB, but the waking up of the callers requires locking the - -- caller's ATCB. We cannot safely do this while we are holding other - -- locks. Therefore, the queue-clearing operation is done in a separate - -- pass over the activation chain. - - procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is - Self_ID : constant Task_Id := STPO.Self; - P : Task_Id; - C : Task_Id; - Next_C, Last_C : Task_Id; - Activate_Prio : System.Any_Priority; - Success : Boolean; - All_Elaborated : Boolean := True; - - begin - -- If pragma Detect_Blocking is active, then we must check whether this - -- potentially blocking operation is called from a protected action. - - if System.Tasking.Detect_Blocking - and then Self_ID.Common.Protected_Action_Nesting > 0 - then - raise Program_Error with "potentially blocking operation"; - end if; - - pragma Debug - (Debug.Trace (Self_ID, "Activate_Tasks", 'C')); - - Initialization.Defer_Abort_Nestable (Self_ID); - - pragma Assert (Self_ID.Common.Wait_Count = 0); - - -- Lock RTS_Lock, to prevent activated tasks from racing ahead before - -- we finish activating the chain. - - Lock_RTS; - - -- Check that all task bodies have been elaborated - - C := Chain_Access.T_ID; - Last_C := null; - while C /= null loop - if C.Common.Elaborated /= null - and then not C.Common.Elaborated.all - then - All_Elaborated := False; - end if; - - -- Reverse the activation chain so that tasks are activated in the - -- same order they're declared. - - Next_C := C.Common.Activation_Link; - C.Common.Activation_Link := Last_C; - Last_C := C; - C := Next_C; - end loop; - - Chain_Access.T_ID := Last_C; - - if not All_Elaborated then - Unlock_RTS; - Initialization.Undefer_Abort_Nestable (Self_ID); - raise Program_Error with "Some tasks have not been elaborated"; - end if; - - -- Activate all the tasks in the chain. Creation of the thread of - -- control was deferred until activation. So create it now. - - C := Chain_Access.T_ID; - while C /= null loop - if C.Common.State /= Terminated then - pragma Assert (C.Common.State = Unactivated); - - P := C.Common.Parent; - Write_Lock (P); - Write_Lock (C); - - Activate_Prio := - (if C.Common.Base_Priority < Get_Priority (Self_ID) - then Get_Priority (Self_ID) - else C.Common.Base_Priority); - - System.Task_Primitives.Operations.Create_Task - (C, Task_Wrapper'Address, - Parameters.Size_Type - (C.Common.Compiler_Data.Pri_Stack_Info.Size), - Activate_Prio, Success); - - -- There would be a race between the created task and the creator - -- to do the following initialization, if we did not have a - -- Lock/Unlock_RTS pair in the task wrapper to prevent it from - -- racing ahead. - - if Success then - C.Common.State := Activating; - C.Awake_Count := 1; - C.Alive_Count := 1; - P.Awake_Count := P.Awake_Count + 1; - P.Alive_Count := P.Alive_Count + 1; - - if P.Common.State = Master_Completion_Sleep and then - C.Master_of_Task = P.Master_Within - then - pragma Assert (Self_ID /= P); - P.Common.Wait_Count := P.Common.Wait_Count + 1; - end if; - - for J in System.Tasking.Debug.Known_Tasks'Range loop - if System.Tasking.Debug.Known_Tasks (J) = null then - System.Tasking.Debug.Known_Tasks (J) := C; - C.Known_Tasks_Index := J; - exit; - end if; - end loop; - - if Global_Task_Debug_Event_Set then - Debug.Signal_Debug_Event - (Debug.Debug_Event_Activating, C); - end if; - - C.Common.State := Runnable; - - Unlock (C); - Unlock (P); - - else - -- No need to set Awake_Count, State, etc. here since the loop - -- below will do that for any Unactivated tasks. - - Unlock (C); - Unlock (P); - Self_ID.Common.Activation_Failed := True; - end if; - end if; - - C := C.Common.Activation_Link; - end loop; - - if not Single_Lock then - Unlock_RTS; - end if; - - -- Close the entries of any tasks that failed thread creation, and count - -- those that have not finished activation. - - Write_Lock (Self_ID); - Self_ID.Common.State := Activator_Sleep; - - C := Chain_Access.T_ID; - while C /= null loop - Write_Lock (C); - - if C.Common.State = Unactivated then - C.Common.Activator := null; - C.Common.State := Terminated; - C.Callable := False; - Utilities.Cancel_Queued_Entry_Calls (C); - - elsif C.Common.Activator /= null then - Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; - end if; - - Unlock (C); - P := C.Common.Activation_Link; - C.Common.Activation_Link := null; - C := P; - end loop; - - -- Wait for the activated tasks to complete activation. It is - -- unsafe to abort any of these tasks until the count goes to zero. - - loop - exit when Self_ID.Common.Wait_Count = 0; - Sleep (Self_ID, Activator_Sleep); - end loop; - - Self_ID.Common.State := Runnable; - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - -- Remove the tasks from the chain - - Chain_Access.T_ID := null; - Initialization.Undefer_Abort_Nestable (Self_ID); - - if Self_ID.Common.Activation_Failed then - Self_ID.Common.Activation_Failed := False; - raise Tasking_Error with "Failure during activation"; - end if; - end Activate_Tasks; - - ------------------------- - -- Complete_Activation -- - ------------------------- - - procedure Complete_Activation is - Self_ID : constant Task_Id := STPO.Self; - - begin - Initialization.Defer_Abort_Nestable (Self_ID); - - if Single_Lock then - Lock_RTS; - end if; - - Vulnerable_Complete_Activation (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort_Nestable (Self_ID); - - -- ??? Why do we need to allow for nested deferral here? - - end Complete_Activation; - - --------------------- - -- Complete_Master -- - --------------------- - - procedure Complete_Master is - Self_ID : constant Task_Id := STPO.Self; - begin - pragma Assert - (Self_ID.Deferral_Level > 0 - or else not System.Restrictions.Abort_Allowed); - Vulnerable_Complete_Master (Self_ID); - end Complete_Master; - - ------------------- - -- Complete_Task -- - ------------------- - - -- See comments on Vulnerable_Complete_Task for details - - procedure Complete_Task is - Self_ID : constant Task_Id := STPO.Self; - - begin - pragma Assert - (Self_ID.Deferral_Level > 0 - or else not System.Restrictions.Abort_Allowed); - - Vulnerable_Complete_Task (Self_ID); - - -- All of our dependents have terminated, never undefer abort again - - end Complete_Task; - - ----------------- - -- Create_Task -- - ----------------- - - -- Compiler interface only. Do not call from within the RTS. This must be - -- called to create a new task. - - procedure Create_Task - (Priority : Integer; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - Relative_Deadline : Ada.Real_Time.Time_Span; - Domain : Dispatching_Domain_Access; - Num_Entries : Task_Entry_Index; - Master : Master_Level; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Chain : in out Activation_Chain; - Task_Image : String; - Created_Task : out Task_Id) - is - T, P : Task_Id; - Self_ID : constant Task_Id := STPO.Self; - Success : Boolean; - Base_Priority : System.Any_Priority; - Len : Natural; - Base_CPU : System.Multiprocessors.CPU_Range; - - use type System.Multiprocessors.CPU_Range; - - pragma Unreferenced (Relative_Deadline); - -- EDF scheduling is not supported by any of the target platforms so - -- this parameter is not passed any further. - - begin - -- If Master is greater than the current master, it means that Master - -- has already awaited its dependent tasks. This raises Program_Error, - -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads. - - if Self_ID.Master_of_Task /= Foreign_Task_Level - and then Master > Self_ID.Master_Within - then - raise Program_Error with - "create task after awaiting termination"; - end if; - - -- If pragma Detect_Blocking is active must be checked whether this - -- potentially blocking operation is called from a protected action. - - if System.Tasking.Detect_Blocking - and then Self_ID.Common.Protected_Action_Nesting > 0 - then - raise Program_Error with "potentially blocking operation"; - end if; - - pragma Debug (Debug.Trace (Self_ID, "Create_Task", 'C')); - - Base_Priority := - (if Priority = Unspecified_Priority - then Self_ID.Common.Base_Priority - else System.Any_Priority (Priority)); - - -- Legal values of CPU are the special Unspecified_CPU value which is - -- inserted by the compiler for tasks without CPU aspect, and those in - -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise - -- the task is defined to have failed, and it becomes a completed task - -- (RM D.16(14/3)). - - if CPU /= Unspecified_CPU - and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) - or else - CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) - then - raise Tasking_Error with "CPU not in range"; - - -- Normal CPU affinity - - else - -- When the application code says nothing about the task affinity - -- (task without CPU aspect) then the compiler inserts the value - -- Unspecified_CPU which indicates to the run-time library that - -- the task will activate and execute on the same processor as its - -- activating task if the activating task is assigned a processor - -- (RM D.16(14/3)). - - Base_CPU := - (if CPU = Unspecified_CPU - then Self_ID.Common.Base_CPU - else System.Multiprocessors.CPU_Range (CPU)); - end if; - - -- Find parent P of new Task, via master level number. Independent - -- tasks should have Parent = Environment_Task, and all tasks created - -- by independent tasks are also independent. See, for example, - -- s-interr.adb, where Interrupt_Manager does "new Server_Task". The - -- access type is at library level, so the parent of the Server_Task - -- is Environment_Task. - - P := Self_ID; - - if P.Master_of_Task <= Independent_Task_Level then - P := Environment_Task; - else - while P /= null and then P.Master_of_Task >= Master loop - P := P.Common.Parent; - end loop; - end if; - - Initialization.Defer_Abort_Nestable (Self_ID); - - begin - T := New_ATCB (Num_Entries); - exception - when others => - Initialization.Undefer_Abort_Nestable (Self_ID); - raise Storage_Error with "Cannot allocate task"; - end; - - -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. Up to this - -- point, it is possible that we may be part of a family of tasks that - -- is being aborted. - - Lock_RTS; - Write_Lock (Self_ID); - - -- Now, we must check that we have not been aborted. If so, we should - -- give up on creating this task, and simply return. - - if not Self_ID.Callable then - pragma Assert (Self_ID.Pending_ATC_Level = 0); - pragma Assert (Self_ID.Pending_Action); - pragma Assert - (Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated); - - Unlock (Self_ID); - Unlock_RTS; - Initialization.Undefer_Abort_Nestable (Self_ID); - - -- ??? Should never get here - - pragma Assert (False); - raise Standard'Abort_Signal; - end if; - - Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated, - Base_Priority, Base_CPU, Domain, Task_Info, Size, - Secondary_Stack_Size, T, Success); - - if not Success then - Free (T); - Unlock (Self_ID); - Unlock_RTS; - Initialization.Undefer_Abort_Nestable (Self_ID); - raise Storage_Error with "Failed to initialize task"; - end if; - - if Master = Foreign_Task_Level + 2 then - - -- This should not happen, except when a foreign task creates non - -- library-level Ada tasks. In this case, we pretend the master is - -- a regular library level task, otherwise the run-time will get - -- confused when waiting for these tasks to terminate. - - T.Master_of_Task := Library_Task_Level; - - else - T.Master_of_Task := Master; - end if; - - T.Master_Within := T.Master_of_Task + 1; - - for L in T.Entry_Calls'Range loop - T.Entry_Calls (L).Self := T; - T.Entry_Calls (L).Level := L; - end loop; - - if Task_Image'Length = 0 then - T.Common.Task_Image_Len := 0; - else - Len := 1; - T.Common.Task_Image (1) := Task_Image (Task_Image'First); - - -- Remove unwanted blank space generated by 'Image - - for J in Task_Image'First + 1 .. Task_Image'Last loop - if Task_Image (J) /= ' ' - or else Task_Image (J - 1) /= '(' - then - Len := Len + 1; - T.Common.Task_Image (Len) := Task_Image (J); - exit when Len = T.Common.Task_Image'Last; - end if; - end loop; - - T.Common.Task_Image_Len := Len; - end if; - - -- Note: we used to have code here to initialize T.Commmon.Domain, but - -- that is not needed, since this is initialized in System.Tasking. - - Unlock (Self_ID); - Unlock_RTS; - - -- The CPU associated to the task (if any) must belong to the - -- dispatching domain. - - if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU - and then - (Base_CPU not in T.Common.Domain'Range - or else not T.Common.Domain (Base_CPU)) - then - Initialization.Undefer_Abort_Nestable (Self_ID); - raise Tasking_Error with "CPU not in dispatching domain"; - end if; - - -- To handle the interaction between pragma CPU and dispatching domains - -- we need to signal that this task is being allocated to a processor. - -- This is needed only for tasks belonging to the system domain (the - -- creation of new dispatching domains can only take processors from the - -- system domain) and only before the environment task calls the main - -- procedure (dispatching domains cannot be created after this). - - if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU - and then T.Common.Domain = System.Tasking.System_Domain - and then not System.Tasking.Dispatching_Domains_Frozen - then - -- Increase the number of tasks attached to the CPU to which this - -- task is being moved. - - Dispatching_Domain_Tasks (Base_CPU) := - Dispatching_Domain_Tasks (Base_CPU) + 1; - end if; - - -- Create TSD as early as possible in the creation of a task, since it - -- may be used by the operation of Ada code within the task. - - SSL.Create_TSD (T.Common.Compiler_Data); - T.Common.Activation_Link := Chain.T_ID; - Chain.T_ID := T; - Created_Task := T; - Initialization.Undefer_Abort_Nestable (Self_ID); - - pragma Debug - (Debug.Trace - (Self_ID, "Created task in " & T.Master_of_Task'Img, 'C', T)); - end Create_Task; - - -------------------- - -- Current_Master -- - -------------------- - - function Current_Master return Master_Level is - begin - return STPO.Self.Master_Within; - end Current_Master; - - ------------------ - -- Enter_Master -- - ------------------ - - procedure Enter_Master is - Self_ID : constant Task_Id := STPO.Self; - begin - Self_ID.Master_Within := Self_ID.Master_Within + 1; - pragma Debug - (Debug.Trace - (Self_ID, "Enter_Master ->" & Self_ID.Master_Within'Img, 'M')); - end Enter_Master; - - ------------------------------- - -- Expunge_Unactivated_Tasks -- - ------------------------------- - - -- See procedure Close_Entries for the general case - - procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is - Self_ID : constant Task_Id := STPO.Self; - C : Task_Id; - Call : Entry_Call_Link; - Temp : Task_Id; - - begin - pragma Debug - (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C')); - - Initialization.Defer_Abort_Nestable (Self_ID); - - -- ??? - -- Experimentation has shown that abort is sometimes (but not always) - -- already deferred when this is called. - - -- That may indicate an error. Find out what is going on - - C := Chain.T_ID; - while C /= null loop - pragma Assert (C.Common.State = Unactivated); - - Temp := C.Common.Activation_Link; - - if C.Common.State = Unactivated then - Lock_RTS; - Write_Lock (C); - - for J in 1 .. C.Entry_Num loop - Queuing.Dequeue_Head (C.Entry_Queues (J), Call); - pragma Assert (Call = null); - end loop; - - Unlock (C); - - Initialization.Remove_From_All_Tasks_List (C); - Unlock_RTS; - - Vulnerable_Free_Task (C); - C := Temp; - end if; - end loop; - - Chain.T_ID := null; - Initialization.Undefer_Abort_Nestable (Self_ID); - end Expunge_Unactivated_Tasks; - - --------------------------- - -- Finalize_Global_Tasks -- - --------------------------- - - -- ??? - -- We have a potential problem here if finalization of global objects does - -- anything with signals or the timer server, since by that time those - -- servers have terminated. - - -- It is hard to see how that would occur - - -- However, a better solution might be to do all this finalization - -- using the global finalization chain. - - procedure Finalize_Global_Tasks is - Self_ID : constant Task_Id := STPO.Self; - - Ignore_1 : Boolean; - Ignore_2 : Boolean; - - function State - (Int : System.Interrupt_Management.Interrupt_ID) return Character; - pragma Import (C, State, "__gnat_get_interrupt_state"); - -- Get interrupt state for interrupt number Int. Defined in init.c - - Default : constant Character := 's'; - -- 's' Interrupt_State pragma set state to System (use "default" - -- system handler) - - begin - if Self_ID.Deferral_Level = 0 then - -- ??? - -- In principle, we should be able to predict whether abort is - -- already deferred here (and it should not be deferred yet but in - -- practice it seems Finalize_Global_Tasks is being called sometimes, - -- from RTS code for exceptions, with abort already deferred. - - Initialization.Defer_Abort_Nestable (Self_ID); - - -- Never undefer again - end if; - - -- This code is only executed by the environment task - - pragma Assert (Self_ID = Environment_Task); - - -- Set Environment_Task'Callable to false to notify library-level tasks - -- that it is waiting for them. - - Self_ID.Callable := False; - - -- Exit level 2 master, for normal tasks in library-level packages - - Complete_Master; - - -- Force termination of "independent" library-level server tasks - - Lock_RTS; - - Abort_Dependents (Self_ID); - - if not Single_Lock then - Unlock_RTS; - end if; - - -- We need to explicitly wait for the task to be terminated here - -- because on true concurrent system, we may end this procedure before - -- the tasks are really terminated. - - Write_Lock (Self_ID); - - -- If the Abort_Task signal is set to system, it means that we may - -- not have been able to abort all independent tasks (in particular, - -- Server_Task may be blocked, waiting for a signal), in which case, do - -- not wait for Independent_Task_Count to go down to 0. We arbitrarily - -- limit the number of loop iterations; if an independent task does not - -- terminate, we do not want to hang here. In that case, the thread will - -- be terminated when the process exits. - - if State (System.Interrupt_Management.Abort_Task_Interrupt) /= Default - then - for J in 1 .. 10 loop - exit when Utilities.Independent_Task_Count = 0; - - -- We used to yield here, but this did not take into account low - -- priority tasks that would cause dead lock in some cases (true - -- FIFO scheduling). - - Timed_Sleep - (Self_ID, 0.01, System.OS_Primitives.Relative, - Self_ID.Common.State, Ignore_1, Ignore_2); - end loop; - end if; - - -- ??? On multi-processor environments, it seems that the above loop - -- isn't sufficient, so we need to add an additional delay. - - Timed_Sleep - (Self_ID, 0.01, System.OS_Primitives.Relative, - Self_ID.Common.State, Ignore_1, Ignore_2); - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - -- Complete the environment task - - Vulnerable_Complete_Task (Self_ID); - - -- Handle normal task termination by the environment task, but only - -- for the normal task termination. In the case of Abnormal and - -- Unhandled_Exception they must have been handled before, and the - -- task termination soft link must have been changed so the task - -- termination routine is not executed twice. - - SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence); - - -- Finalize all library-level controlled objects - - if not SSL."=" (SSL.Finalize_Library_Objects, null) then - SSL.Finalize_Library_Objects.all; - end if; - - -- Reset the soft links to non-tasking - - SSL.Abort_Defer := SSL.Abort_Defer_NT'Access; - SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access; - SSL.Lock_Task := SSL.Task_Lock_NT'Access; - SSL.Unlock_Task := SSL.Task_Unlock_NT'Access; - SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access; - SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access; - SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access; - SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access; - SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access; - SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access; - - -- Don't bother trying to finalize Initialization.Global_Task_Lock - -- and System.Task_Primitives.RTS_Lock. - - end Finalize_Global_Tasks; - - --------------- - -- Free_Task -- - --------------- - - procedure Free_Task (T : Task_Id) is - Self_Id : constant Task_Id := Self; - - begin - if T.Common.State = Terminated then - - -- It is not safe to call Abort_Defer or Write_Lock at this stage - - Initialization.Task_Lock (Self_Id); - - Lock_RTS; - Initialization.Finalize_Attributes (T); - Initialization.Remove_From_All_Tasks_List (T); - Unlock_RTS; - - Initialization.Task_Unlock (Self_Id); - - System.Task_Primitives.Operations.Finalize_TCB (T); - - else - -- If the task is not terminated, then mark the task as to be freed - -- upon termination. - - T.Free_On_Termination := True; - end if; - end Free_Task; - - --------------------------- - -- Move_Activation_Chain -- - --------------------------- - - procedure Move_Activation_Chain - (From, To : Activation_Chain_Access; - New_Master : Master_ID) - is - Self_ID : constant Task_Id := STPO.Self; - C : Task_Id; - - begin - pragma Debug - (Debug.Trace (Self_ID, "Move_Activation_Chain", 'C')); - - -- Nothing to do if From is empty, and we can check that without - -- deferring aborts. - - C := From.all.T_ID; - - if C = null then - return; - end if; - - Initialization.Defer_Abort_Nestable (Self_ID); - - -- Loop through the From chain, changing their Master_of_Task fields, - -- and to find the end of the chain. - - loop - C.Master_of_Task := New_Master; - exit when C.Common.Activation_Link = null; - C := C.Common.Activation_Link; - end loop; - - -- Hook From in at the start of To - - C.Common.Activation_Link := To.all.T_ID; - To.all.T_ID := From.all.T_ID; - - -- Set From to empty - - From.all.T_ID := null; - - Initialization.Undefer_Abort_Nestable (Self_ID); - end Move_Activation_Chain; - - ------------------ - -- Task_Wrapper -- - ------------------ - - -- The task wrapper is a procedure that is called first for each task body - -- and which in turn calls the compiler-generated task body procedure. - -- The wrapper's main job is to do initialization for the task. It also - -- has some locally declared objects that serve as per-task local data. - -- Task finalization is done by Complete_Task, which is called from an - -- at-end handler that the compiler generates. - - procedure Task_Wrapper (Self_ID : Task_Id) is - use type SSE.Storage_Offset; - use System.Standard_Library; - use System.Stack_Usage; - - Bottom_Of_Stack : aliased Integer; - - Task_Alternate_Stack : - aliased SSE.Storage_Array (1 .. Alternate_Stack_Size); - -- The alternate signal stack for this task, if any - - Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; - -- Whether to use above alternate signal stack for stack overflows - - function Secondary_Stack_Size return Storage_Elements.Storage_Offset; - -- Returns the size of the secondary stack for the task. For fixed - -- secondary stacks, the function will return the ATCB field - -- Secondary_Stack_Size if it is not set to Unspecified_Size, - -- otherwise a percentage of the stack is reserved using the - -- System.Parameters.Sec_Stack_Percentage property. - - -- Dynamic secondary stacks are allocated in System.Soft_Links. - -- Create_TSD and thus the function returns 0 to suppress the - -- creation of the fixed secondary stack in the primary stack. - - -------------------------- - -- Secondary_Stack_Size -- - -------------------------- - - function Secondary_Stack_Size return Storage_Elements.Storage_Offset is - use System.Storage_Elements; - use System.Secondary_Stack; - - begin - if Parameters.Sec_Stack_Dynamic then - return 0; - - elsif Self_ID.Common.Secondary_Stack_Size = Unspecified_Size then - return (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size - * SSE.Storage_Offset (Sec_Stack_Percentage) / 100); - else - -- Use the size specified by aspect Secondary_Stack_Size padded - -- by the amount of space used by the stack data structure. - - return Storage_Offset (Self_ID.Common.Secondary_Stack_Size) + - Storage_Offset (SST.Minimum_Secondary_Stack_Size); - end if; - end Secondary_Stack_Size; - - Secondary_Stack : aliased Storage_Elements.Storage_Array - (1 .. Secondary_Stack_Size); - for Secondary_Stack'Alignment use Standard'Maximum_Alignment; - -- Actual area allocated for secondary stack. Note that it is critical - -- that this have maximum alignment, since any kind of data can be - -- allocated here. - - Secondary_Stack_Address : System.Address := Secondary_Stack'Address; - -- Address of secondary stack. In the fixed secondary stack case, this - -- value is not modified, causing a warning, hence the bracketing with - -- Warnings (Off/On). But why is so much *more* bracketed??? - - SEH_Table : aliased SSE.Storage_Array (1 .. 8); - -- Structured Exception Registration table (2 words) - - procedure Install_SEH_Handler (Addr : System.Address); - pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler"); - -- Install the SEH (Structured Exception Handling) handler - - Cause : Cause_Of_Termination := Normal; - -- Indicates the reason why this task terminates. Normal corresponds to - -- a task terminating due to completing the last statement of its body, - -- or as a result of waiting on a terminate alternative. If the task - -- terminates because it is being aborted then Cause will be set - -- to Abnormal. If the task terminates because of an exception - -- raised by the execution of its task body, then Cause is set - -- to Unhandled_Exception. - - EO : Exception_Occurrence; - -- If the task terminates because of an exception raised by the - -- execution of its task body, then EO will contain the associated - -- exception occurrence. Otherwise, it will contain Null_Occurrence. - - TH : Termination_Handler := null; - -- Pointer to the protected procedure to be executed upon task - -- termination. - - procedure Search_Fall_Back_Handler (ID : Task_Id); - -- Procedure that searches recursively a fall-back handler through the - -- master relationship. If the handler is found, its pointer is stored - -- in TH. It stops when the handler is found or when the ID is null. - - ------------------------------ - -- Search_Fall_Back_Handler -- - ------------------------------ - - procedure Search_Fall_Back_Handler (ID : Task_Id) is - begin - -- A null Task_Id indicates that we have reached the root of the - -- task hierarchy and no handler has been found. - - if ID = null then - return; - - -- If there is a fall back handler, store its pointer for later - -- execution. - - elsif ID.Common.Fall_Back_Handler /= null then - TH := ID.Common.Fall_Back_Handler; - - -- Otherwise look for a fall back handler in the parent - - else - Search_Fall_Back_Handler (ID.Common.Parent); - end if; - end Search_Fall_Back_Handler; - - -- Start of processing for Task_Wrapper - - begin - pragma Assert (Self_ID.Deferral_Level = 1); - - Debug.Master_Hook - (Self_ID, Self_ID.Common.Parent, Self_ID.Master_of_Task); - - -- Assume a size of the stack taken at this stage - - if not Parameters.Sec_Stack_Dynamic then - Self_ID.Common.Compiler_Data.Sec_Stack_Addr := - Secondary_Stack'Address; - SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last)); - end if; - - if Use_Alternate_Stack then - Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address; - end if; - - -- Set the guard page at the bottom of the stack. The call to unprotect - -- the page is done in Terminate_Task - - Stack_Guard (Self_ID, True); - - -- Initialize low-level TCB components, that cannot be initialized by - -- the creator. Enter_Task sets Self_ID.LL.Thread. - - Enter_Task (Self_ID); - - -- Initialize dynamic stack usage - - if System.Stack_Usage.Is_Enabled then - declare - Guard_Page_Size : constant := 16 * 1024; - -- Part of the stack used as a guard page. This is an OS dependent - -- value, so we need to use the maximum. This value is only used - -- when the stack address is known, that is currently Windows. - - Small_Overflow_Guard : constant := 12 * 1024; - -- Note: this used to be 4K, but was changed to 12K, since - -- smaller values resulted in segmentation faults from dynamic - -- stack analysis. - - Big_Overflow_Guard : constant := 64 * 1024 + 8 * 1024; - Small_Stack_Limit : constant := 64 * 1024; - -- ??? These three values are experimental, and seem to work on - -- most platforms. They still need to be analyzed further. They - -- also need documentation, what are they and why does the logic - -- differ depending on whether the stack is large or small??? - - Pattern_Size : Natural := - Natural (Self_ID.Common. - Compiler_Data.Pri_Stack_Info.Size); - -- Size of the pattern - - Stack_Base : Address; - -- Address of the base of the stack - - begin - Stack_Base := Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base; - - if Stack_Base = Null_Address then - - -- On many platforms, we don't know the real stack base - -- address. Estimate it using an address in the frame. - - Stack_Base := Bottom_Of_Stack'Address; - - -- Also reduce the size of the stack to take into account the - -- secondary stack array declared in this frame. This is for - -- sure very conservative. - - if not Parameters.Sec_Stack_Dynamic then - Pattern_Size := - Pattern_Size - Natural (Secondary_Stack_Size); - end if; - - -- Adjustments for inner frames - - Pattern_Size := Pattern_Size - - (if Pattern_Size < Small_Stack_Limit - then Small_Overflow_Guard - else Big_Overflow_Guard); - else - -- Reduce by the size of the final guard page - - Pattern_Size := Pattern_Size - Guard_Page_Size; - end if; - - STPO.Lock_RTS; - Initialize_Analyzer - (Self_ID.Common.Analyzer, - Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len), - Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size), - SSE.To_Integer (Stack_Base), - Pattern_Size); - STPO.Unlock_RTS; - Fill_Stack (Self_ID.Common.Analyzer); - end; - end if; - - -- We setup the SEH (Structured Exception Handling) handler if supported - -- on the target. - - Install_SEH_Handler (SEH_Table'Address); - - -- Initialize exception occurrence - - Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); - - -- We lock RTS_Lock to wait for activator to finish activating the rest - -- of the chain, so that everyone in the chain comes out in priority - -- order. - - -- This also protects the value of - -- Self_ID.Common.Activator.Common.Wait_Count. - - Lock_RTS; - Unlock_RTS; - - if not System.Restrictions.Abort_Allowed then - - -- If Abort is not allowed, reset the deferral level since it will - -- not get changed by the generated code. Keeping a default value - -- of one would prevent some operations (e.g. select or delay) to - -- proceed successfully. - - Self_ID.Deferral_Level := 0; - end if; - - if Global_Task_Debug_Event_Set then - Debug.Signal_Debug_Event (Debug.Debug_Event_Run, Self_ID); - end if; - - begin - -- We are separating the following portion of the code in order to - -- place the exception handlers in a different block. In this way, - -- we do not call Set_Jmpbuf_Address (which needs Self) before we - -- set Self in Enter_Task - - -- Call the task body procedure - - -- The task body is called with abort still deferred. That - -- eliminates a dangerous window, for which we had to patch-up in - -- Terminate_Task. - - -- During the expansion of the task body, we insert an RTS-call - -- to Abort_Undefer, at the first point where abort should be - -- allowed. - - Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg); - Initialization.Defer_Abort_Nestable (Self_ID); - - exception - -- We can't call Terminate_Task in the exception handlers below, - -- since there may be (e.g. in the case of GCC exception handling) - -- clean ups associated with the exception handler that need to - -- access task specific data. - - -- Defer abort so that this task can't be aborted while exiting - - when Standard'Abort_Signal => - Initialization.Defer_Abort_Nestable (Self_ID); - - -- Update the cause that motivated the task termination so that - -- the appropriate information is passed to the task termination - -- procedure. Task termination as a result of waiting on a - -- terminate alternative is a normal termination, although it is - -- implemented using the abort mechanisms. - - if Self_ID.Terminate_Alternative then - Cause := Normal; - - if Global_Task_Debug_Event_Set then - Debug.Signal_Debug_Event - (Debug.Debug_Event_Terminated, Self_ID); - end if; - else - Cause := Abnormal; - - if Global_Task_Debug_Event_Set then - Debug.Signal_Debug_Event - (Debug.Debug_Event_Abort_Terminated, Self_ID); - end if; - end if; - - when others => - -- ??? Using an E : others here causes CD2C11A to fail on Tru64 - - Initialization.Defer_Abort_Nestable (Self_ID); - - -- Perform the task specific exception tracing duty. We handle - -- these outputs here and not in the common notification routine - -- because we need access to tasking related data and we don't - -- want to drag dependencies against tasking related units in the - -- the common notification units. Additionally, no trace is ever - -- triggered from the common routine for the Unhandled_Raise case - -- in tasks, since an exception never appears unhandled in this - -- context because of this handler. - - if Exception_Trace = Unhandled_Raise then - Trace_Unhandled_Exception_In_Task (Self_ID); - end if; - - -- Update the cause that motivated the task termination so that - -- the appropriate information is passed to the task termination - -- procedure, as well as the associated Exception_Occurrence. - - Cause := Unhandled_Exception; - - Save_Occurrence (EO, SSL.Get_Current_Excep.all.all); - - if Global_Task_Debug_Event_Set then - Debug.Signal_Debug_Event - (Debug.Debug_Event_Exception_Terminated, Self_ID); - end if; - end; - - -- Look for a task termination handler. This code is for all tasks but - -- the environment task. The task termination code for the environment - -- task is executed by SSL.Task_Termination_Handler. - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - if Self_ID.Common.Specific_Handler /= null then - TH := Self_ID.Common.Specific_Handler; - - -- Independent tasks should not call the Fall_Back_Handler (of the - -- environment task), because they are implementation artifacts that - -- should be invisible to Ada programs. - - elsif Self_ID.Master_of_Task /= Independent_Task_Level then - - -- Look for a fall-back handler following the master relationship - -- for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back - -- handler applies only to the dependent tasks of the task". Hence, - -- if the terminating tasks (Self_ID) had a fall-back handler, it - -- would not apply to itself, so we start the search with the parent. - - Search_Fall_Back_Handler (Self_ID.Common.Parent); - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - -- Execute the task termination handler if we found it - - if TH /= null then - begin - TH.all (Cause, Self_ID, EO); - - exception - - -- RM-C.7.3 requires all exceptions raised here to be ignored - - when others => - null; - end; - end if; - - if System.Stack_Usage.Is_Enabled then - Compute_Result (Self_ID.Common.Analyzer); - Report_Result (Self_ID.Common.Analyzer); - end if; - - Terminate_Task (Self_ID); - end Task_Wrapper; - - -------------------- - -- Terminate_Task -- - -------------------- - - -- Before we allow the thread to exit, we must clean up. This is a delicate - -- job. We must wake up the task's master, who may immediately try to - -- deallocate the ATCB from the current task WHILE IT IS STILL EXECUTING. - - -- To avoid this, the parent task must be blocked up to the latest - -- statement executed. The trouble is that we have another step that we - -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD. - -- We have to postpone that until the end because compiler-generated code - -- is likely to try to access that data at just about any point. - - -- We can't call Destroy_TSD while we are holding any other locks, because - -- it locks Global_Task_Lock, and our deadlock prevention rules require - -- that to be the outermost lock. Our first "solution" was to just lock - -- Global_Task_Lock in addition to the other locks, and force the parent to - -- also lock this lock between its wakeup and its freeing of the ATCB. See - -- Complete_Task for the parent-side of the code that has the matching - -- calls to Task_Lock and Task_Unlock. That was not really a solution, - -- since the operation Task_Unlock continued to access the ATCB after - -- unlocking, after which the parent was observed to race ahead, deallocate - -- the ATCB, and then reallocate it to another task. The call to - -- Undefer_Abort in Task_Unlock by the "terminated" task was overwriting - -- the data of the new task that reused the ATCB. To solve this problem, we - -- introduced the new operation Final_Task_Unlock. - - procedure Terminate_Task (Self_ID : Task_Id) is - Environment_Task : constant Task_Id := STPO.Environment_Task; - Master_of_Task : Integer; - Deallocate : Boolean; - - begin - Debug.Task_Termination_Hook; - - -- Since GCC cannot allocate stack chunks efficiently without reordering - -- some of the allocations, we have to handle this unexpected situation - -- here. Normally we never have to call Vulnerable_Complete_Task here. - - if Self_ID.Common.Activator /= null then - Vulnerable_Complete_Task (Self_ID); - end if; - - Initialization.Task_Lock (Self_ID); - - if Single_Lock then - Lock_RTS; - end if; - - Master_of_Task := Self_ID.Master_of_Task; - - -- Check if the current task is an independent task If so, decrement - -- the Independent_Task_Count value. - - if Master_of_Task = Independent_Task_Level then - if Single_Lock then - Utilities.Independent_Task_Count := - Utilities.Independent_Task_Count - 1; - - else - Write_Lock (Environment_Task); - Utilities.Independent_Task_Count := - Utilities.Independent_Task_Count - 1; - Unlock (Environment_Task); - end if; - end if; - - -- Unprotect the guard page if needed - - Stack_Guard (Self_ID, False); - - Utilities.Make_Passive (Self_ID, Task_Completed => True); - Deallocate := Self_ID.Free_On_Termination; - - if Single_Lock then - Unlock_RTS; - end if; - - pragma Assert (Check_Exit (Self_ID)); - - SSL.Destroy_TSD (Self_ID.Common.Compiler_Data); - Initialization.Final_Task_Unlock (Self_ID); - - -- WARNING: past this point, this thread must assume that the ATCB has - -- been deallocated, and can't access it anymore (which is why we have - -- saved the Free_On_Termination flag in a temporary variable). - - if Deallocate then - Free_Task (Self_ID); - end if; - - if Master_of_Task > 0 then - STPO.Exit_Task; - end if; - end Terminate_Task; - - ---------------- - -- Terminated -- - ---------------- - - function Terminated (T : Task_Id) return Boolean is - Self_ID : constant Task_Id := STPO.Self; - Result : Boolean; - - begin - Initialization.Defer_Abort_Nestable (Self_ID); - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (T); - Result := T.Common.State = Terminated; - Unlock (T); - - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort_Nestable (Self_ID); - return Result; - end Terminated; - - ---------------------------------------- - -- Trace_Unhandled_Exception_In_Task -- - ---------------------------------------- - - procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is - procedure To_Stderr (S : String); - pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); - - use System.Soft_Links; - use System.Standard_Library; - - function To_Address is new - Ada.Unchecked_Conversion - (Task_Id, System.Task_Primitives.Task_Address); - - Excep : constant Exception_Occurrence_Access := - SSL.Get_Current_Excep.all; - - begin - -- This procedure is called by the task outermost handler in - -- Task_Wrapper below, so only once the task stack has been fully - -- unwound. The common notification routine has been called at the - -- raise point already. - - -- Lock to prevent unsynchronized output - - Initialization.Task_Lock (Self_Id); - To_Stderr ("task "); - - if Self_Id.Common.Task_Image_Len /= 0 then - To_Stderr - (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len)); - To_Stderr ("_"); - end if; - - To_Stderr (System.Address_Image (To_Address (Self_Id))); - To_Stderr (" terminated by unhandled exception"); - To_Stderr ((1 => ASCII.LF)); - To_Stderr (Exception_Information (Excep.all)); - Initialization.Task_Unlock (Self_Id); - end Trace_Unhandled_Exception_In_Task; - - ------------------------------------ - -- Vulnerable_Complete_Activation -- - ------------------------------------ - - -- As in several other places, the locks of the activator and activated - -- task are both locked here. This follows our deadlock prevention lock - -- ordering policy, since the activated task must be created after the - -- activator. - - procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is - Activator : constant Task_Id := Self_ID.Common.Activator; - - begin - pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C')); - - Write_Lock (Activator); - Write_Lock (Self_ID); - - pragma Assert (Self_ID.Common.Activator /= null); - - -- Remove dangling reference to Activator, since a task may outlive its - -- activator. - - Self_ID.Common.Activator := null; - - -- Wake up the activator, if it is waiting for a chain of tasks to - -- activate, and we are the last in the chain to complete activation. - - if Activator.Common.State = Activator_Sleep then - Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1; - - if Activator.Common.Wait_Count = 0 then - Wakeup (Activator, Activator_Sleep); - end if; - end if; - - -- The activator raises a Tasking_Error if any task it is activating - -- is completed before the activation is done. However, if the reason - -- for the task completion is an abort, we do not raise an exception. - -- See RM 9.2(5). - - if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then - Activator.Common.Activation_Failed := True; - end if; - - Unlock (Self_ID); - Unlock (Activator); - - -- After the activation, active priority should be the same as base - -- priority. We must unlock the Activator first, though, since it - -- should not wait if we have lower priority. - - if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then - Write_Lock (Self_ID); - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - Unlock (Self_ID); - end if; - end Vulnerable_Complete_Activation; - - -------------------------------- - -- Vulnerable_Complete_Master -- - -------------------------------- - - procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is - C : Task_Id; - P : Task_Id; - CM : constant Master_Level := Self_ID.Master_Within; - T : aliased Task_Id; - - To_Be_Freed : Task_Id; - -- This is a list of ATCBs to be freed, after we have released all RTS - -- locks. This is necessary because of the locking order rules, since - -- the storage manager uses Global_Task_Lock. - - pragma Warnings (Off); - function Check_Unactivated_Tasks return Boolean; - pragma Warnings (On); - -- Temporary error-checking code below. This is part of the checks - -- added in the new run time. Call it only inside a pragma Assert. - - ----------------------------- - -- Check_Unactivated_Tasks -- - ----------------------------- - - function Check_Unactivated_Tasks return Boolean is - begin - if not Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - C := All_Tasks_List; - while C /= null loop - if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then - return False; - end if; - - if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then - Write_Lock (C); - - if C.Common.State = Unactivated then - return False; - end if; - - Unlock (C); - end if; - - C := C.Common.All_Tasks_Link; - end loop; - - Unlock (Self_ID); - - if not Single_Lock then - Unlock_RTS; - end if; - - return True; - end Check_Unactivated_Tasks; - - -- Start of processing for Vulnerable_Complete_Master - - begin - pragma Debug - (Debug.Trace (Self_ID, "V_Complete_Master(" & CM'Img & ")", 'C')); - - pragma Assert (Self_ID.Common.Wait_Count = 0); - pragma Assert - (Self_ID.Deferral_Level > 0 - or else not System.Restrictions.Abort_Allowed); - - -- Count how many active dependent tasks this master currently has, and - -- record this in Wait_Count. - - -- This count should start at zero, since it is initialized to zero for - -- new tasks, and the task should not exit the sleep-loops that use this - -- count until the count reaches zero. - - -- While we're counting, if we run across any unactivated tasks that - -- belong to this master, we summarily terminate them as required by - -- RM-9.2(6). - - Lock_RTS; - Write_Lock (Self_ID); - - C := All_Tasks_List; - while C /= null loop - - -- Terminate unactivated (never-to-be activated) tasks - - if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then - - -- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task - -- = CM. The only case where C is pending activation by this - -- task, but the master of C is not CM is in Ada 2005, when C is - -- part of a return object of a build-in-place function. - - pragma Assert (C.Common.State = Unactivated); - - Write_Lock (C); - C.Common.Activator := null; - C.Common.State := Terminated; - C.Callable := False; - Utilities.Cancel_Queued_Entry_Calls (C); - Unlock (C); - end if; - - -- Count it if directly dependent on this master - - if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then - Write_Lock (C); - - if C.Awake_Count /= 0 then - Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; - end if; - - Unlock (C); - end if; - - C := C.Common.All_Tasks_Link; - end loop; - - Self_ID.Common.State := Master_Completion_Sleep; - Unlock (Self_ID); - - if not Single_Lock then - Unlock_RTS; - end if; - - -- Wait until dependent tasks are all terminated or ready to terminate. - -- While waiting, the task may be awakened if the task's priority needs - -- changing, or this master is aborted. In the latter case, we abort the - -- dependents, and resume waiting until Wait_Count goes to zero. - - Write_Lock (Self_ID); - - loop - exit when Self_ID.Common.Wait_Count = 0; - - -- Here is a difference as compared to Complete_Master - - if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - and then not Self_ID.Dependents_Aborted - then - if Single_Lock then - Abort_Dependents (Self_ID); - else - Unlock (Self_ID); - Lock_RTS; - Abort_Dependents (Self_ID); - Unlock_RTS; - Write_Lock (Self_ID); - end if; - else - pragma Debug - (Debug.Trace (Self_ID, "master_completion_sleep", 'C')); - Sleep (Self_ID, Master_Completion_Sleep); - end if; - end loop; - - Self_ID.Common.State := Runnable; - Unlock (Self_ID); - - -- Dependents are all terminated or on terminate alternatives. Now, - -- force those on terminate alternatives to terminate, by aborting them. - - pragma Assert (Check_Unactivated_Tasks); - - if Self_ID.Alive_Count > 1 then - -- ??? - -- Consider finding a way to skip the following extra steps if there - -- are no dependents with terminate alternatives. This could be done - -- by adding another count to the ATCB, similar to Awake_Count, but - -- keeping track of tasks that are on terminate alternatives. - - pragma Assert (Self_ID.Common.Wait_Count = 0); - - -- Force any remaining dependents to terminate by aborting them - - if not Single_Lock then - Lock_RTS; - end if; - - Abort_Dependents (Self_ID); - - -- Above, when we "abort" the dependents we are simply using this - -- operation for convenience. We are not required to support the full - -- abort-statement semantics; in particular, we are not required to - -- immediately cancel any queued or in-service entry calls. That is - -- good, because if we tried to cancel a call we would need to lock - -- the caller, in order to wake the caller up. Our anti-deadlock - -- rules prevent us from doing that without releasing the locks on C - -- and Self_ID. Releasing and retaking those locks would be wasteful - -- at best, and should not be considered further without more - -- detailed analysis of potential concurrent accesses to the ATCBs - -- of C and Self_ID. - - -- Count how many "alive" dependent tasks this master currently has, - -- and record this in Wait_Count. This count should start at zero, - -- since it is initialized to zero for new tasks, and the task should - -- not exit the sleep-loops that use this count until the count - -- reaches zero. - - pragma Assert (Self_ID.Common.Wait_Count = 0); - - Write_Lock (Self_ID); - - C := All_Tasks_List; - while C /= null loop - if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then - Write_Lock (C); - - pragma Assert (C.Awake_Count = 0); - - if C.Alive_Count > 0 then - pragma Assert (C.Terminate_Alternative); - Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; - end if; - - Unlock (C); - end if; - - C := C.Common.All_Tasks_Link; - end loop; - - Self_ID.Common.State := Master_Phase_2_Sleep; - Unlock (Self_ID); - - if not Single_Lock then - Unlock_RTS; - end if; - - -- Wait for all counted tasks to finish terminating themselves - - Write_Lock (Self_ID); - - loop - exit when Self_ID.Common.Wait_Count = 0; - Sleep (Self_ID, Master_Phase_2_Sleep); - end loop; - - Self_ID.Common.State := Runnable; - Unlock (Self_ID); - end if; - - -- We don't wake up for abort here. We are already terminating just as - -- fast as we can, so there is no point. - - -- Remove terminated tasks from the list of Self_ID's dependents, but - -- don't free their ATCBs yet, because of lock order restrictions, which - -- don't allow us to call "free" or "malloc" while holding any other - -- locks. Instead, we put those ATCBs to be freed onto a temporary list, - -- called To_Be_Freed. - - if not Single_Lock then - Lock_RTS; - end if; - - C := All_Tasks_List; - P := null; - while C /= null loop - - -- If Free_On_Termination is set, do nothing here, and let the - -- task free itself if not already done, otherwise we risk a race - -- condition where Vulnerable_Free_Task is called in the loop below, - -- while the task calls Free_Task itself, in Terminate_Task. - - if C.Common.Parent = Self_ID - and then C.Master_of_Task >= CM - and then not C.Free_On_Termination - then - if P /= null then - P.Common.All_Tasks_Link := C.Common.All_Tasks_Link; - else - All_Tasks_List := C.Common.All_Tasks_Link; - end if; - - T := C.Common.All_Tasks_Link; - C.Common.All_Tasks_Link := To_Be_Freed; - To_Be_Freed := C; - C := T; - - else - P := C; - C := C.Common.All_Tasks_Link; - end if; - end loop; - - Unlock_RTS; - - -- Free all the ATCBs on the list To_Be_Freed - - -- The ATCBs in the list are no longer in All_Tasks_List, and after - -- any interrupt entries are detached from them they should no longer - -- be referenced. - - -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to - -- avoid a race between a terminating task and its parent. The parent - -- might try to deallocate the ACTB out from underneath the exiting - -- task. Note that Free will also lock Global_Task_Lock, but that is - -- OK, since this is the *one* lock for which we have a mechanism to - -- support nested locking. See Task_Wrapper and its finalizer for more - -- explanation. - - -- ??? - -- The check "T.Common.Parent /= null ..." below is to prevent dangling - -- references to terminated library-level tasks, which could otherwise - -- occur during finalization of library-level objects. A better solution - -- might be to hook task objects into the finalization chain and - -- deallocate the ATCB when the task object is deallocated. However, - -- this change is not likely to gain anything significant, since all - -- this storage should be recovered en-masse when the process exits. - - while To_Be_Freed /= null loop - T := To_Be_Freed; - To_Be_Freed := T.Common.All_Tasks_Link; - - -- ??? On SGI there is currently no Interrupt_Manager, that's why we - -- need to check if the Interrupt_Manager_ID is null. - - if T.Interrupt_Entry and then Interrupt_Manager_ID /= null then - declare - Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1; - -- Corresponds to the entry index of System.Interrupts. - -- Interrupt_Manager.Detach_Interrupt_Entries. Be sure - -- to update this value when changing Interrupt_Manager specs. - - type Param_Type is access all Task_Id; - - Param : aliased Param_Type := T'Access; - - begin - System.Tasking.Rendezvous.Call_Simple - (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index, - Param'Address); - end; - end if; - - if (T.Common.Parent /= null - and then T.Common.Parent.Common.Parent /= null) - or else T.Master_of_Task > Library_Task_Level - then - Initialization.Task_Lock (Self_ID); - - -- If Sec_Stack_Addr is not null, it means that Destroy_TSD - -- has not been called yet (case of an unactivated task). - - if T.Common.Compiler_Data.Sec_Stack_Addr /= Null_Address then - SSL.Destroy_TSD (T.Common.Compiler_Data); - end if; - - Vulnerable_Free_Task (T); - Initialization.Task_Unlock (Self_ID); - end if; - end loop; - - -- It might seem nice to let the terminated task deallocate its own - -- ATCB. That would not cover the case of unactivated tasks. It also - -- would force us to keep the underlying thread around past termination, - -- since references to the ATCB are possible past termination. - - -- Currently, we get rid of the thread as soon as the task terminates, - -- and let the parent recover the ATCB later. - - -- Some day, if we want to recover the ATCB earlier, at task - -- termination, we could consider using "fat task IDs", that include the - -- serial number with the ATCB pointer, to catch references to tasks - -- that no longer have ATCBs. It is not clear how much this would gain, - -- since the user-level task object would still be occupying storage. - - -- Make next master level up active. We don't need to lock the ATCB, - -- since the value is only updated by each task for itself. - - Self_ID.Master_Within := CM - 1; - - Debug.Master_Completed_Hook (Self_ID, CM); - end Vulnerable_Complete_Master; - - ------------------------------ - -- Vulnerable_Complete_Task -- - ------------------------------ - - -- Complete the calling task - - -- This procedure must be called with abort deferred. It should only be - -- called by Complete_Task and Finalize_Global_Tasks (for the environment - -- task). - - -- The effect is similar to that of Complete_Master. Differences include - -- the closing of entries here, and computation of the number of active - -- dependent tasks in Complete_Master. - - -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation, - -- because that does its own locking, and because we do not need the lock - -- to test Self_ID.Common.Activator. That value should only be read and - -- modified by Self. - - procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is - begin - pragma Assert - (Self_ID.Deferral_Level > 0 - or else not System.Restrictions.Abort_Allowed); - pragma Assert (Self_ID = Self); - pragma Assert - (Self_ID.Master_Within in - Self_ID.Master_of_Task + 1 .. Self_ID.Master_of_Task + 3); - pragma Assert (Self_ID.Common.Wait_Count = 0); - pragma Assert (Self_ID.Open_Accepts = null); - pragma Assert (Self_ID.ATC_Nesting_Level = 1); - - pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C')); - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - Self_ID.Callable := False; - - -- In theory, Self should have no pending entry calls left on its - -- call-stack. Each async. select statement should clean its own call, - -- and blocking entry calls should defer abort until the calls are - -- cancelled, then clean up. - - Utilities.Cancel_Queued_Entry_Calls (Self_ID); - Unlock (Self_ID); - - if Self_ID.Common.Activator /= null then - Vulnerable_Complete_Activation (Self_ID); - end if; - - if Single_Lock then - Unlock_RTS; - end if; - - -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 we may have - -- dependent tasks for which we need to wait. Otherwise we just exit. - - if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then - Vulnerable_Complete_Master (Self_ID); - end if; - end Vulnerable_Complete_Task; - - -------------------------- - -- Vulnerable_Free_Task -- - -------------------------- - - -- Recover all runtime system storage associated with the task T. This - -- should only be called after T has terminated and will no longer be - -- referenced. - - -- For tasks created by an allocator that fails, due to an exception, it - -- is called from Expunge_Unactivated_Tasks. - - -- For tasks created by elaboration of task object declarations it is - -- called from the finalization code of the Task_Wrapper procedure. - - procedure Vulnerable_Free_Task (T : Task_Id) is - begin - pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T)); - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (T); - Initialization.Finalize_Attributes (T); - Unlock (T); - - if Single_Lock then - Unlock_RTS; - end if; - - System.Task_Primitives.Operations.Finalize_TCB (T); - end Vulnerable_Free_Task; - --- Package elaboration code - -begin - -- Establish the Adafinal softlink - - -- This is not done inside the central RTS initialization routine - -- to avoid with'ing this package from System.Tasking.Initialization. - - SSL.Adafinal := Finalize_Global_Tasks'Access; - - -- Establish soft links for subprograms that manipulate master_id's. - -- This cannot be done when the RTS is initialized, because of various - -- elaboration constraints. - - SSL.Current_Master := Stages.Current_Master'Access; - SSL.Enter_Master := Stages.Enter_Master'Access; - SSL.Complete_Master := Stages.Complete_Master'Access; -end System.Tasking.Stages; diff --git a/gcc/ada/s-tassta.ads b/gcc/ada/s-tassta.ads deleted file mode 100644 index 1717d447eb6..00000000000 --- a/gcc/ada/s-tassta.ads +++ /dev/null @@ -1,305 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . S T A G E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - --- This package represents the high level tasking interface used by the --- compiler to expand Ada 95 tasking constructs into simpler run time calls --- (aka GNARLI, GNU Ada Run-time Library Interface) - --- Note: Only the compiler is allowed to use this interface, by generating --- direct calls to it, via Rtsfind. - --- Any changes to this interface may require corresponding compiler changes --- in exp_ch9.adb and possibly exp_ch7.adb - -with System.Task_Info; -with System.Parameters; - -with Ada.Real_Time; - -package System.Tasking.Stages is - pragma Elaborate_Body; - - -- The compiler will expand in the GNAT tree the following construct: - - -- task type T (Discr : Integer); - - -- task body T is - -- ...declarations, possibly some controlled... - -- begin - -- ...B...; - -- end T; - - -- T1 : T (1); - - -- as follows: - - -- enter_master.all; - - -- _chain : aliased activation_chain; - -- activation_chainIP (_chain); - - -- task type t (discr : integer); - -- tE : aliased boolean := false; - -- tZ : size_type := unspecified_size; - -- type tV (discr : integer) is limited record - -- _task_id : task_id; - -- end record; - -- procedure tB (_task : access tV); - -- freeze tV [ - -- procedure tVIP (_init : in out tV; _master : master_id; - -- _chain : in out activation_chain; _task_id : in task_image_type; - -- discr : integer) is - -- begin - -- _init.discr := discr; - -- _init._task_id := null; - -- create_task (unspecified_priority, tZ, - -- unspecified_task_info, unspecified_cpu, - -- ada__real_time__time_span_zero, 0, _master, - -- task_procedure_access!(tB'address), _init'address, - -- tE'unchecked_access, _chain, _task_id, _init._task_id); - -- return; - -- end tVIP; - -- ] - - -- procedure tB (_task : access tV) is - -- discr : integer renames _task.discr; - - -- procedure _clean is - -- begin - -- abort_defer.all; - -- complete_task; - -- finalize_list (F14b); - -- abort_undefer.all; - -- return; - -- end _clean; - -- begin - -- abort_undefer.all; - -- ...declarations... - -- complete_activation; - -- ...B...; - -- return; - -- at end - -- _clean; - -- end tB; - - -- tE := true; - -- t1 : t (1); - -- _master : constant master_id := current_master.all; - -- t1S : task_image_type := new string'"t1"; - -- task_image_typeIP (t1, _master, _chain, t1S, 1); - - -- activate_tasks (_chain'unchecked_access); - - procedure Abort_Tasks (Tasks : Task_List); - -- Compiler interface only. Do not call from within the RTS. Initiate - -- abort, however, the actual abort is done by abortee by means of - -- Abort_Handler and Abort_Undefer - -- - -- source code: - -- Abort T1, T2; - -- code expansion: - -- abort_tasks (task_list'(t1._task_id, t2._task_id)); - - procedure Activate_Tasks (Chain_Access : Activation_Chain_Access); - -- Compiler interface only. Do not call from within the RTS. - -- This must be called by the creator of a chain of one or more new tasks, - -- to activate them. The chain is a linked list that up to this point is - -- only known to the task that created them, though the individual tasks - -- are already in the All_Tasks_List. - -- - -- The compiler builds the chain in LIFO order (as a stack). Another - -- version of this procedure had code to reverse the chain, so as to - -- activate the tasks in the order of declaration. This might be nice, but - -- it is not needed if priority-based scheduling is supported, since all - -- the activated tasks synchronize on the activators lock before they - -- start activating and so they should start activating in priority order. - -- ??? Actually, the body of this package DOES reverse the chain, so I - -- don't understand the above comment. - - procedure Complete_Activation; - -- Compiler interface only. Do not call from within the RTS. - -- This should be called from the task body at the end of - -- the elaboration code for its declarative part. - -- Decrement the count of tasks to be activated by the activator and - -- wake it up so it can check to see if all tasks have been activated. - -- Except for the environment task, which should never call this procedure, - -- T.Activator should only be null iff T has completed activation. - - procedure Complete_Master; - -- Compiler interface only. Do not call from within the RTS. This must - -- be called on exit from any master where Enter_Master was called. - -- Assume abort is deferred at this point. - - procedure Complete_Task; - -- Compiler interface only. Do not call from within the RTS. - -- This should be called from an implicit at-end handler - -- associated with the task body, when it completes. - -- From this point, the current task will become not callable. - -- If the current task have not completed activation, this should be done - -- now in order to wake up the activator (the environment task). - - procedure Create_Task - (Priority : Integer; - Size : System.Parameters.Size_Type; - Secondary_Stack_Size : System.Parameters.Size_Type; - Task_Info : System.Task_Info.Task_Info_Type; - CPU : Integer; - Relative_Deadline : Ada.Real_Time.Time_Span; - Domain : Dispatching_Domain_Access; - Num_Entries : Task_Entry_Index; - Master : Master_Level; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Chain : in out Activation_Chain; - Task_Image : String; - Created_Task : out Task_Id); - -- Compiler interface only. Do not call from within the RTS. - -- This must be called to create a new task. - -- - -- Priority is the task's priority (assumed to be in range of type - -- System.Any_Priority) - -- Size is the stack size of the task to create - -- Secondary_Stack_Size is the secondary stack size of the task to create - -- Task_Info is the task info associated with the created task, or - -- Unspecified_Task_Info if none. - -- CPU is the task affinity. Passed as an Integer because the undefined - -- value is not in the range of CPU_Range. Static range checks are - -- performed when analyzing the pragma, and dynamic ones are performed - -- before setting the affinity at run time. - -- Relative_Deadline is the relative deadline associated with the created - -- task by means of a pragma Relative_Deadline, or 0.0 if none. - -- Domain is the dispatching domain associated with the created task by - -- means of a Dispatching_Domain pragma or aspect, or null if none. - -- State is the compiler generated task's procedure body - -- Discriminants is a pointer to a limited record whose discriminants - -- are those of the task to create. This parameter should be passed as - -- the single argument to State. - -- Elaborated is a pointer to a Boolean that must be set to true on exit - -- if the task could be successfully elaborated. - -- Chain is a linked list of task that needs to be created. On exit, - -- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID - -- will be Created_Task (e.g the created task will be linked at the front - -- of Chain). - -- Task_Image is a string created by the compiler that the - -- run time can store to ease the debugging and the - -- Ada.Task_Identification facility. - -- Created_Task is the resulting task. - -- - -- This procedure can raise Storage_Error if the task creation failed. - - function Current_Master return Master_Level; - -- Compiler interface only. - -- This is called to obtain the current master nesting level. - - procedure Enter_Master; - -- Compiler interface only. Do not call from within the RTS. - -- This must be called on entry to any "master" where a task, - -- or access type designating objects containing tasks, may be - -- declared. - - procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain); - -- Compiler interface only. Do not call from within the RTS. - -- This must be called by the compiler-generated code for an allocator if - -- the allocated object contains tasks, if the allocator exits without - -- calling Activate_Tasks for a given activation chains, as can happen if - -- an exception occurs during initialization of the object. - -- - -- This should be called ONLY for tasks created via an allocator. Recovery - -- of storage for unactivated local task declarations is done by - -- Complete_Master and Complete_Task. - -- - -- We remove each task from Chain and All_Tasks_List before we free the - -- storage of its ATCB. - -- - -- In other places where we recover the storage of unactivated tasks, we - -- need to clean out the entry queues, but here that should not be - -- necessary, since these tasks should not have been visible to any other - -- tasks, and so no task should be able to queue a call on their entries. - -- - -- Just in case somebody misuses this subprogram, there is a check to - -- verify this condition. - - procedure Finalize_Global_Tasks; - -- This should be called to complete the execution of the environment task - -- and shut down the tasking runtime system. It is the equivalent of - -- Complete_Task, but for the environment task. - -- - -- The environment task must first call Complete_Master, to wait for user - -- tasks that depend on library-level packages to terminate. It then calls - -- Abort_Dependents to abort the "independent" library-level server tasks - -- that are created implicitly by the RTS packages (signal and timer server - -- tasks), and then waits for them to terminate. Then, it calls - -- Vulnerable_Complete_Task. - -- - -- It currently also executes the global finalization list, and then resets - -- the "soft links". - - procedure Free_Task (T : Task_Id); - -- Recover all runtime system storage associated with the task T, but only - -- if T has terminated. Do nothing in the other case. It is called from - -- Unchecked_Deallocation, for objects that are or contain tasks. - - procedure Move_Activation_Chain - (From, To : Activation_Chain_Access; - New_Master : Master_ID); - -- Compiler interface only. Do not call from within the RTS. - -- Move all tasks on From list to To list, and change their Master_of_Task - -- to be New_Master. This is used to implement build-in-place function - -- returns. Tasks that are part of the return object are initially placed - -- on an activation chain local to the return statement, and their master - -- is the return statement, in case the return statement is left - -- prematurely (due to raising an exception, being aborted, or a goto or - -- exit statement). Once the return statement has completed successfully, - -- Move_Activation_Chain is called to move them to the caller's activation - -- chain, and change their master to the one passed in by the caller. If - -- that doesn't happen, they will never be activated, and will become - -- terminated on leaving the return statement. - - function Terminated (T : Task_Id) return Boolean; - -- This is called by the compiler to implement the 'Terminated attribute. - -- Though is not required to be so by the ARM, we choose to synchronize - -- with the task's ATCB, so that this is more useful for polling the state - -- of a task, and so that it becomes an abort completion point for the - -- calling task (via Undefer_Abort). - -- - -- source code: - -- T1'Terminated - -- - -- code expansion: - -- terminated (t1._task_id) - - procedure Terminate_Task (Self_ID : Task_Id); - -- Terminate the calling task. - -- This should only be called by the Task_Wrapper procedure, and to - -- deallocate storage associate with foreign tasks. - -end System.Tasking.Stages; diff --git a/gcc/ada/s-tasuti.adb b/gcc/ada/s-tasuti.adb deleted file mode 100644 index 1a7e8cf9f10..00000000000 --- a/gcc/ada/s-tasuti.adb +++ /dev/null @@ -1,491 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . U T I L I T I E 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 package provides RTS Internal Declarations - --- These declarations are not part of the GNARLI - -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.Tasking.Debug; -with System.Task_Primitives.Operations; -with System.Tasking.Initialization; -with System.Tasking.Queuing; -with System.Parameters; - -package body System.Tasking.Utilities is - - package STPO renames System.Task_Primitives.Operations; - - use Parameters; - use Tasking.Debug; - use Task_Primitives; - use Task_Primitives.Operations; - - -------------------- - -- Abort_One_Task -- - -------------------- - - -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but: - -- (1) caller should be holding no locks except RTS_Lock when Single_Lock - -- (2) may be called for tasks that have not yet been activated - -- (3) always aborts whole task - - procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id) is - begin - Write_Lock (T); - - if T.Common.State = Unactivated then - T.Common.Activator := null; - T.Common.State := Terminated; - T.Callable := False; - Cancel_Queued_Entry_Calls (T); - - elsif T.Common.State /= Terminated then - Initialization.Locked_Abort_To_Level (Self_ID, T, 0); - end if; - - Unlock (T); - end Abort_One_Task; - - ----------------- - -- Abort_Tasks -- - ----------------- - - -- This must be called to implement the abort statement. - -- Much of the actual work of the abort is done by the abortee, - -- via the Abort_Handler signal handler, and propagation of the - -- Abort_Signal special exception. - - procedure Abort_Tasks (Tasks : Task_List) is - Self_Id : constant Task_Id := STPO.Self; - C : Task_Id; - P : Task_Id; - - begin - -- If pragma Detect_Blocking is active then Program_Error must be - -- raised if this potentially blocking operation is called from a - -- protected action. - - if System.Tasking.Detect_Blocking - and then Self_Id.Common.Protected_Action_Nesting > 0 - then - raise Program_Error with "potentially blocking operation"; - end if; - - Initialization.Defer_Abort_Nestable (Self_Id); - - -- ????? - -- Really should not be nested deferral here. - -- Patch for code generation error that defers abort before - -- evaluating parameters of an entry call (at least, timed entry - -- calls), and so may propagate an exception that causes abort - -- to remain undeferred indefinitely. See C97404B. When all - -- such bugs are fixed, this patch can be removed. - - Lock_RTS; - - for J in Tasks'Range loop - C := Tasks (J); - Abort_One_Task (Self_Id, C); - end loop; - - C := All_Tasks_List; - - while C /= null loop - if C.Pending_ATC_Level > 0 then - P := C.Common.Parent; - - while P /= null loop - if P.Pending_ATC_Level = 0 then - Abort_One_Task (Self_Id, C); - exit; - end if; - - P := P.Common.Parent; - end loop; - end if; - - C := C.Common.All_Tasks_Link; - end loop; - - Unlock_RTS; - Initialization.Undefer_Abort_Nestable (Self_Id); - end Abort_Tasks; - - ------------------------------- - -- Cancel_Queued_Entry_Calls -- - ------------------------------- - - -- This should only be called by T, unless T is a terminated previously - -- unactivated task. - - procedure Cancel_Queued_Entry_Calls (T : Task_Id) is - Next_Entry_Call : Entry_Call_Link; - Entry_Call : Entry_Call_Link; - Self_Id : constant Task_Id := STPO.Self; - - Caller : Task_Id; - pragma Unreferenced (Caller); - -- Should this be removed ??? - - Level : Integer; - pragma Unreferenced (Level); - -- Should this be removed ??? - - begin - pragma Assert (T = Self or else T.Common.State = Terminated); - - for J in 1 .. T.Entry_Num loop - Queuing.Dequeue_Head (T.Entry_Queues (J), Entry_Call); - - while Entry_Call /= null loop - - -- Leave Entry_Call.Done = False, since this is cancelled - - Caller := Entry_Call.Self; - Entry_Call.Exception_To_Raise := Tasking_Error'Identity; - Queuing.Dequeue_Head (T.Entry_Queues (J), Next_Entry_Call); - Level := Entry_Call.Level - 1; - Unlock (T); - Write_Lock (Entry_Call.Self); - Initialization.Wakeup_Entry_Caller - (Self_Id, Entry_Call, Cancelled); - Unlock (Entry_Call.Self); - Write_Lock (T); - Entry_Call.State := Done; - Entry_Call := Next_Entry_Call; - end loop; - end loop; - end Cancel_Queued_Entry_Calls; - - ------------------------ - -- Exit_One_ATC_Level -- - ------------------------ - - -- Call only with abort deferred and holding lock of Self_Id. - -- This is a bit of common code for all entry calls. - -- The effect is to exit one level of ATC nesting. - - -- If we have reached the desired ATC nesting level, reset the - -- requested level to effective infinity, to allow further calls. - -- In any case, reset Self_Id.Aborting, to allow re-raising of - -- Abort_Signal. - - procedure Exit_One_ATC_Level (Self_ID : Task_Id) is - begin - Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1; - - pragma Debug - (Debug.Trace (Self_ID, "EOAL: exited to ATC level: " & - ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); - - pragma Assert (Self_ID.ATC_Nesting_Level >= 1); - - if Self_ID.Pending_ATC_Level < ATC_Level_Infinity then - if Self_ID.Pending_ATC_Level = Self_ID.ATC_Nesting_Level then - Self_ID.Pending_ATC_Level := ATC_Level_Infinity; - Self_ID.Aborting := False; - else - -- Force the next Undefer_Abort to re-raise Abort_Signal - - pragma Assert - (Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level); - - if Self_ID.Aborting then - Self_ID.ATC_Hack := True; - Self_ID.Pending_Action := True; - end if; - end if; - end if; - end Exit_One_ATC_Level; - - ---------------------- - -- Make_Independent -- - ---------------------- - - function Make_Independent return Boolean is - Self_Id : constant Task_Id := STPO.Self; - Environment_Task : constant Task_Id := STPO.Environment_Task; - Parent : constant Task_Id := Self_Id.Common.Parent; - - begin - if Self_Id.Known_Tasks_Index /= -1 then - Known_Tasks (Self_Id.Known_Tasks_Index) := null; - end if; - - Initialization.Defer_Abort (Self_Id); - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Environment_Task); - Write_Lock (Self_Id); - - -- The run time assumes that the parent of an independent task is the - -- environment task. - - pragma Assert (Parent = Environment_Task); - - Self_Id.Master_of_Task := Independent_Task_Level; - - -- Update Independent_Task_Count that is needed for the GLADE - -- termination rule. See also pending update in - -- System.Tasking.Stages.Check_Independent - - Independent_Task_Count := Independent_Task_Count + 1; - - -- This should be called before the task reaches its "begin" (see spec), - -- which ensures that the environment task cannot race ahead and be - -- already waiting for children to complete. - - Unlock (Self_Id); - pragma Assert (Environment_Task.Common.State /= Master_Completion_Sleep); - - Unlock (Environment_Task); - - if Single_Lock then - Unlock_RTS; - end if; - - Initialization.Undefer_Abort (Self_Id); - - -- Return True. Actually the return value is junk, since we expect it - -- always to be ignored (see spec), but we have to return something! - - return True; - end Make_Independent; - - ------------------ - -- Make_Passive -- - ------------------ - - procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean) is - C : Task_Id := Self_ID; - P : Task_Id := C.Common.Parent; - - Master_Completion_Phase : Integer; - - begin - if P /= null then - Write_Lock (P); - end if; - - Write_Lock (C); - - if Task_Completed then - Self_ID.Common.State := Terminated; - - if Self_ID.Awake_Count = 0 then - - -- We are completing via a terminate alternative. - -- Our parent should wait in Phase 2 of Complete_Master. - - Master_Completion_Phase := 2; - - pragma Assert (Task_Completed); - pragma Assert (Self_ID.Terminate_Alternative); - pragma Assert (Self_ID.Alive_Count = 1); - - else - -- We are NOT on a terminate alternative. - -- Our parent should wait in Phase 1 of Complete_Master. - - Master_Completion_Phase := 1; - pragma Assert (Self_ID.Awake_Count >= 1); - end if; - - -- We are accepting with a terminate alternative - - else - if Self_ID.Open_Accepts = null then - - -- Somebody started a rendezvous while we had our lock open. - -- Skip the terminate alternative. - - Unlock (C); - - if P /= null then - Unlock (P); - end if; - - return; - end if; - - Self_ID.Terminate_Alternative := True; - Master_Completion_Phase := 0; - - pragma Assert (Self_ID.Terminate_Alternative); - pragma Assert (Self_ID.Awake_Count >= 1); - end if; - - if Master_Completion_Phase = 2 then - - -- Since our Awake_Count is zero but our Alive_Count - -- is nonzero, we have been accepting with a terminate - -- alternative, and we now have been told to terminate - -- by a completed master (in some ancestor task) that - -- is waiting (with zero Awake_Count) in Phase 2 of - -- Complete_Master. - - pragma Debug (Debug.Trace (Self_ID, "Make_Passive: Phase 2", 'M')); - - pragma Assert (P /= null); - - C.Alive_Count := C.Alive_Count - 1; - - if C.Alive_Count > 0 then - Unlock (C); - Unlock (P); - return; - end if; - - -- C's count just went to zero, indicating that - -- all of C's dependents are terminated. - -- C has a parent, P. - - loop - -- C's count just went to zero, indicating that all of C's - -- dependents are terminated. C has a parent, P. Notify P that - -- C and its dependents have all terminated. - - P.Alive_Count := P.Alive_Count - 1; - exit when P.Alive_Count > 0; - Unlock (C); - Unlock (P); - C := P; - P := C.Common.Parent; - - -- Environment task cannot have terminated yet - - pragma Assert (P /= null); - - Write_Lock (P); - Write_Lock (C); - end loop; - - if P.Common.State = Master_Phase_2_Sleep - and then C.Master_of_Task = P.Master_Within - then - pragma Assert (P.Common.Wait_Count > 0); - P.Common.Wait_Count := P.Common.Wait_Count - 1; - - if P.Common.Wait_Count = 0 then - Wakeup (P, Master_Phase_2_Sleep); - end if; - end if; - - Unlock (C); - Unlock (P); - return; - end if; - - -- We are terminating in Phase 1 or Complete_Master, - -- or are accepting on a terminate alternative. - - C.Awake_Count := C.Awake_Count - 1; - - if Task_Completed then - C.Alive_Count := C.Alive_Count - 1; - end if; - - if C.Awake_Count > 0 or else P = null then - Unlock (C); - - if P /= null then - Unlock (P); - end if; - - return; - end if; - - -- C's count just went to zero, indicating that all of C's - -- dependents are terminated or accepting with terminate alt. - -- C has a parent, P. - - loop - -- Notify P that C has gone passive - - if P.Awake_Count > 0 then - P.Awake_Count := P.Awake_Count - 1; - end if; - - if Task_Completed and then C.Alive_Count = 0 then - P.Alive_Count := P.Alive_Count - 1; - end if; - - exit when P.Awake_Count > 0; - Unlock (C); - Unlock (P); - C := P; - P := C.Common.Parent; - - if P = null then - return; - end if; - - Write_Lock (P); - Write_Lock (C); - end loop; - - -- P has non-passive dependents - - if P.Common.State = Master_Completion_Sleep - and then C.Master_of_Task = P.Master_Within - then - pragma Debug - (Debug.Trace - (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M')); - - -- If parent is in Master_Completion_Sleep, it cannot be on a - -- terminate alternative, hence it cannot have Wait_Count of zero. - - pragma Assert (P.Common.Wait_Count > 0); - P.Common.Wait_Count := P.Common.Wait_Count - 1; - - if P.Common.Wait_Count = 0 then - Wakeup (P, Master_Completion_Sleep); - end if; - - else - pragma Debug - (Debug.Trace (Self_ID, "Make_Passive: Phase 1, parent awake", 'M')); - null; - end if; - - Unlock (C); - Unlock (P); - end Make_Passive; - -end System.Tasking.Utilities; diff --git a/gcc/ada/s-tasuti.ads b/gcc/ada/s-tasuti.ads deleted file mode 100644 index 875489297ea..00000000000 --- a/gcc/ada/s-tasuti.ads +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . U T I L I T I E S -- --- -- --- S p e c -- --- -- --- 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. -- --- -- ------------------------------------------------------------------------------- - --- This package provides RTS Internal Declarations. --- These declarations are not part of the GNARLI - -with Ada.Unchecked_Conversion; -with System.Task_Primitives; - -package System.Tasking.Utilities is - - function ATCB_To_Address is new - Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address); - - --------------------------------- - -- Task_Stage Related routines -- - --------------------------------- - - function Make_Independent return Boolean; - -- Move the current task to the outermost level (level 2) of the master - -- hierarchy of the environment task. That is one level further out - -- than normal tasks defined in library-level packages (level 3). The - -- environment task will wait for level 3 tasks to terminate normally, - -- then it will abort all the level 2 tasks. See Finalize_Global_Tasks - -- procedure for more information. - -- - -- This is a dangerous operation, and should never be used on nested tasks - -- or tasks that depend on any objects that might be finalized earlier than - -- the termination of the environment task. It is for internal use by the - -- GNARL, to prevent such internal server tasks from preventing a partition - -- from terminating. - -- - -- Also note that the run time assumes that the parent of an independent - -- task is the environment task. If this is not the case, Make_Independent - -- will change the task's parent. This assumption is particularly - -- important for master level completion and for the computation of - -- Independent_Task_Count. - -- - -- NOTE WELL: Make_Independent should be called before the task reaches its - -- "begin", like this: - -- - -- task body Some_Independent_Task is - -- ... - -- Ignore : constant Boolean := Make_Independent; - -- ... - -- begin - -- - -- The return value is meaningless; the only reason this is a function is - -- to get around the Ada limitation that makes a procedure call - -- syntactically illegal before the "begin". - -- - -- Calling it before "begin" ensures that the call completes before the - -- activating task can proceed. This is important for preventing race - -- conditions. For example, if the environment task reaches - -- Finalize_Global_Tasks before some task has finished Make_Independent, - -- the program can hang. - -- - -- Note also that if a package declares independent tasks, it should not - -- initialize its package-body data after "begin" of the package, because - -- that's where the tasks are activated. Initializing such data before the - -- task activation helps prevent the tasks from accessing uninitialized - -- data. - - Independent_Task_Count : Natural := 0; - -- Number of independent tasks. This counter is incremented each time - -- Make_Independent is called. Note that if a server task terminates, - -- this counter will not be decremented. Since Make_Independent locks - -- the environment task (because every independent task depends on it), - -- this counter is protected by the environment task's lock. - - --------------------------------- - -- Task Abort Related Routines -- - --------------------------------- - - procedure Cancel_Queued_Entry_Calls (T : Task_Id); - -- Cancel any entry calls queued on target task. - -- Call this while holding T's lock (or RTS_Lock in Single_Lock mode). - - procedure Exit_One_ATC_Level (Self_ID : Task_Id); - pragma Inline (Exit_One_ATC_Level); - -- Call only with abort deferred and holding lock of Self_ID. - -- This is a bit of common code for all entry calls. - -- The effect is to exit one level of ATC nesting. - - procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id); - -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but: - -- (1) caller should be holding no locks - -- (2) may be called for tasks that have not yet been activated - -- (3) always aborts whole task - - procedure Abort_Tasks (Tasks : Task_List); - -- Abort_Tasks is called to initiate abort, however, the actual - -- aborting is done by aborted task by means of Abort_Handler - - procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean); - -- Update counts to indicate current task is either terminated or - -- accepting on a terminate alternative. Call holding no locks except - -- Global_Task_Lock when calling from Terminate_Task, and RTS_Lock when - -- Single_Lock is True. - -end System.Tasking.Utilities; diff --git a/gcc/ada/s-tataat.adb b/gcc/ada/s-tataat.adb deleted file mode 100644 index 0ebf3d1bb96..00000000000 --- a/gcc/ada/s-tataat.adb +++ /dev/null @@ -1,98 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . T A S K _ A T T R I B U T E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2014-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. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Parameters; use System.Parameters; -with System.Tasking.Initialization; use System.Tasking.Initialization; -with System.Task_Primitives.Operations; - -package body System.Tasking.Task_Attributes is - - package STPO renames System.Task_Primitives.Operations; - - type Index_Info is record - Used : Boolean; - -- Used is True if a given index is used by an instantiation of - -- Ada.Task_Attributes, False otherwise. - - Require_Finalization : Boolean; - -- Require_Finalization is True if the attribute requires finalization - end record; - - Index_Array : array (1 .. Max_Attribute_Count) of Index_Info := - (others => (False, False)); - - -- Note that this package will use an efficient implementation with no - -- locks and no extra dynamic memory allocation if Attribute can fit in a - -- System.Address type and Initial_Value is 0 (or null for an access type). - - function Next_Index (Require_Finalization : Boolean) return Integer is - Self_Id : constant Task_Id := STPO.Self; - - begin - Task_Lock (Self_Id); - - for J in Index_Array'Range loop - if not Index_Array (J).Used then - Index_Array (J).Used := True; - Index_Array (J).Require_Finalization := Require_Finalization; - Task_Unlock (Self_Id); - return J; - end if; - end loop; - - Task_Unlock (Self_Id); - raise Storage_Error with "Out of task attributes"; - end Next_Index; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Index : Integer) is - Self_Id : constant Task_Id := STPO.Self; - begin - pragma Assert (Index in Index_Array'Range); - Task_Lock (Self_Id); - Index_Array (Index).Used := False; - Task_Unlock (Self_Id); - end Finalize; - - -------------------------- - -- Require_Finalization -- - -------------------------- - - function Require_Finalization (Index : Integer) return Boolean is - begin - pragma Assert (Index in Index_Array'Range); - return Index_Array (Index).Require_Finalization; - end Require_Finalization; - -end System.Tasking.Task_Attributes; diff --git a/gcc/ada/s-tataat.ads b/gcc/ada/s-tataat.ads deleted file mode 100644 index 2dd5f5e6787..00000000000 --- a/gcc/ada/s-tataat.ads +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . T A S K _ A T T R I B U T E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2014, 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 package provides support for the body of Ada.Task_Attributes - -with Ada.Unchecked_Conversion; - -package System.Tasking.Task_Attributes is - - type Deallocator is access procedure (Ptr : Atomic_Address); - - type Attribute_Record is record - Free : Deallocator; - end record; - -- The real type is declared in Ada.Task_Attributes body: Real_Attribute. - -- As long as the first field is the deallocator we are good. - - type Attribute_Access is access all Attribute_Record; - pragma No_Strict_Aliasing (Attribute_Access); - - function To_Attribute is new - Ada.Unchecked_Conversion (Atomic_Address, Attribute_Access); - - function Next_Index (Require_Finalization : Boolean) return Integer; - -- Return the next attribute index available. Require_Finalization is True - -- if the attribute requires finalization and in particular its deallocator - -- (Free field in Attribute_Record) should be called. Raise Storage_Error - -- if no index is available. - - function Require_Finalization (Index : Integer) return Boolean; - -- Return True if a given attribute index requires call to Free. This call - -- is not protected against concurrent access, should only be called during - -- finalization of the corresponding instantiation of Ada.Task_Attributes, - -- or during finalization of a task. - - procedure Finalize (Index : Integer); - -- Finalize given Index, possibly allowing future reuse - -private - pragma Inline (Finalize); - pragma Inline (Require_Finalization); -end System.Tasking.Task_Attributes; diff --git a/gcc/ada/s-tpinop.adb b/gcc/ada/s-tpinop.adb deleted file mode 100644 index 0ab91ffef66..00000000000 --- a/gcc/ada/s-tpinop.adb +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.INTERRUPT_OPERATIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-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. -- --- -- ------------------------------------------------------------------------------- - -package body System.Task_Primitives.Interrupt_Operations is - - -- ??? The VxWorks version of System.Interrupt_Management needs to access - -- this array, but due to elaboration problems, it can't with this - -- package directly, so we export this variable for now. - - Interrupt_ID_Map : array (IM.Interrupt_ID) of ST.Task_Id; - pragma Export (Ada, Interrupt_ID_Map, - "system__task_primitives__interrupt_operations__interrupt_id_map"); - - ---------------------- - -- Get_Interrupt_ID -- - ---------------------- - - function Get_Interrupt_ID (T : ST.Task_Id) return IM.Interrupt_ID is - use type ST.Task_Id; - - begin - for Interrupt in IM.Interrupt_ID loop - if Interrupt_ID_Map (Interrupt) = T then - return Interrupt; - end if; - end loop; - - raise Program_Error; - end Get_Interrupt_ID; - - ----------------- - -- Get_Task_Id -- - ----------------- - - function Get_Task_Id (Interrupt : IM.Interrupt_ID) return ST.Task_Id is - begin - return Interrupt_ID_Map (Interrupt); - end Get_Task_Id; - - ---------------------- - -- Set_Interrupt_ID -- - ---------------------- - - procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_Id) is - begin - Interrupt_ID_Map (Interrupt) := T; - end Set_Interrupt_ID; - -end System.Task_Primitives.Interrupt_Operations; diff --git a/gcc/ada/s-tpinop.ads b/gcc/ada/s-tpinop.ads deleted file mode 100644 index 57f7c7cb839..00000000000 --- a/gcc/ada/s-tpinop.ads +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.INTERRUPT_OPERATIONS -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-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. -- --- -- ------------------------------------------------------------------------------- - -with System.Interrupt_Management; -with System.Tasking; - -package System.Task_Primitives.Interrupt_Operations is - pragma Preelaborate; - - package IM renames System.Interrupt_Management; - package ST renames System.Tasking; - - procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_Id); - -- Associate an Interrupt_ID with a task - - function Get_Interrupt_ID (T : ST.Task_Id) return IM.Interrupt_ID; - -- Return the Interrupt_ID associated with a task - - function Get_Task_Id (Interrupt : IM.Interrupt_ID) return ST.Task_Id; - -- Return the Task_Id associated with an Interrupt - -end System.Task_Primitives.Interrupt_Operations; diff --git a/gcc/ada/s-tpoaal.adb b/gcc/ada/s-tpoaal.adb deleted file mode 100644 index 1d25fb84b62..00000000000 --- a/gcc/ada/s-tpoaal.adb +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.ATCB_ALLOCATION -- --- -- --- B o d y -- --- -- --- Copyright (C) 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. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -separate (System.Task_Primitives.Operations) -package body ATCB_Allocation is - - --------------- - -- Free_ATCB -- - --------------- - - procedure Free_ATCB (T : Task_Id) is - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - - begin - if Is_Self then - declare - Local_ATCB : aliased Ada_Task_Control_Block (0); - -- Create a dummy ATCB and initialize it minimally so that "Free" - -- can still call Self and Defer/Undefer_Abort after Tmp is freed - -- by the underlying memory management library. - - begin - Local_ATCB.Common.LL.Thread := T.Common.LL.Thread; - Local_ATCB.Common.Current_Priority := T.Common.Current_Priority; - - Specific.Set (Local_ATCB'Unchecked_Access); - Free (Tmp); - - -- Note: it is assumed here that for all platforms, Specific.Set - -- deletes the task specific information if passed a null value. - - Specific.Set (null); - end; - - else - Free (Tmp); - end if; - end Free_ATCB; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - -end ATCB_Allocation; diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb deleted file mode 100644 index ddea94802b8..00000000000 --- a/gcc/ada/s-tpoben.adb +++ /dev/null @@ -1,427 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-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. -- --- -- ------------------------------------------------------------------------------- - --- This package contains all the simple primitives related to protected --- objects with entries (i.e init, lock, unlock). - --- The handling of protected objects with no entries is done in --- System.Tasking.Protected_Objects, the complex routines for protected --- objects with entries in System.Tasking.Protected_Objects.Operations. - --- The split between Entries and Operations is needed to break circular --- dependencies inside the run time. - --- Note: the compiler generates direct calls to this interface, via Rtsfind - -with System.Task_Primitives.Operations; -with System.Restrictions; -with System.Parameters; - -with System.Tasking.Initialization; -pragma Elaborate_All (System.Tasking.Initialization); --- To insure that tasking is initialized if any protected objects are created - -package body System.Tasking.Protected_Objects.Entries is - - package STPO renames System.Task_Primitives.Operations; - - use Parameters; - use Task_Primitives.Operations; - - ---------------- - -- Local Data -- - ---------------- - - Locking_Policy : Character; - pragma Import (C, Locking_Policy, "__gl_locking_policy"); - - -------------- - -- Finalize -- - -------------- - - overriding procedure Finalize (Object : in out Protection_Entries) is - Entry_Call : Entry_Call_Link; - Caller : Task_Id; - Ceiling_Violation : Boolean; - Self_ID : constant Task_Id := STPO.Self; - Old_Base_Priority : System.Any_Priority; - - begin - if Object.Finalized then - return; - end if; - - STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); - - if Single_Lock then - Lock_RTS; - end if; - - if Ceiling_Violation then - - -- Dip our own priority down to ceiling of lock. See similar code in - -- Tasking.Entry_Calls.Lock_Server. - - STPO.Write_Lock (Self_ID); - Old_Base_Priority := Self_ID.Common.Base_Priority; - Self_ID.New_Base_Priority := Object.Ceiling; - Initialization.Change_Base_Priority (Self_ID); - STPO.Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); - - if Ceiling_Violation then - raise Program_Error with "ceiling violation"; - end if; - - if Single_Lock then - Lock_RTS; - end if; - - Object.Old_Base_Priority := Old_Base_Priority; - Object.Pending_Action := True; - end if; - - -- Send program_error to all tasks still queued on this object - - for E in Object.Entry_Queues'Range loop - Entry_Call := Object.Entry_Queues (E).Head; - - while Entry_Call /= null loop - Caller := Entry_Call.Self; - Entry_Call.Exception_To_Raise := Program_Error'Identity; - - STPO.Write_Lock (Caller); - Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); - STPO.Unlock (Caller); - - exit when Entry_Call = Object.Entry_Queues (E).Tail; - Entry_Call := Entry_Call.Next; - end loop; - end loop; - - Object.Finalized := True; - - if Single_Lock then - Unlock_RTS; - end if; - - STPO.Unlock (Object.L'Unrestricted_Access); - - STPO.Finalize_Lock (Object.L'Unrestricted_Access); - end Finalize; - - ----------------- - -- Get_Ceiling -- - ----------------- - - function Get_Ceiling - (Object : Protection_Entries_Access) return System.Any_Priority is - begin - return Object.New_Ceiling; - end Get_Ceiling; - - ------------------------------------- - -- Has_Interrupt_Or_Attach_Handler -- - ------------------------------------- - - function Has_Interrupt_Or_Attach_Handler - (Object : Protection_Entries_Access) - return Boolean - is - pragma Warnings (Off, Object); - begin - return False; - end Has_Interrupt_Or_Attach_Handler; - - ----------------------------------- - -- Initialize_Protection_Entries -- - ----------------------------------- - - procedure Initialize_Protection_Entries - (Object : Protection_Entries_Access; - Ceiling_Priority : Integer; - Compiler_Info : System.Address; - Entry_Queue_Maxes : Protected_Entry_Queue_Max_Access; - Entry_Bodies : Protected_Entry_Body_Access; - Find_Body_Index : Find_Body_Index_Access) - is - Init_Priority : Integer := Ceiling_Priority; - Self_ID : constant Task_Id := STPO.Self; - - begin - if Init_Priority = Unspecified_Priority then - Init_Priority := System.Priority'Last; - end if; - - if Locking_Policy = 'C' - and then Has_Interrupt_Or_Attach_Handler (Object) - and then Init_Priority not in System.Interrupt_Priority - then - -- Required by C.3.1(11) - - raise Program_Error; - end if; - - -- If a PO is created from a controlled operation, abort is already - -- deferred at this point, so we need to use Defer_Abort_Nestable. In - -- some cases, the following assertion can help to spot inconsistencies, - -- outside the above scenario involving controlled types. - - -- pragma Assert (Self_Id.Deferral_Level = 0); - - Initialization.Defer_Abort_Nestable (Self_ID); - Initialize_Lock (Init_Priority, Object.L'Access); - Initialization.Undefer_Abort_Nestable (Self_ID); - - Object.Ceiling := System.Any_Priority (Init_Priority); - Object.New_Ceiling := System.Any_Priority (Init_Priority); - Object.Owner := Null_Task; - Object.Compiler_Info := Compiler_Info; - Object.Pending_Action := False; - Object.Call_In_Progress := null; - Object.Entry_Queue_Maxes := Entry_Queue_Maxes; - Object.Entry_Bodies := Entry_Bodies; - Object.Find_Body_Index := Find_Body_Index; - - for E in Object.Entry_Queues'Range loop - Object.Entry_Queues (E).Head := null; - Object.Entry_Queues (E).Tail := null; - end loop; - end Initialize_Protection_Entries; - - ------------------ - -- Lock_Entries -- - ------------------ - - procedure Lock_Entries (Object : Protection_Entries_Access) is - Ceiling_Violation : Boolean; - - begin - Lock_Entries_With_Status (Object, Ceiling_Violation); - - if Ceiling_Violation then - raise Program_Error with "ceiling violation"; - end if; - end Lock_Entries; - - ------------------------------ - -- Lock_Entries_With_Status -- - ------------------------------ - - procedure Lock_Entries_With_Status - (Object : Protection_Entries_Access; - Ceiling_Violation : out Boolean) - is - begin - if Object.Finalized then - raise Program_Error with "protected object is finalized"; - end if; - - -- If pragma Detect_Blocking is active then, as described in the ARM - -- 9.5.1, par. 15, we must check whether this is an external call on a - -- protected subprogram with the same target object as that of the - -- protected action that is currently in progress (i.e., if the caller - -- is already the protected object's owner). If this is the case hence - -- Program_Error must be raised. - - if Detect_Blocking and then Object.Owner = Self then - raise Program_Error; - end if; - - -- The lock is made without deferring abort - - -- Therefore the abort has to be deferred before calling this routine. - -- This means that the compiler has to generate a Defer_Abort call - -- before the call to Lock. - - -- The caller is responsible for undeferring abort, and compiler - -- generated calls must be protected with cleanup handlers to ensure - -- that abort is undeferred in all cases. - - pragma Assert - (STPO.Self.Deferral_Level > 0 - or else not Restrictions.Abort_Allowed); - - Write_Lock (Object.L'Access, Ceiling_Violation); - - -- We are entering in a protected action, so that we increase the - -- protected object nesting level (if pragma Detect_Blocking is - -- active), and update the protected object's owner. - - if Detect_Blocking then - declare - Self_Id : constant Task_Id := Self; - - begin - -- Update the protected object's owner - - Object.Owner := Self_Id; - - -- Increase protected object nesting level - - Self_Id.Common.Protected_Action_Nesting := - Self_Id.Common.Protected_Action_Nesting + 1; - end; - end if; - end Lock_Entries_With_Status; - - ---------------------------- - -- Lock_Read_Only_Entries -- - ---------------------------- - - procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is - Ceiling_Violation : Boolean; - - begin - if Object.Finalized then - raise Program_Error with "protected object is finalized"; - end if; - - -- If pragma Detect_Blocking is active then, as described in the ARM - -- 9.5.1, par. 15, we must check whether this is an external call on a - -- protected subprogram with the same target object as that of the - -- protected action that is currently in progress (i.e., if the caller - -- is already the protected object's owner). If this is the case hence - -- Program_Error must be raised. - - -- Note that in this case (getting read access), several tasks may - -- have read ownership of the protected object, so that this method of - -- storing the (single) protected object's owner does not work - -- reliably for read locks. However, this is the approach taken for two - -- major reasons: first, this function is not currently being used (it - -- is provided for possible future use), and second, it largely - -- simplifies the implementation. - - if Detect_Blocking and then Object.Owner = Self then - raise Program_Error; - end if; - - Read_Lock (Object.L'Access, Ceiling_Violation); - - if Ceiling_Violation then - raise Program_Error with "ceiling violation"; - end if; - - -- We are entering in a protected action, so that we increase the - -- protected object nesting level (if pragma Detect_Blocking is - -- active), and update the protected object's owner. - - if Detect_Blocking then - declare - Self_Id : constant Task_Id := Self; - - begin - -- Update the protected object's owner - - Object.Owner := Self_Id; - - -- Increase protected object nesting level - - Self_Id.Common.Protected_Action_Nesting := - Self_Id.Common.Protected_Action_Nesting + 1; - end; - end if; - end Lock_Read_Only_Entries; - - ----------------------- - -- Number_Of_Entries -- - ----------------------- - - function Number_Of_Entries - (Object : Protection_Entries_Access) return Entry_Index - is - begin - return Entry_Index (Object.Num_Entries); - end Number_Of_Entries; - - ----------------- - -- Set_Ceiling -- - ----------------- - - procedure Set_Ceiling - (Object : Protection_Entries_Access; - Prio : System.Any_Priority) is - begin - Object.New_Ceiling := Prio; - end Set_Ceiling; - - -------------------- - -- Unlock_Entries -- - -------------------- - - procedure Unlock_Entries (Object : Protection_Entries_Access) is - begin - -- We are exiting from a protected action, so that we decrease the - -- protected object nesting level (if pragma Detect_Blocking is - -- active), and remove ownership of the protected object. - - if Detect_Blocking then - declare - Self_Id : constant Task_Id := Self; - - begin - -- Calls to this procedure can only take place when being within - -- a protected action and when the caller is the protected - -- object's owner. - - pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 - and then Object.Owner = Self_Id); - - -- Remove ownership of the protected object - - Object.Owner := Null_Task; - - Self_Id.Common.Protected_Action_Nesting := - Self_Id.Common.Protected_Action_Nesting - 1; - end; - end if; - - -- Before releasing the mutex we must actually update its ceiling - -- priority if it has been changed. - - if Object.New_Ceiling /= Object.Ceiling then - if Locking_Policy = 'C' then - System.Task_Primitives.Operations.Set_Ceiling - (Object.L'Access, Object.New_Ceiling); - end if; - - Object.Ceiling := Object.New_Ceiling; - end if; - - Unlock (Object.L'Access); - end Unlock_Entries; - -end System.Tasking.Protected_Objects.Entries; diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads deleted file mode 100644 index 8f928204d68..00000000000 --- a/gcc/ada/s-tpoben.ads +++ /dev/null @@ -1,236 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - --- This package contains all simple primitives related to Protected_Objects --- with entries (i.e init, lock, unlock). - --- The handling of protected objects with no entries is done in --- System.Tasking.Protected_Objects, the complex routines for protected --- objects with entries in System.Tasking.Protected_Objects.Operations. - --- The split between Entries and Operations is needed to break circular --- dependencies inside the run time. - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes. - -with Ada.Finalization; -with Ada.Unchecked_Conversion; - -package System.Tasking.Protected_Objects.Entries is - pragma Elaborate_Body; - - subtype Positive_Protected_Entry_Index is - Protected_Entry_Index range 1 .. Protected_Entry_Index'Last; - -- Index of the entry (and in some cases of the queue) - - type Find_Body_Index_Access is access - function - (O : System.Address; - E : Protected_Entry_Index) - return Protected_Entry_Index; - -- Convert a queue index to an entry index (an entry family has one entry - -- index for several queue indexes). - - type Protected_Entry_Body_Array is - array (Positive_Protected_Entry_Index range <>) of Entry_Body; - -- Contains executable code for all entry bodies of a protected type - - type Protected_Entry_Body_Access is - access constant Protected_Entry_Body_Array; - - type Protected_Entry_Queue_Array is - array (Protected_Entry_Index range <>) of Entry_Queue; - - type Protected_Entry_Queue_Max_Array is - array (Positive_Protected_Entry_Index range <>) of Natural; - - type Protected_Entry_Queue_Max_Access is - access constant Protected_Entry_Queue_Max_Array; - - -- The following type contains the GNARL state of a protected object. - -- The application-defined portion of the state (i.e. private objects) - -- is maintained by the compiler-generated code. Note that there is a - -- simplified version of this type declared in System.Tasking.PO_Simple - -- that handle the simple case (no entries). - - type Protection_Entries (Num_Entries : Protected_Entry_Index) is new - Ada.Finalization.Limited_Controlled - with record - L : aliased Task_Primitives.Lock; - -- The underlying lock associated with a Protection_Entries. Note - -- that you should never (un)lock Object.L directly, but instead - -- use Lock_Entries/Unlock_Entries. - - Compiler_Info : System.Address; - -- Pointer to compiler-generated record representing protected object - - Call_In_Progress : Entry_Call_Link; - -- Pointer to the entry call being executed (if any) - - Ceiling : System.Any_Priority; - -- Ceiling priority associated with the protected object - - New_Ceiling : System.Any_Priority; - -- New ceiling priority associated to the protected object. In case - -- of assignment of a new ceiling priority to the protected object the - -- frontend generates a call to set_ceiling to save the new value in - -- this field. After such assignment this value can be read by means - -- of the 'Priority attribute, which generates a call to get_ceiling. - -- However, the ceiling of the protected object will not be changed - -- until completion of the protected action in which the assignment - -- has been executed (AARM D.5.2 (10/2)). - - Owner : Task_Id; - -- This field contains the protected object's owner. Null_Task - -- indicates that the protected object is not currently being used. - -- This information is used for detecting the type of potentially - -- blocking operations described in the ARM 9.5.1, par. 15 (external - -- calls on a protected subprogram with the same target object as that - -- of the protected action). - - Old_Base_Priority : System.Any_Priority; - -- Task's base priority when the protected operation was called - - Pending_Action : Boolean; - -- Flag indicating that priority has been dipped temporarily in order - -- to avoid violating the priority ceiling of the lock associated with - -- this protected object, in Lock_Server. The flag tells Unlock_Server - -- or Unlock_And_Update_Server to restore the old priority to - -- Old_Base_Priority. This is needed because of situations (bad - -- language design?) where one needs to lock a PO but to do so would - -- violate the priority ceiling. For example, this can happen when an - -- entry call has been requeued to a lower-priority object, and the - -- caller then tries to cancel the call while its own priority is - -- higher than the ceiling of the new PO. - - Finalized : Boolean := False; - -- Set to True by Finalize to make this routine idempotent - - Entry_Bodies : Protected_Entry_Body_Access; - -- Pointer to an array containing the executable code for all entry - -- bodies of a protected type. - - Find_Body_Index : Find_Body_Index_Access; - -- A function which maps the entry index in a call (which denotes the - -- queue of the proper entry) into the body of the entry. - - Entry_Queue_Maxes : Protected_Entry_Queue_Max_Access; - -- Access to an array of naturals representing the max value for each - -- entry's queue length. A value of 0 signifies no max. - - Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries); - -- Action and barrier subprograms for the protected type. - end record; - - -- No default initial values for this type, since call records will need to - -- be re-initialized before every use. - - type Protection_Entries_Access is access all Protection_Entries'Class; - -- See comments in s-tassta.adb about the implicit call to Current_Master - -- generated by this declaration. - - function To_Address is - new Ada.Unchecked_Conversion (Protection_Entries_Access, System.Address); - function To_Protection is - new Ada.Unchecked_Conversion (System.Address, Protection_Entries_Access); - - function Get_Ceiling - (Object : Protection_Entries_Access) return System.Any_Priority; - -- Returns the new ceiling priority of the protected object - - function Has_Interrupt_Or_Attach_Handler - (Object : Protection_Entries_Access) return Boolean; - -- Returns True if an Interrupt_Handler or Attach_Handler pragma applies - -- to the protected object. That is to say this primitive returns False for - -- Protection, but is overridden to return True when interrupt handlers are - -- declared so the check required by C.3.1(11) can be implemented in - -- System.Tasking.Protected_Objects.Initialize_Protection. - - procedure Initialize_Protection_Entries - (Object : Protection_Entries_Access; - Ceiling_Priority : Integer; - Compiler_Info : System.Address; - Entry_Queue_Maxes : Protected_Entry_Queue_Max_Access; - Entry_Bodies : Protected_Entry_Body_Access; - Find_Body_Index : Find_Body_Index_Access); - -- Initialize the Object parameter so that it can be used by the runtime - -- to keep track of the runtime state of a protected object. - - procedure Lock_Entries (Object : Protection_Entries_Access); - -- Lock a protected object for write access. Upon return, the caller owns - -- the lock to this object, and no other call to Lock or Lock_Read_Only - -- with the same argument will return until the corresponding call to - -- Unlock has been made by the caller. Program_Error is raised in case of - -- ceiling violation. - - procedure Lock_Entries_With_Status - (Object : Protection_Entries_Access; - Ceiling_Violation : out Boolean); - -- Same as above, but return the ceiling violation status instead of - -- raising Program_Error. - - procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access); - -- Lock a protected object for read access. Upon return, the caller owns - -- the lock for read access, and no other calls to Lock with the same - -- argument will return until the corresponding call to Unlock has been - -- made by the caller. Other calls to Lock_Read_Only may (but need not) - -- return before the call to Unlock, and the corresponding callers will - -- also own the lock for read access. - -- - -- Note: we are not currently using this interface, it is provided for - -- possible future use. At the current time, everyone uses Lock for both - -- read and write locks. - - function Number_Of_Entries - (Object : Protection_Entries_Access) return Entry_Index; - -- Return the number of entries of a protected object - - procedure Set_Ceiling - (Object : Protection_Entries_Access; - Prio : System.Any_Priority); - -- Sets the new ceiling priority of the protected object - - procedure Unlock_Entries (Object : Protection_Entries_Access); - -- Relinquish ownership of the lock for the object represented by the - -- Object parameter. If this ownership was for write access, or if it was - -- for read access where there are no other read access locks outstanding, - -- one (or more, in the case of Lock_Read_Only) of the tasks waiting on - -- this lock (if any) will be given the lock and allowed to return from - -- the Lock or Lock_Read_Only call. - -private - - overriding procedure Finalize (Object : in out Protection_Entries); - -- Clean up a Protection object; in particular, finalize the associated - -- Lock object. - -end System.Tasking.Protected_Objects.Entries; diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb deleted file mode 100644 index 242fe45f97e..00000000000 --- a/gcc/ada/s-tpobop.adb +++ /dev/null @@ -1,1103 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS -- --- -- --- 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 package contains all extended primitives related to Protected_Objects --- with entries. - --- The handling of protected objects with no entries is done in --- System.Tasking.Protected_Objects, the simple routines for protected --- objects with entries in System.Tasking.Protected_Objects.Entries. - --- The split between Entries and Operations is needed to break circular --- dependencies inside the run time. - --- This package contains all primitives related to Protected_Objects. --- Note: the compiler generates direct calls to this interface, via Rtsfind. - -with System.Task_Primitives.Operations; -with System.Tasking.Entry_Calls; -with System.Tasking.Queuing; -with System.Tasking.Rendezvous; -with System.Tasking.Utilities; -with System.Tasking.Debug; -with System.Parameters; -with System.Restrictions; - -with System.Tasking.Initialization; -pragma Elaborate_All (System.Tasking.Initialization); --- Insures that tasking is initialized if any protected objects are created - -package body System.Tasking.Protected_Objects.Operations is - - package STPO renames System.Task_Primitives.Operations; - - use Parameters; - use Task_Primitives; - use Ada.Exceptions; - use Entries; - - use System.Restrictions; - use System.Restrictions.Rident; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Update_For_Queue_To_PO - (Entry_Call : Entry_Call_Link; - With_Abort : Boolean); - pragma Inline (Update_For_Queue_To_PO); - -- Update the state of an existing entry call to reflect the fact that it - -- is being enqueued, based on whether the current queuing action is with - -- or without abort. Call this only while holding the PO's lock. It returns - -- with the PO's lock still held. - - procedure Requeue_Call - (Self_Id : Task_Id; - Object : Protection_Entries_Access; - Entry_Call : Entry_Call_Link); - -- Handle requeue of Entry_Call. - -- In particular, queue the call if needed, or service it immediately - -- if possible. - - --------------------------------- - -- Cancel_Protected_Entry_Call -- - --------------------------------- - - -- Compiler interface only (do not call from within the RTS) - - -- This should have analogous effect to Cancel_Task_Entry_Call, setting - -- the value of Block.Cancelled instead of returning the parameter value - -- Cancelled. - - -- The effect should be idempotent, since the call may already have been - -- dequeued. - - -- Source code: - - -- select r.e; - -- ...A... - -- then abort - -- ...B... - -- end select; - - -- Expanded code: - - -- declare - -- X : protected_entry_index := 1; - -- B80b : communication_block; - -- communication_blockIP (B80b); - - -- begin - -- begin - -- A79b : label - -- A79b : declare - -- procedure _clean is - -- begin - -- if enqueued (B80b) then - -- cancel_protected_entry_call (B80b); - -- end if; - -- return; - -- end _clean; - - -- begin - -- protected_entry_call (rTV!(r)._object'unchecked_access, X, - -- null_address, asynchronous_call, B80b, objectF => 0); - -- if enqueued (B80b) then - -- ...B... - -- end if; - -- at end - -- _clean; - -- end A79b; - - -- exception - -- when _abort_signal => - -- abort_undefer.all; - -- null; - -- end; - - -- if not cancelled (B80b) then - -- x := ...A... - -- end if; - -- end; - - -- If the entry call completes after we get into the abortable part, - -- Abort_Signal should be raised and ATC will take us to the at-end - -- handler, which will call _clean. - - -- If the entry call returns with the call already completed, we can skip - -- this, and use the "if enqueued()" to go past the at-end handler, but we - -- will still call _clean. - - -- If the abortable part completes before the entry call is Done, it will - -- call _clean. - - -- If the entry call or the abortable part raises an exception, - -- we will still call _clean, but the value of Cancelled should not matter. - - -- Whoever calls _clean first gets to decide whether the call - -- has been "cancelled". - - -- Enqueued should be true if there is any chance that the call is still on - -- a queue. It seems to be safe to make it True if the call was Onqueue at - -- some point before return from Protected_Entry_Call. - - -- Cancelled should be true iff the abortable part completed - -- and succeeded in cancelling the entry call before it completed. - - -- ????? - -- The need for Enqueued is less obvious. The "if enqueued ()" tests are - -- not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call - -- must do the same test internally, with locking. The one that makes - -- cancellation conditional may be a useful heuristic since at least 1/2 - -- the time the call should be off-queue by that point. The other one seems - -- totally useless, since Protected_Entry_Call must do the same check and - -- then possibly wait for the call to be abortable, internally. - - -- We can check Call.State here without locking the caller's mutex, - -- since the call must be over after returning from Wait_For_Completion. - -- No other task can access the call record at this point. - - procedure Cancel_Protected_Entry_Call - (Block : in out Communication_Block) is - begin - Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled); - end Cancel_Protected_Entry_Call; - - --------------- - -- Cancelled -- - --------------- - - function Cancelled (Block : Communication_Block) return Boolean is - begin - return Block.Cancelled; - end Cancelled; - - ------------------------- - -- Complete_Entry_Body -- - ------------------------- - - procedure Complete_Entry_Body (Object : Protection_Entries_Access) is - begin - Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id); - end Complete_Entry_Body; - - -------------- - -- Enqueued -- - -------------- - - function Enqueued (Block : Communication_Block) return Boolean is - begin - return Block.Enqueued; - end Enqueued; - - ------------------------------------- - -- Exceptional_Complete_Entry_Body -- - ------------------------------------- - - procedure Exceptional_Complete_Entry_Body - (Object : Protection_Entries_Access; - Ex : Ada.Exceptions.Exception_Id) - is - procedure Transfer_Occurrence - (Target : Ada.Exceptions.Exception_Occurrence_Access; - Source : Ada.Exceptions.Exception_Occurrence); - pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); - - Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; - Self_Id : Task_Id; - - begin - pragma Debug - (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P')); - - -- We must have abort deferred, since we are inside a protected - -- operation. - - if Entry_Call /= null then - - -- The call was not requeued - - Entry_Call.Exception_To_Raise := Ex; - - if Ex /= Ada.Exceptions.Null_Id then - - -- An exception was raised and abort was deferred, so adjust - -- before propagating, otherwise the task will stay with deferral - -- enabled for its remaining life. - - Self_Id := STPO.Self; - - if not ZCX_By_Default then - Initialization.Undefer_Abort_Nestable (Self_Id); - end if; - - Transfer_Occurrence - (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access, - Self_Id.Common.Compiler_Data.Current_Excep); - end if; - - -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or - -- PO_Service_Entries on return. - - end if; - end Exceptional_Complete_Entry_Body; - - -------------------- - -- PO_Do_Or_Queue -- - -------------------- - - procedure PO_Do_Or_Queue - (Self_ID : Task_Id; - Object : Protection_Entries_Access; - Entry_Call : Entry_Call_Link) - is - E : constant Protected_Entry_Index := - Protected_Entry_Index (Entry_Call.E); - Index : constant Protected_Entry_Index := - Object.Find_Body_Index (Object.Compiler_Info, E); - Barrier_Value : Boolean; - Queue_Length : Natural; - begin - -- When the Action procedure for an entry body returns, it is either - -- completed (having called [Exceptional_]Complete_Entry_Body) or it - -- is queued, having executed a requeue statement. - - Barrier_Value := - Object.Entry_Bodies (Index).Barrier (Object.Compiler_Info, E); - - if Barrier_Value then - - -- Not abortable while service is in progress - - if Entry_Call.State = Now_Abortable then - Entry_Call.State := Was_Abortable; - end if; - - Object.Call_In_Progress := Entry_Call; - - pragma Debug - (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P')); - Object.Entry_Bodies (Index).Action ( - Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); - - if Object.Call_In_Progress /= null then - - -- Body of current entry served call to completion - - Object.Call_In_Progress := null; - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Entry_Call.Self); - Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); - STPO.Unlock (Entry_Call.Self); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - else - Requeue_Call (Self_ID, Object, Entry_Call); - end if; - - elsif Entry_Call.Mode /= Conditional_Call - or else not Entry_Call.With_Abort - then - if Run_Time_Restrictions.Set (Max_Entry_Queue_Length) - or else Object.Entry_Queue_Maxes /= null - then - -- Need to check the queue length. Computing the length is an - -- unusual case and is slow (need to walk the queue). - - Queue_Length := Queuing.Count_Waiting (Object.Entry_Queues (E)); - - if (Run_Time_Restrictions.Set (Max_Entry_Queue_Length) - and then Queue_Length >= - Run_Time_Restrictions.Value (Max_Entry_Queue_Length)) - or else - (Object.Entry_Queue_Maxes /= null - and then Object.Entry_Queue_Maxes (Index) /= 0 - and then Queue_Length >= Object.Entry_Queue_Maxes (Index)) - then - -- This violates the Max_Entry_Queue_Length restriction or the - -- Max_Queue_Length bound, raise Program_Error. - - Entry_Call.Exception_To_Raise := Program_Error'Identity; - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Entry_Call.Self); - Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); - STPO.Unlock (Entry_Call.Self); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - return; - end if; - end if; - - -- Do the work: queue the call - - Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call); - Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort); - - return; - else - -- Conditional_Call and With_Abort - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Entry_Call.Self); - pragma Assert (Entry_Call.State /= Not_Yet_Abortable); - Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); - STPO.Unlock (Entry_Call.Self); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - end if; - - exception - when others => - Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call); - end PO_Do_Or_Queue; - - ------------------------ - -- PO_Service_Entries -- - ------------------------ - - procedure PO_Service_Entries - (Self_ID : Task_Id; - Object : Entries.Protection_Entries_Access; - Unlock_Object : Boolean := True) - is - E : Protected_Entry_Index; - Caller : Task_Id; - Entry_Call : Entry_Call_Link; - - begin - loop - Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call); - - exit when Entry_Call = null; - - E := Protected_Entry_Index (Entry_Call.E); - - -- Not abortable while service is in progress - - if Entry_Call.State = Now_Abortable then - Entry_Call.State := Was_Abortable; - end if; - - Object.Call_In_Progress := Entry_Call; - - begin - pragma Debug - (Debug.Trace (Self_ID, "POSE: start entry body", 'P')); - - Object.Entry_Bodies - (Object.Find_Body_Index (Object.Compiler_Info, E)).Action - (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); - - exception - when others => - Queuing.Broadcast_Program_Error - (Self_ID, Object, Entry_Call); - end; - - if Object.Call_In_Progress = null then - Requeue_Call (Self_ID, Object, Entry_Call); - exit when Entry_Call.State = Cancelled; - - else - Object.Call_In_Progress := null; - Caller := Entry_Call.Self; - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Caller); - Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); - STPO.Unlock (Caller); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - end if; - end loop; - - if Unlock_Object then - Unlock_Entries (Object); - end if; - end PO_Service_Entries; - - --------------------- - -- Protected_Count -- - --------------------- - - function Protected_Count - (Object : Protection_Entries'Class; - E : Protected_Entry_Index) return Natural - is - begin - return Queuing.Count_Waiting (Object.Entry_Queues (E)); - end Protected_Count; - - -------------------------- - -- Protected_Entry_Call -- - -------------------------- - - -- Compiler interface only (do not call from within the RTS) - - -- select r.e; - -- ...A... - -- else - -- ...B... - -- end select; - - -- declare - -- X : protected_entry_index := 1; - -- B85b : communication_block; - -- communication_blockIP (B85b); - - -- begin - -- protected_entry_call (rTV!(r)._object'unchecked_access, X, - -- null_address, conditional_call, B85b, objectF => 0); - - -- if cancelled (B85b) then - -- ...B... - -- else - -- ...A... - -- end if; - -- end; - - -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous - -- entry call. - - -- The initial part of this procedure does not need to lock the calling - -- task's ATCB, up to the point where the call record first may be queued - -- (PO_Do_Or_Queue), since before that no other task will have access to - -- the record. - - -- If this is a call made inside of an abort deferred region, the call - -- should be never abortable. - - -- If the call was not queued abortably, we need to wait until it is before - -- proceeding with the abortable part. - - -- There are some heuristics here, just to save time for frequently - -- occurring cases. For example, we check Initially_Abortable to try to - -- avoid calling the procedure Wait_Until_Abortable, since the normal case - -- for async. entry calls is to be queued abortably. - - -- Another heuristic uses the Block.Enqueued to try to avoid calling - -- Cancel_Protected_Entry_Call if the call can be served immediately. - - procedure Protected_Entry_Call - (Object : Protection_Entries_Access; - E : Protected_Entry_Index; - Uninterpreted_Data : System.Address; - Mode : Call_Modes; - Block : out Communication_Block) - is - Self_ID : constant Task_Id := STPO.Self; - Entry_Call : Entry_Call_Link; - Initially_Abortable : Boolean; - Ceiling_Violation : Boolean; - - begin - pragma Debug - (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P')); - - if Self_ID.ATC_Nesting_Level = ATC_Level'Last then - raise Storage_Error with "not enough ATC nesting levels"; - end if; - - -- If pragma Detect_Blocking is active then Program_Error must be - -- raised if this potentially blocking operation is called from a - -- protected action. - - if Detect_Blocking - and then Self_ID.Common.Protected_Action_Nesting > 0 - then - raise Program_Error with "potentially blocking operation"; - end if; - - -- Self_ID.Deferral_Level should be 0, except when called from Finalize, - -- where abort is already deferred. - - Initialization.Defer_Abort_Nestable (Self_ID); - Lock_Entries_With_Status (Object, Ceiling_Violation); - - if Ceiling_Violation then - - -- Failed ceiling check - - Initialization.Undefer_Abort_Nestable (Self_ID); - raise Program_Error; - end if; - - Block.Self := Self_ID; - Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1; - pragma Debug - (Debug.Trace (Self_ID, "PEC: entered ATC level: " & - ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); - Entry_Call := - Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; - Entry_Call.Next := null; - Entry_Call.Mode := Mode; - Entry_Call.Cancellation_Attempted := False; - - Entry_Call.State := - (if Self_ID.Deferral_Level > 1 - then Never_Abortable else Now_Abortable); - - Entry_Call.E := Entry_Index (E); - Entry_Call.Prio := STPO.Get_Priority (Self_ID); - Entry_Call.Uninterpreted_Data := Uninterpreted_Data; - Entry_Call.Called_PO := To_Address (Object); - Entry_Call.Called_Task := null; - Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; - Entry_Call.With_Abort := True; - - PO_Do_Or_Queue (Self_ID, Object, Entry_Call); - Initially_Abortable := Entry_Call.State = Now_Abortable; - PO_Service_Entries (Self_ID, Object); - - -- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call) - -- for completed or cancelled calls. (This is a heuristic, only.) - - if Entry_Call.State >= Done then - - -- Once State >= Done it will not change any more - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Self_ID); - Utilities.Exit_One_ATC_Level (Self_ID); - STPO.Unlock (Self_ID); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - Block.Enqueued := False; - Block.Cancelled := Entry_Call.State = Cancelled; - Initialization.Undefer_Abort_Nestable (Self_ID); - Entry_Calls.Check_Exception (Self_ID, Entry_Call); - return; - - else - -- In this case we cannot conclude anything, since State can change - -- concurrently. - - null; - end if; - - -- Now for the general case - - if Mode = Asynchronous_Call then - - -- Try to avoid an expensive call - - if not Initially_Abortable then - if Single_Lock then - STPO.Lock_RTS; - Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); - STPO.Unlock_RTS; - else - Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); - end if; - end if; - - else - case Mode is - when Conditional_Call - | Simple_Call - => - if Single_Lock then - STPO.Lock_RTS; - Entry_Calls.Wait_For_Completion (Entry_Call); - STPO.Unlock_RTS; - - else - STPO.Write_Lock (Self_ID); - Entry_Calls.Wait_For_Completion (Entry_Call); - STPO.Unlock (Self_ID); - end if; - - Block.Cancelled := Entry_Call.State = Cancelled; - - when Asynchronous_Call - | Timed_Call - => - pragma Assert (False); - null; - end case; - end if; - - Initialization.Undefer_Abort_Nestable (Self_ID); - Entry_Calls.Check_Exception (Self_ID, Entry_Call); - end Protected_Entry_Call; - - ------------------ - -- Requeue_Call -- - ------------------ - - procedure Requeue_Call - (Self_Id : Task_Id; - Object : Protection_Entries_Access; - Entry_Call : Entry_Call_Link) - is - New_Object : Protection_Entries_Access; - Ceiling_Violation : Boolean; - Result : Boolean; - E : Protected_Entry_Index; - - begin - New_Object := To_Protection (Entry_Call.Called_PO); - - if New_Object = null then - - -- Call is to be requeued to a task entry - - if Single_Lock then - STPO.Lock_RTS; - end if; - - Result := Rendezvous.Task_Do_Or_Queue (Self_Id, Entry_Call); - - if not Result then - Queuing.Broadcast_Program_Error - (Self_Id, Object, Entry_Call, RTS_Locked => True); - end if; - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - else - -- Call should be requeued to a PO - - if Object /= New_Object then - - -- Requeue is to different PO - - Lock_Entries_With_Status (New_Object, Ceiling_Violation); - - if Ceiling_Violation then - Object.Call_In_Progress := null; - Queuing.Broadcast_Program_Error (Self_Id, Object, Entry_Call); - - else - PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call); - PO_Service_Entries (Self_Id, New_Object); - end if; - - else - -- Requeue is to same protected object - - -- ??? Try to compensate apparent failure of the scheduler on some - -- OS (e.g VxWorks) to give higher priority tasks a chance to run - -- (see CXD6002). - - STPO.Yield (Do_Yield => False); - - if Entry_Call.With_Abort - and then Entry_Call.Cancellation_Attempted - then - -- If this is a requeue with abort and someone tried to cancel - -- this call, cancel it at this point. - - Entry_Call.State := Cancelled; - return; - end if; - - if not Entry_Call.With_Abort - or else Entry_Call.Mode /= Conditional_Call - then - E := Protected_Entry_Index (Entry_Call.E); - - if Run_Time_Restrictions.Set (Max_Entry_Queue_Length) - and then - Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <= - Queuing.Count_Waiting (Object.Entry_Queues (E)) - then - -- This violates the Max_Entry_Queue_Length restriction, - -- raise Program_Error. - - Entry_Call.Exception_To_Raise := Program_Error'Identity; - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Entry_Call.Self); - Initialization.Wakeup_Entry_Caller - (Self_Id, Entry_Call, Done); - STPO.Unlock (Entry_Call.Self); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - else - Queuing.Enqueue - (New_Object.Entry_Queues (E), Entry_Call); - Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort); - end if; - - else - PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call); - end if; - end if; - end if; - end Requeue_Call; - - ---------------------------- - -- Protected_Entry_Caller -- - ---------------------------- - - function Protected_Entry_Caller - (Object : Protection_Entries'Class) return Task_Id is - begin - return Object.Call_In_Progress.Self; - end Protected_Entry_Caller; - - ----------------------------- - -- Requeue_Protected_Entry -- - ----------------------------- - - -- Compiler interface only (do not call from within the RTS) - - -- entry e when b is - -- begin - -- b := false; - -- ...A... - -- requeue e2; - -- end e; - - -- procedure rPT__E10b (O : address; P : address; E : - -- protected_entry_index) is - -- type rTVP is access rTV; - -- freeze rTVP [] - -- _object : rTVP := rTVP!(O); - -- begin - -- declare - -- rR : protection renames _object._object; - -- vP : integer renames _object.v; - -- bP : boolean renames _object.b; - -- begin - -- b := false; - -- ...A... - -- requeue_protected_entry (rR'unchecked_access, rR' - -- unchecked_access, 2, false, objectF => 0, new_objectF => - -- 0); - -- return; - -- end; - -- complete_entry_body (_object._object'unchecked_access, objectF => - -- 0); - -- return; - -- exception - -- when others => - -- abort_undefer.all; - -- exceptional_complete_entry_body (_object._object' - -- unchecked_access, current_exception, objectF => 0); - -- return; - -- end rPT__E10b; - - procedure Requeue_Protected_Entry - (Object : Protection_Entries_Access; - New_Object : Protection_Entries_Access; - E : Protected_Entry_Index; - With_Abort : Boolean) - is - Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; - - begin - pragma Debug - (Debug.Trace (STPO.Self, "Requeue_Protected_Entry", 'P')); - pragma Assert (STPO.Self.Deferral_Level > 0); - - Entry_Call.E := Entry_Index (E); - Entry_Call.Called_PO := To_Address (New_Object); - Entry_Call.Called_Task := null; - Entry_Call.With_Abort := With_Abort; - Object.Call_In_Progress := null; - end Requeue_Protected_Entry; - - ------------------------------------- - -- Requeue_Task_To_Protected_Entry -- - ------------------------------------- - - -- Compiler interface only (do not call from within the RTS) - - -- accept e1 do - -- ...A... - -- requeue r.e2; - -- end e1; - - -- A79b : address; - -- L78b : label - - -- begin - -- accept_call (1, A79b); - -- ...A... - -- requeue_task_to_protected_entry (rTV!(r)._object' - -- unchecked_access, 2, false, new_objectF => 0); - -- goto L78b; - -- <> - -- complete_rendezvous; - - -- exception - -- when all others => - -- exceptional_complete_rendezvous (get_gnat_exception); - -- end; - - procedure Requeue_Task_To_Protected_Entry - (New_Object : Protection_Entries_Access; - E : Protected_Entry_Index; - With_Abort : Boolean) - is - Self_ID : constant Task_Id := STPO.Self; - Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call; - - begin - Initialization.Defer_Abort (Self_ID); - - -- We do not need to lock Self_ID here since the call is not abortable - -- at this point, and therefore, the caller cannot cancel the call. - - Entry_Call.Needs_Requeue := True; - Entry_Call.With_Abort := With_Abort; - Entry_Call.Called_PO := To_Address (New_Object); - Entry_Call.Called_Task := null; - Entry_Call.E := Entry_Index (E); - Initialization.Undefer_Abort (Self_ID); - end Requeue_Task_To_Protected_Entry; - - --------------------- - -- Service_Entries -- - --------------------- - - procedure Service_Entries (Object : Protection_Entries_Access) is - Self_ID : constant Task_Id := STPO.Self; - begin - PO_Service_Entries (Self_ID, Object); - end Service_Entries; - - -------------------------------- - -- Timed_Protected_Entry_Call -- - -------------------------------- - - -- Compiler interface only (do not call from within the RTS) - - procedure Timed_Protected_Entry_Call - (Object : Protection_Entries_Access; - E : Protected_Entry_Index; - Uninterpreted_Data : System.Address; - Timeout : Duration; - Mode : Delay_Modes; - Entry_Call_Successful : out Boolean) - is - Self_Id : constant Task_Id := STPO.Self; - Entry_Call : Entry_Call_Link; - Ceiling_Violation : Boolean; - - Yielded : Boolean; - pragma Unreferenced (Yielded); - - begin - if Self_Id.ATC_Nesting_Level = ATC_Level'Last then - raise Storage_Error with "not enough ATC nesting levels"; - end if; - - -- If pragma Detect_Blocking is active then Program_Error must be - -- raised if this potentially blocking operation is called from a - -- protected action. - - if Detect_Blocking - and then Self_Id.Common.Protected_Action_Nesting > 0 - then - raise Program_Error with "potentially blocking operation"; - end if; - - Initialization.Defer_Abort_Nestable (Self_Id); - Lock_Entries_With_Status (Object, Ceiling_Violation); - - if Ceiling_Violation then - Initialization.Undefer_Abort (Self_Id); - raise Program_Error; - end if; - - Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; - pragma Debug - (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " & - ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); - Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; - Entry_Call.Next := null; - Entry_Call.Mode := Timed_Call; - Entry_Call.Cancellation_Attempted := False; - - Entry_Call.State := - (if Self_Id.Deferral_Level > 1 - then Never_Abortable - else Now_Abortable); - - Entry_Call.E := Entry_Index (E); - Entry_Call.Prio := STPO.Get_Priority (Self_Id); - Entry_Call.Uninterpreted_Data := Uninterpreted_Data; - Entry_Call.Called_PO := To_Address (Object); - Entry_Call.Called_Task := null; - Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; - Entry_Call.With_Abort := True; - - PO_Do_Or_Queue (Self_Id, Object, Entry_Call); - PO_Service_Entries (Self_Id, Object); - - if Single_Lock then - STPO.Lock_RTS; - else - STPO.Write_Lock (Self_Id); - end if; - - -- Try to avoid waiting for completed or cancelled calls - - if Entry_Call.State >= Done then - Utilities.Exit_One_ATC_Level (Self_Id); - - if Single_Lock then - STPO.Unlock_RTS; - else - STPO.Unlock (Self_Id); - end if; - - Entry_Call_Successful := Entry_Call.State = Done; - Initialization.Undefer_Abort_Nestable (Self_Id); - Entry_Calls.Check_Exception (Self_Id, Entry_Call); - return; - end if; - - Entry_Calls.Wait_For_Completion_With_Timeout - (Entry_Call, Timeout, Mode, Yielded); - - if Single_Lock then - STPO.Unlock_RTS; - else - STPO.Unlock (Self_Id); - end if; - - -- ??? Do we need to yield in case Yielded is False - - Initialization.Undefer_Abort_Nestable (Self_Id); - Entry_Call_Successful := Entry_Call.State = Done; - Entry_Calls.Check_Exception (Self_Id, Entry_Call); - end Timed_Protected_Entry_Call; - - ---------------------------- - -- Update_For_Queue_To_PO -- - ---------------------------- - - -- Update the state of an existing entry call, based on - -- whether the current queuing action is with or without abort. - -- Call this only while holding the server's lock. - -- It returns with the server's lock released. - - New_State : constant array (Boolean, Entry_Call_State) - of Entry_Call_State := - (True => - (Never_Abortable => Never_Abortable, - Not_Yet_Abortable => Now_Abortable, - Was_Abortable => Now_Abortable, - Now_Abortable => Now_Abortable, - Done => Done, - Cancelled => Cancelled), - False => - (Never_Abortable => Never_Abortable, - Not_Yet_Abortable => Not_Yet_Abortable, - Was_Abortable => Was_Abortable, - Now_Abortable => Now_Abortable, - Done => Done, - Cancelled => Cancelled) - ); - - procedure Update_For_Queue_To_PO - (Entry_Call : Entry_Call_Link; - With_Abort : Boolean) - is - Old : constant Entry_Call_State := Entry_Call.State; - - begin - pragma Assert (Old < Done); - - Entry_Call.State := New_State (With_Abort, Entry_Call.State); - - if Entry_Call.Mode = Asynchronous_Call then - if Old < Was_Abortable and then - Entry_Call.State = Now_Abortable - then - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Entry_Call.Self); - - if Entry_Call.Self.Common.State = Async_Select_Sleep then - STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); - end if; - - STPO.Unlock (Entry_Call.Self); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - end if; - - elsif Entry_Call.Mode = Conditional_Call then - pragma Assert (Entry_Call.State < Was_Abortable); - null; - end if; - end Update_For_Queue_To_PO; - -end System.Tasking.Protected_Objects.Operations; diff --git a/gcc/ada/s-tpobop.ads b/gcc/ada/s-tpobop.ads deleted file mode 100644 index 9b67fbd4673..00000000000 --- a/gcc/ada/s-tpobop.ads +++ /dev/null @@ -1,213 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - --- This package contains all the extended primitives related to protected --- objects with entries. - --- The handling of protected objects with no entries is done in --- System.Tasking.Protected_Objects, the simple routines for protected --- objects with entries in System.Tasking.Protected_Objects.Entries. The --- split between Entries and Operations is needed to break circular --- dependencies inside the run time. - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes. - -with Ada.Exceptions; - -with System.Tasking.Protected_Objects.Entries; - -package System.Tasking.Protected_Objects.Operations is - pragma Elaborate_Body; - - type Communication_Block is private; - -- Objects of this type are passed between GNARL calls to allow RTS - -- information to be preserved. - - procedure Protected_Entry_Call - (Object : Entries.Protection_Entries_Access; - E : Protected_Entry_Index; - Uninterpreted_Data : System.Address; - Mode : Call_Modes; - Block : out Communication_Block); - -- Make a protected entry call to the specified object. - -- Pend a protected entry call on the protected object represented - -- by Object. A pended call is not queued; it may be executed immediately - -- or queued, depending on the state of the entry barrier. - -- - -- E - -- The index representing the entry to be called. - -- - -- Uninterpreted_Data - -- This will be returned by Next_Entry_Call when this call is serviced. - -- It can be used by the compiler to pass information between the - -- caller and the server, in particular entry parameters. - -- - -- Mode - -- The kind of call to be pended - -- - -- Block - -- Information passed between runtime calls by the compiler - - procedure Timed_Protected_Entry_Call - (Object : Entries.Protection_Entries_Access; - E : Protected_Entry_Index; - Uninterpreted_Data : System.Address; - Timeout : Duration; - Mode : Delay_Modes; - Entry_Call_Successful : out Boolean); - -- Same as the Protected_Entry_Call but with time-out specified. - -- This routines is used when we do not use ATC mechanism to implement - -- timed entry calls. - - procedure Service_Entries (Object : Entries.Protection_Entries_Access); - pragma Inline (Service_Entries); - - procedure PO_Service_Entries - (Self_ID : Task_Id; - Object : Entries.Protection_Entries_Access; - Unlock_Object : Boolean := True); - -- Service all entry queues of the specified object, executing the - -- corresponding bodies of any queued entry calls that are waiting - -- on True barriers. This is used when the state of a protected - -- object may have changed, in particular after the execution of - -- the statement sequence of a protected procedure. - -- - -- Note that servicing an entry may change the value of one or more - -- barriers, so this routine keeps checking barriers until all of - -- them are closed. - -- - -- This must be called with abort deferred and with the corresponding - -- object locked. - -- - -- If Unlock_Object is set True, then Object is unlocked on return, - -- otherwise Object remains locked and the caller is responsible for - -- the required unlock. - - procedure Complete_Entry_Body (Object : Entries.Protection_Entries_Access); - -- Called from within an entry body procedure, indicates that the - -- corresponding entry call has been serviced. - - procedure Exceptional_Complete_Entry_Body - (Object : Entries.Protection_Entries_Access; - Ex : Ada.Exceptions.Exception_Id); - -- Perform all of the functions of Complete_Entry_Body. In addition, - -- report in Ex the exception whose propagation terminated the entry - -- body to the runtime system. - - procedure Cancel_Protected_Entry_Call (Block : in out Communication_Block); - -- Attempt to cancel the most recent protected entry call. If the call is - -- not queued abortably, wait until it is or until it has completed. - -- If the call is actually cancelled, the called object will be - -- locked on return from this call. Get_Cancelled (Block) can be - -- used to determine if the cancellation took place; there - -- may be entries needing service in this case. - -- - -- Block passes information between this and other runtime calls. - - function Enqueued (Block : Communication_Block) return Boolean; - -- Returns True if the Protected_Entry_Call which returned the - -- specified Block object was queued; False otherwise. - - function Cancelled (Block : Communication_Block) return Boolean; - -- Returns True if the Protected_Entry_Call which returned the - -- specified Block object was cancelled, False otherwise. - - procedure Requeue_Protected_Entry - (Object : Entries.Protection_Entries_Access; - New_Object : Entries.Protection_Entries_Access; - E : Protected_Entry_Index; - With_Abort : Boolean); - -- If Object = New_Object, queue the protected entry call on Object - -- currently being serviced on the queue corresponding to the entry - -- represented by E. - -- - -- If Object /= New_Object, transfer the call to New_Object.E, - -- executing or queuing it as appropriate. - -- - -- With_Abort---True if the call is to be queued abortably, false - -- otherwise. - - procedure Requeue_Task_To_Protected_Entry - (New_Object : Entries.Protection_Entries_Access; - E : Protected_Entry_Index; - With_Abort : Boolean); - -- Transfer task entry call currently being serviced to entry E - -- on New_Object. - -- - -- With_Abort---True if the call is to be queued abortably, false - -- otherwise. - - function Protected_Count - (Object : Entries.Protection_Entries'Class; - E : Protected_Entry_Index) - return Natural; - -- Return the number of entry calls to E on Object - - function Protected_Entry_Caller - (Object : Entries.Protection_Entries'Class) return Task_Id; - -- Return value of E'Caller, where E is the protected entry currently - -- being handled. This will only work if called from within an entry - -- body, as required by the LRM (C.7.1(14)). - - -- For internal use only - - procedure PO_Do_Or_Queue - (Self_ID : Task_Id; - Object : Entries.Protection_Entries_Access; - Entry_Call : Entry_Call_Link); - -- This procedure either executes or queues an entry call, depending - -- on the status of the corresponding barrier. It assumes that abort - -- is deferred and that the specified object is locked. - -private - type Communication_Block is record - Self : Task_Id; - Enqueued : Boolean := True; - Cancelled : Boolean := False; - end record; - pragma Volatile (Communication_Block); - - -- When a program contains limited interfaces, the compiler generates the - -- predefined primitives associated with dispatching selects. One of the - -- parameters of these routines is of type Communication_Block. Even if - -- the program lacks implementing concurrent types, the tasking runtime is - -- dragged in unconditionally because of Communication_Block. To avoid this - -- case, the compiler uses type Dummy_Communication_Block which defined in - -- System.Soft_Links. If the structure of Communication_Block is changed, - -- the corresponding dummy type must be changed as well. - - -- The Communication_Block seems to be a relic. At the moment, the - -- compiler seems to be generating unnecessary conditional code based on - -- this block. See the code generated for async. select with task entry - -- call for another way of solving this ??? - -end System.Tasking.Protected_Objects.Operations; diff --git a/gcc/ada/s-tpopsp-posix-foreign.adb b/gcc/ada/s-tpopsp-posix-foreign.adb deleted file mode 100644 index 485abc5c953..00000000000 --- a/gcc/ada/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-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 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/s-tpopsp-posix.adb b/gcc/ada/s-tpopsp-posix.adb deleted file mode 100644 index af068e0bc22..00000000000 --- a/gcc/ada/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-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 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/s-tpopsp-solaris.adb b/gcc/ada/s-tpopsp-solaris.adb deleted file mode 100644 index 1d46e714cc4..00000000000 --- a/gcc/ada/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-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. -- --- -- ------------------------------------------------------------------------------- - --- 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/s-tpopsp-tls.adb b/gcc/ada/s-tpopsp-tls.adb deleted file mode 100644 index a82f7f38d3e..00000000000 --- a/gcc/ada/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-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 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/s-tpopsp-vxworks.adb b/gcc/ada/s-tpopsp-vxworks.adb deleted file mode 100644 index c3a23c26509..00000000000 --- a/gcc/ada/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-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 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/s-tporft.adb b/gcc/ada/s-tporft.adb deleted file mode 100644 index 2f22f8aaac9..00000000000 --- a/gcc/ada/s-tporft.adb +++ /dev/null @@ -1,100 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.REGISTER_FOREIGN_THREAD -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-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. -- --- -- ------------------------------------------------------------------------------- - -with System.Task_Info; --- Use for Unspecified_Task_Info - -with System.Soft_Links; --- used to initialize TSD for a C thread, in function Self - -with System.Multiprocessors; - -separate (System.Task_Primitives.Operations) -function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id is - Local_ATCB : aliased Ada_Task_Control_Block (0); - Self_Id : Task_Id; - Succeeded : Boolean; - -begin - -- This section is tricky. We must not call anything that might require - -- an ATCB, until the new ATCB is in place. In order to get an ATCB - -- immediately, we fake one, so that it is then possible to e.g allocate - -- memory (which might require accessing self). - - -- Record this as the Task_Id for the thread - - Local_ATCB.Common.LL.Thread := Thread; - Local_ATCB.Common.Current_Priority := System.Priority'First; - Specific.Set (Local_ATCB'Unchecked_Access); - - -- It is now safe to use an allocator - - Self_Id := new Ada_Task_Control_Block (0); - - -- Finish initialization - - Lock_RTS; - System.Tasking.Initialize_ATCB - (Self_Id, null, Null_Address, Null_Task, - Foreign_Task_Elaborated'Access, - System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU, null, - Task_Info.Unspecified_Task_Info, 0, 0, Self_Id, Succeeded); - Unlock_RTS; - pragma Assert (Succeeded); - - Self_Id.Master_of_Task := 0; - Self_Id.Master_Within := Self_Id.Master_of_Task + 1; - - for L in Self_Id.Entry_Calls'Range loop - Self_Id.Entry_Calls (L).Self := Self_Id; - Self_Id.Entry_Calls (L).Level := L; - end loop; - - Self_Id.Common.State := Runnable; - Self_Id.Awake_Count := 1; - - Self_Id.Common.Task_Image (1 .. 14) := "foreign thread"; - Self_Id.Common.Task_Image_Len := 14; - - -- Since this is not an ordinary Ada task, we will start out undeferred - - Self_Id.Deferral_Level := 0; - - -- We do not provide an alternate stack for foreign threads - - Self_Id.Common.Task_Alternate_Stack := Null_Address; - - System.Soft_Links.Create_TSD (Self_Id.Common.Compiler_Data); - - Enter_Task (Self_Id); - - return Self_Id; -end Register_Foreign_Thread; diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb deleted file mode 100644 index 9bdf7f82238..00000000000 --- a/gcc/ada/s-tposen.adb +++ /dev/null @@ -1,462 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-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. -- --- -- ------------------------------------------------------------------------------- - -pragma Style_Checks (All_Checks); --- Turn off subprogram ordering check, since restricted GNARLI subprograms are --- gathered together at end. - --- This package provides an optimized version of Protected_Objects.Operations --- and Protected_Objects.Entries making the following assumptions: - --- PO has only one entry --- There is only one caller at a time (No_Entry_Queue) --- There is no dynamic priority support (No_Dynamic_Priorities) --- No Abort Statements --- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) --- PO are at library level --- No Requeue --- None of the tasks will terminate (no need for finalization) - --- This interface is intended to be used in the ravenscar and restricted --- profiles, the compiler is responsible for ensuring that the conditions --- mentioned above are respected, except for the No_Entry_Queue restriction --- that is checked dynamically in this package, since the check cannot be --- performed at compile time, and is relatively cheap (see PO_Do_Or_Queue, --- Service_Entry). - -pragma Polling (Off); --- Turn off polling, we do not want polling to take place during tasking --- operations. It can cause infinite loops and other problems. - -pragma Suppress (All_Checks); --- Why is this required ??? - -with Ada.Exceptions; - -with System.Task_Primitives.Operations; -with System.Parameters; - -package body System.Tasking.Protected_Objects.Single_Entry is - - package STPO renames System.Task_Primitives.Operations; - - use Parameters; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Send_Program_Error (Entry_Call : Entry_Call_Link); - pragma Inline (Send_Program_Error); - -- Raise Program_Error in the caller of the specified entry call - - -------------------------- - -- Entry Calls Handling -- - -------------------------- - - procedure Wakeup_Entry_Caller (Entry_Call : Entry_Call_Link); - pragma Inline (Wakeup_Entry_Caller); - -- This is called at the end of service of an entry call, to abort the - -- caller if he is in an abortable part, and to wake up the caller if he - -- is on Entry_Caller_Sleep. Call it holding the lock of Entry_Call.Self. - - procedure Wait_For_Completion (Entry_Call : Entry_Call_Link); - pragma Inline (Wait_For_Completion); - -- This procedure suspends the calling task until the specified entry call - -- has either been completed or cancelled. On exit, the call will not be - -- queued. This waits for calls on protected entries. - -- Call this only when holding Self_ID locked. - - procedure Check_Exception - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link); - pragma Inline (Check_Exception); - -- Raise any pending exception from the Entry_Call. This should be called - -- at the end of every compiler interface procedure that implements an - -- entry call. The caller should not be holding any locks, or there will - -- be deadlock. - - procedure PO_Do_Or_Queue - (Object : Protection_Entry_Access; - Entry_Call : Entry_Call_Link); - -- This procedure executes or queues an entry call, depending on the status - -- of the corresponding barrier. The specified object is assumed locked. - - --------------------- - -- Check_Exception -- - --------------------- - - procedure Check_Exception - (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link) - is - pragma Warnings (Off, Self_ID); - - procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); - pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); - - use type Ada.Exceptions.Exception_Id; - - E : constant Ada.Exceptions.Exception_Id := - Entry_Call.Exception_To_Raise; - - begin - if E /= Ada.Exceptions.Null_Id then - Internal_Raise (E); - end if; - end Check_Exception; - - ------------------------ - -- Send_Program_Error -- - ------------------------ - - procedure Send_Program_Error (Entry_Call : Entry_Call_Link) is - Caller : constant Task_Id := Entry_Call.Self; - - begin - Entry_Call.Exception_To_Raise := Program_Error'Identity; - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Caller); - Wakeup_Entry_Caller (Entry_Call); - STPO.Unlock (Caller); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - end Send_Program_Error; - - ------------------------- - -- Wait_For_Completion -- - ------------------------- - - procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is - Self_Id : constant Task_Id := Entry_Call.Self; - begin - Self_Id.Common.State := Entry_Caller_Sleep; - STPO.Sleep (Self_Id, Entry_Caller_Sleep); - Self_Id.Common.State := Runnable; - end Wait_For_Completion; - - ------------------------- - -- Wakeup_Entry_Caller -- - ------------------------- - - -- This is called at the end of service of an entry call, to abort the - -- caller if he is in an abortable part, and to wake up the caller if it - -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue. - - -- (This enforces the rule that a task must be off-queue if its state is - -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self. - - -- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion. - - procedure Wakeup_Entry_Caller - (Entry_Call : Entry_Call_Link) - is - Caller : constant Task_Id := Entry_Call.Self; - begin - pragma Assert - (Caller.Common.State /= Terminated and then - Caller.Common.State /= Unactivated); - Entry_Call.State := Done; - STPO.Wakeup (Caller, Entry_Caller_Sleep); - end Wakeup_Entry_Caller; - - ----------------------- - -- Restricted GNARLI -- - ----------------------- - - -------------------------------------------- - -- Exceptional_Complete_Single_Entry_Body -- - -------------------------------------------- - - procedure Exceptional_Complete_Single_Entry_Body - (Object : Protection_Entry_Access; - Ex : Ada.Exceptions.Exception_Id) - is - begin - Object.Call_In_Progress.Exception_To_Raise := Ex; - end Exceptional_Complete_Single_Entry_Body; - - --------------------------------- - -- Initialize_Protection_Entry -- - --------------------------------- - - procedure Initialize_Protection_Entry - (Object : Protection_Entry_Access; - Ceiling_Priority : Integer; - Compiler_Info : System.Address; - Entry_Body : Entry_Body_Access) - is - begin - Initialize_Protection (Object.Common'Access, Ceiling_Priority); - - Object.Compiler_Info := Compiler_Info; - Object.Call_In_Progress := null; - Object.Entry_Body := Entry_Body; - Object.Entry_Queue := null; - end Initialize_Protection_Entry; - - ---------------- - -- Lock_Entry -- - ---------------- - - -- Compiler interface only - - -- Do not call this procedure from within the run-time system. - - procedure Lock_Entry (Object : Protection_Entry_Access) is - begin - Lock (Object.Common'Access); - end Lock_Entry; - - -------------------------- - -- Lock_Read_Only_Entry -- - -------------------------- - - -- Compiler interface only - - -- Do not call this procedure from within the runtime system - - procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is - begin - Lock_Read_Only (Object.Common'Access); - end Lock_Read_Only_Entry; - - -------------------- - -- PO_Do_Or_Queue -- - -------------------- - - procedure PO_Do_Or_Queue - (Object : Protection_Entry_Access; - Entry_Call : Entry_Call_Link) - is - Barrier_Value : Boolean; - - begin - -- When the Action procedure for an entry body returns, it must be - -- completed (having called [Exceptional_]Complete_Entry_Body). - - Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1); - - if Barrier_Value then - if Object.Call_In_Progress /= null then - - -- This violates the No_Entry_Queue restriction, send - -- Program_Error to the caller. - - Send_Program_Error (Entry_Call); - return; - end if; - - Object.Call_In_Progress := Entry_Call; - Object.Entry_Body.Action - (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); - Object.Call_In_Progress := null; - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Entry_Call.Self); - Wakeup_Entry_Caller (Entry_Call); - STPO.Unlock (Entry_Call.Self); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - else - pragma Assert (Entry_Call.Mode = Simple_Call); - - if Object.Entry_Queue /= null then - - -- This violates the No_Entry_Queue restriction, send - -- Program_Error to the caller. - - Send_Program_Error (Entry_Call); - return; - else - Object.Entry_Queue := Entry_Call; - end if; - - end if; - - exception - when others => - Send_Program_Error (Entry_Call); - end PO_Do_Or_Queue; - - ---------------------------- - -- Protected_Single_Count -- - ---------------------------- - - function Protected_Count_Entry (Object : Protection_Entry) return Natural is - begin - if Object.Entry_Queue /= null then - return 1; - else - return 0; - end if; - end Protected_Count_Entry; - - --------------------------------- - -- Protected_Single_Entry_Call -- - --------------------------------- - - procedure Protected_Single_Entry_Call - (Object : Protection_Entry_Access; - Uninterpreted_Data : System.Address) - is - Self_Id : constant Task_Id := STPO.Self; - Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); - begin - -- If pragma Detect_Blocking is active then Program_Error must be - -- raised if this potentially blocking operation is called from a - -- protected action. - - if Detect_Blocking - and then Self_Id.Common.Protected_Action_Nesting > 0 - then - raise Program_Error with "potentially blocking operation"; - end if; - - Lock_Entry (Object); - - Entry_Call.Mode := Simple_Call; - Entry_Call.State := Now_Abortable; - Entry_Call.Uninterpreted_Data := Uninterpreted_Data; - Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; - - PO_Do_Or_Queue (Object, Entry_Call'Access); - Unlock_Entry (Object); - - -- The call is either `Done' or not. It cannot be cancelled since there - -- is no ATC construct. - - pragma Assert (Entry_Call.State /= Cancelled); - - if Entry_Call.State /= Done then - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Self_Id); - Wait_For_Completion (Entry_Call'Access); - STPO.Unlock (Self_Id); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - end if; - - Check_Exception (Self_Id, Entry_Call'Access); - end Protected_Single_Entry_Call; - - ----------------------------------- - -- Protected_Single_Entry_Caller -- - ----------------------------------- - - function Protected_Single_Entry_Caller - (Object : Protection_Entry) return Task_Id - is - begin - return Object.Call_In_Progress.Self; - end Protected_Single_Entry_Caller; - - ------------------- - -- Service_Entry -- - ------------------- - - procedure Service_Entry (Object : Protection_Entry_Access) is - Entry_Call : constant Entry_Call_Link := Object.Entry_Queue; - Caller : Task_Id; - - begin - if Entry_Call /= null - and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1) - then - Object.Entry_Queue := null; - - if Object.Call_In_Progress /= null then - - -- Violation of No_Entry_Queue restriction, raise exception - - Send_Program_Error (Entry_Call); - Unlock_Entry (Object); - return; - end if; - - Object.Call_In_Progress := Entry_Call; - Object.Entry_Body.Action - (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); - Object.Call_In_Progress := null; - Caller := Entry_Call.Self; - Unlock_Entry (Object); - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Caller); - Wakeup_Entry_Caller (Entry_Call); - STPO.Unlock (Caller); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - else - -- Just unlock the entry - - Unlock_Entry (Object); - end if; - - exception - when others => - Send_Program_Error (Entry_Call); - Unlock_Entry (Object); - end Service_Entry; - - ------------------ - -- Unlock_Entry -- - ------------------ - - procedure Unlock_Entry (Object : Protection_Entry_Access) is - begin - Unlock (Object.Common'Access); - end Unlock_Entry; - -end System.Tasking.Protected_Objects.Single_Entry; diff --git a/gcc/ada/s-tposen.ads b/gcc/ada/s-tposen.ads deleted file mode 100644 index ea0513a1792..00000000000 --- a/gcc/ada/s-tposen.ads +++ /dev/null @@ -1,278 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-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 package provides an optimized version of Protected_Objects.Operations --- and Protected_Objects.Entries making the following assumptions: - --- PO have only one entry --- There is only one caller at a time (No_Entry_Queue) --- There is no dynamic priority support (No_Dynamic_Priorities) --- No Abort Statements --- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) --- PO are at library level --- None of the tasks will terminate (no need for finalization) - --- This interface is intended to be used in the Ravenscar profile, the --- compiler is responsible for ensuring that the conditions mentioned above --- are respected, except for the No_Entry_Queue restriction that is checked --- dynamically in this package, since the check cannot be performed at compile --- time, and is relatively cheap (see body). - --- This package is part of the high level tasking interface used by the --- compiler to expand Ada 95 tasking constructs into simpler run time calls --- (aka GNARLI, GNU Ada Run-time Library Interface) - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes --- in exp_ch9.adb and possibly exp_ch7.adb - -package System.Tasking.Protected_Objects.Single_Entry is - pragma Elaborate_Body; - - --------------------------------- - -- Compiler Interface (GNARLI) -- - --------------------------------- - - -- The compiler will expand in the GNAT tree the following construct: - - -- protected PO is - -- entry E; - -- procedure P; - -- private - -- Open : Boolean := False; - -- end PO; - - -- protected body PO is - -- entry E when Open is - -- ...variable declarations... - -- begin - -- ...B... - -- end E; - - -- procedure P is - -- ...variable declarations... - -- begin - -- ...C... - -- end P; - -- end PO; - - -- as follows: - - -- protected type poT is - -- entry e; - -- procedure p; - -- private - -- open : boolean := false; - -- end poT; - -- type poTV is limited record - -- open : boolean := false; - -- _object : aliased protection_entry; - -- end record; - -- procedure poPT__E1s (O : address; P : address; E : - -- protected_entry_index); - -- function poPT__B2s (O : address; E : protected_entry_index) return - -- boolean; - -- procedure poPT__pN (_object : in out poTV); - -- procedure poPT__pP (_object : in out poTV); - -- poTA : aliased entry_body := ( - -- barrier => poPT__B2s'unrestricted_access, - -- action => poPT__E1s'unrestricted_access); - -- freeze poTV [ - -- procedure poTVIP (_init : in out poTV) is - -- begin - -- _init.open := false; - -- object-init-proc (_init._object); - -- initialize_protection_entry (_init._object'unchecked_access, - -- unspecified_priority, _init'address, poTA' - -- unrestricted_access); - -- return; - -- end poTVIP; - -- ] - -- po : poT; - -- poTVIP (poTV!(po)); - - -- function poPT__B2s (O : address; E : protected_entry_index) return - -- boolean is - -- type poTVP is access poTV; - -- _object : poTVP := poTVP!(O); - -- poR : protection_entry renames _object._object; - -- openP : boolean renames _object.open; - -- begin - -- return open; - -- end poPT__B2s; - - -- procedure poPT__E1s (O : address; P : address; E : - -- protected_entry_index) is - -- type poTVP is access poTV; - -- _object : poTVP := poTVP!(O); - -- begin - -- B1b : declare - -- poR : protection_entry renames _object._object; - -- openP : boolean renames _object.open; - -- ...variable declarations... - -- begin - -- ...B... - -- end B1b; - -- complete_single_entry_body (_object._object'unchecked_access); - -- return; - -- exception - -- when all others => - -- exceptional_complete_single_entry_body (_object._object' - -- unchecked_access, get_gnat_exception); - -- return; - -- end poPT__E1s; - - -- procedure poPT__pN (_object : in out poTV) is - -- poR : protection_entry renames _object._object; - -- openP : boolean renames _object.open; - -- ...variable declarations... - -- begin - -- ...C... - -- return; - -- end poPT__pN; - - -- procedure poPT__pP (_object : in out poTV) is - -- procedure _clean is - -- begin - -- service_entry (_object._object'unchecked_access); - -- return; - -- end _clean; - -- begin - -- lock_entry (_object._object'unchecked_access); - -- B5b : begin - -- poPT__pN (_object); - -- at end - -- _clean; - -- end B5b; - -- return; - -- end poPT__pP; - - type Protection_Entry is limited private; - -- This type contains the GNARL state of a protected object. The - -- application-defined portion of the state (i.e. private objects) - -- is maintained by the compiler-generated code. - - type Protection_Entry_Access is access all Protection_Entry; - - type Entry_Body_Access is access constant Entry_Body; - -- Access to barrier and action function of an entry - - procedure Initialize_Protection_Entry - (Object : Protection_Entry_Access; - Ceiling_Priority : Integer; - Compiler_Info : System.Address; - Entry_Body : Entry_Body_Access); - -- Initialize the Object parameter so that it can be used by the run time - -- to keep track of the runtime state of a protected object. - - procedure Lock_Entry (Object : Protection_Entry_Access); - -- Lock a protected object for write access. Upon return, the caller owns - -- the lock to this object, and no other call to Lock or Lock_Read_Only - -- with the same argument will return until the corresponding call to - -- Unlock has been made by the caller. - - procedure Lock_Read_Only_Entry - (Object : Protection_Entry_Access); - -- Lock a protected object for read access. Upon return, the caller owns - -- the lock for read access, and no other calls to Lock with the same - -- argument will return until the corresponding call to Unlock has been - -- made by the caller. Other calls to Lock_Read_Only may (but need not) - -- return before the call to Unlock, and the corresponding callers will - -- also own the lock for read access. - - procedure Unlock_Entry (Object : Protection_Entry_Access); - -- Relinquish ownership of the lock for the object represented by the - -- Object parameter. If this ownership was for write access, or if it was - -- for read access where there are no other read access locks outstanding, - -- one (or more, in the case of Lock_Read_Only) of the tasks waiting on - -- this lock (if any) will be given the lock and allowed to return from - -- the Lock or Lock_Read_Only call. - - procedure Service_Entry (Object : Protection_Entry_Access); - -- Service the entry queue of the specified object, executing the - -- corresponding body of any queued entry call that is waiting on True - -- barrier. This is used when the state of a protected object may have - -- changed, in particular after the execution of the statement sequence - -- of a protected procedure. - -- - -- This must be called with abort deferred and with the corresponding - -- object locked. Object is unlocked on return. - - procedure Protected_Single_Entry_Call - (Object : Protection_Entry_Access; - Uninterpreted_Data : System.Address); - -- Make a protected entry call to the specified object - -- - -- Pends a protected entry call on the protected object represented by - -- Object. A pended call is not queued; it may be executed immediately - -- or queued, depending on the state of the entry barrier. - -- - -- Uninterpreted_Data - -- This will be returned by Next_Entry_Call when this call is serviced. - -- It can be used by the compiler to pass information between the - -- caller and the server, in particular entry parameters. - - procedure Exceptional_Complete_Single_Entry_Body - (Object : Protection_Entry_Access; - Ex : Ada.Exceptions.Exception_Id); - -- Perform all of the functions of Complete_Entry_Body. In addition, report - -- in Ex the exception whose propagation terminated the entry body to the - -- runtime system. - - function Protected_Count_Entry (Object : Protection_Entry) return Natural; - -- Return the number of entry calls on Object (0 or 1) - - function Protected_Single_Entry_Caller - (Object : Protection_Entry) return Task_Id; - -- Return value of E'Caller, where E is the protected entry currently being - -- handled. This will only work if called from within an entry body, as - -- required by the LRM (C.7.1(14)). - -private - type Protection_Entry is record - Common : aliased Protection; - -- State of the protected object. This part is common to any protected - -- object, including those without entries. - - Compiler_Info : System.Address; - -- Pointer to compiler-generated record representing protected object - - Call_In_Progress : Entry_Call_Link; - -- Pointer to the entry call being executed (if any) - - Entry_Body : Entry_Body_Access; - -- Pointer to executable code for the entry body of the protected type - - Entry_Queue : Entry_Call_Link; - -- Place to store the waiting entry call (if any) - end record; - -end System.Tasking.Protected_Objects.Single_Entry; diff --git a/gcc/ada/s-vxwext-kernel.adb b/gcc/ada/s-vxwext-kernel.adb deleted file mode 100644 index 404e9aaa946..00000000000 --- a/gcc/ada/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-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 -- --- . -- --- -- ------------------------------------------------------------------------------- - --- 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/s-vxwext-kernel.ads b/gcc/ada/s-vxwext-kernel.ads deleted file mode 100644 index dfdbcf19544..00000000000 --- a/gcc/ada/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-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 -- --- . -- --- -- ------------------------------------------------------------------------------- - --- 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/s-vxwext-rtp.adb b/gcc/ada/s-vxwext-rtp.adb deleted file mode 100644 index 4dd7ab46c95..00000000000 --- a/gcc/ada/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-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 -- --- . -- --- -- ------------------------------------------------------------------------------- - --- 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/s-vxwext-rtp.ads b/gcc/ada/s-vxwext-rtp.ads deleted file mode 100644 index 4b658f69434..00000000000 --- a/gcc/ada/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-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 -- --- . -- --- -- ------------------------------------------------------------------------------- - --- 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/s-vxwext.adb b/gcc/ada/s-vxwext.adb deleted file mode 100644 index a386af91d0f..00000000000 --- a/gcc/ada/s-vxwext.adb +++ /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 . E X T -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2011, 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 is the VxWorks 5 and VxWorks MILS version of this package - -package body System.VxWorks.Ext is - - ERROR : constant := -1; - - ------------------------ - -- 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/s-vxwext.ads b/gcc/ada/s-vxwext.ads deleted file mode 100644 index 1aea52739e3..00000000000 --- a/gcc/ada/s-vxwext.ads +++ /dev/null @@ -1,105 +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-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 -- --- . -- --- -- ------------------------------------------------------------------------------- - --- This package provides vxworks specific support functions needed --- by System.OS_Interface. - --- This is the VxWorks 5 and VxWorks MILS 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 Import (C, Int_Lock, "intLock"); - - function Int_Unlock (Old : int) return int; - pragma Import (C, Int_Unlock, "intUnlock"); - - 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 Import (C, semDelete, "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"); - - -------------------------------- - -- 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/s-vxwork-arm.ads b/gcc/ada/s-vxwork-arm.ads deleted file mode 100644 index 8c4cf7e53e2..00000000000 --- a/gcc/ada/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-2013, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License 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/s-vxwork-ppc.ads b/gcc/ada/s-vxwork-ppc.ads deleted file mode 100644 index 2c25e2ce38a..00000000000 --- a/gcc/ada/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-2012, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License 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/s-vxwork-x86.ads b/gcc/ada/s-vxwork-x86.ads deleted file mode 100644 index fac24f316fd..00000000000 --- a/gcc/ada/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-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 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/thread.c b/gcc/ada/thread.c deleted file mode 100644 index bd3cfa6af48..00000000000 --- a/gcc/ada/thread.c +++ /dev/null @@ -1,88 +0,0 @@ -/**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * P T H R E A D * - * * - * C Implementation File * - * * - * Copyright (C) 2011-2014, 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 file provides utility functions to access the threads API */ - -#include "s-oscons.h" - -/* If the clock we used for tasking (CLOCK_RT_Ada) is not the default - * CLOCK_REALTIME, we need to set cond var attributes accordingly. - */ -#if CLOCK_RT_Ada != CLOCK_REALTIME -# include -# include - -int -__gnat_pthread_condattr_setup(pthread_condattr_t *attr) { - return pthread_condattr_setclock (attr, CLOCK_RT_Ada); -} - -#else - -int -__gnat_pthread_condattr_setup (void *attr) { - /* Dummy version for other platforms, which may or may not have pthread.h */ - return 0; -} - -#endif - -#if defined (__APPLE__) -#include -#include -#endif - -/* Return the clock ticks per nanosecond for Posix systems lacking the - Posix extension function clock_getres, or else 0 nsecs on error. */ - -int -__gnat_clock_get_res (void) -{ -#if defined (__APPLE__) - clock_serv_t clock_port; - mach_msg_type_number_t count; - int nsecs; - int result; - - count = 1; - result = host_get_clock_service - (mach_host_self (), SYSTEM_CLOCK, &clock_port); - - if (result == KERN_SUCCESS) - result = clock_get_attributes (clock_port, CLOCK_GET_TIME_RES, - (clock_attr_t) &nsecs, &count); - - if (result == KERN_SUCCESS) - return nsecs; -#endif - - return 0; -}