+2017-09-08 Nicolas Roche <roche@adacore.com>
+
+ * 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 <charlet@adacore.com>
* doc/share/conf.py, doc/share/latex_elements.py,
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . E X E C U T I O N _ T I M E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2007-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Darwin version of this package
-
-with Ada.Task_Identification; use Ada.Task_Identification;
-with Ada.Unchecked_Conversion;
-
-with System.Tasking;
-with System.OS_Interface; use System.OS_Interface;
-with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
-
-with Interfaces.C; use Interfaces.C;
-
-package body Ada.Execution_Time is
-
- ---------
- -- "+" --
- ---------
-
- function "+"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Ada.Real_Time.Time (Left) + Right);
- end "+";
-
- function "+"
- (Left : Ada.Real_Time.Time_Span;
- Right : CPU_Time) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Left + Ada.Real_Time.Time (Right));
- end "+";
-
- ---------
- -- "-" --
- ---------
-
- function "-"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Ada.Real_Time.Time (Left) - Right);
- end "-";
-
- function "-"
- (Left : CPU_Time;
- Right : CPU_Time) return Ada.Real_Time.Time_Span
- is
- use type Ada.Real_Time.Time;
- begin
- return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
- end "-";
-
- -----------
- -- Clock --
- -----------
-
- function Clock
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task) return CPU_Time
- is
- function Convert_Ids is new
- Ada.Unchecked_Conversion (Task_Id, System.Tasking.Task_Id);
-
- function To_CPU_Time is
- new Ada.Unchecked_Conversion (Duration, CPU_Time);
- -- Time is equal to Duration (although it is a private type) and
- -- CPU_Time is equal to Time.
-
- subtype integer_t is Interfaces.C.int;
- subtype mach_port_t is integer_t;
- -- Type definition for Mach.
-
- type time_value_t is record
- seconds : integer_t;
- microseconds : integer_t;
- end record;
- pragma Convention (C, time_value_t);
- -- Mach time_value_t
-
- type thread_basic_info_t is record
- user_time : time_value_t;
- system_time : time_value_t;
- cpu_usage : integer_t;
- policy : integer_t;
- run_state : integer_t;
- flags : integer_t;
- suspend_count : integer_t;
- sleep_time : integer_t;
- end record;
- pragma Convention (C, thread_basic_info_t);
- -- Mach structure from thread_info.h
-
- THREAD_BASIC_INFO : constant := 3;
- THREAD_BASIC_INFO_COUNT : constant := 10;
- -- Flavors for basic info
-
- function thread_info (Target : mach_port_t;
- Flavor : integer_t;
- Thread_Info : System.Address;
- Count : System.Address) return integer_t;
- pragma Import (C, thread_info);
- -- Mach call to get info on a thread
-
- function pthread_mach_thread_np (Thread : pthread_t) return mach_port_t;
- pragma Import (C, pthread_mach_thread_np);
- -- Get Mach thread from posix thread
-
- Result : Interfaces.C.int;
- Thread : pthread_t;
- Port : mach_port_t;
- Ti : thread_basic_info_t;
- Count : integer_t;
- begin
- if T = Ada.Task_Identification.Null_Task_Id then
- raise Program_Error;
- end if;
-
- Thread := Get_Thread_Id (Convert_Ids (T));
- Port := pthread_mach_thread_np (Thread);
- pragma Assert (Port > 0);
-
- Count := THREAD_BASIC_INFO_COUNT;
- Result := thread_info (Port, THREAD_BASIC_INFO,
- Ti'Address, Count'Address);
- pragma Assert (Result = 0);
- pragma Assert (Count = THREAD_BASIC_INFO_COUNT);
-
- return To_CPU_Time
- (Duration (Ti.user_time.seconds + Ti.system_time.seconds)
- + Duration (Ti.user_time.microseconds
- + Ti.system_time.microseconds) / 1E6);
- end Clock;
-
- --------------------------
- -- Clock_For_Interrupts --
- --------------------------
-
- function Clock_For_Interrupts return CPU_Time is
- begin
- -- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
- -- is set to False the function raises Program_Error.
-
- raise Program_Error;
- return CPU_Time_First;
- end Clock_For_Interrupts;
-
- -----------
- -- Split --
- -----------
-
- procedure Split
- (T : CPU_Time;
- SC : out Ada.Real_Time.Seconds_Count;
- TS : out Ada.Real_Time.Time_Span)
- is
- use type Ada.Real_Time.Time;
- begin
- Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
- end Split;
-
- -------------
- -- Time_Of --
- -------------
-
- function Time_Of
- (SC : Ada.Real_Time.Seconds_Count;
- TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
- return CPU_Time
- is
- begin
- return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
- end Time_Of;
-
-end Ada.Execution_Time;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . E X E C U T I O N _ T I M E --
--- --
--- S p e c --
--- --
--- Copyright (C) 2007-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Task_Identification;
-with Ada.Real_Time;
-
-package Ada.Execution_Time with
- SPARK_Mode
-is
-
- type CPU_Time is private;
-
- CPU_Time_First : constant CPU_Time;
- CPU_Time_Last : constant CPU_Time;
- CPU_Time_Unit : constant := Ada.Real_Time.Time_Unit;
- CPU_Tick : constant Ada.Real_Time.Time_Span;
-
- use type Ada.Task_Identification.Task_Id;
-
- function Clock
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task)
- return CPU_Time
- with
- Volatile_Function,
- Global => Ada.Real_Time.Clock_Time,
- Pre => T /= Ada.Task_Identification.Null_Task_Id;
-
- function "+"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- with
- Global => null;
-
- function "+"
- (Left : Ada.Real_Time.Time_Span;
- Right : CPU_Time) return CPU_Time
- with
- Global => null;
-
- function "-"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- with
- Global => null;
-
- function "-"
- (Left : CPU_Time;
- Right : CPU_Time) return Ada.Real_Time.Time_Span
- with
- Global => null;
-
- function "<" (Left, Right : CPU_Time) return Boolean with
- Global => null;
- function "<=" (Left, Right : CPU_Time) return Boolean with
- Global => null;
- function ">" (Left, Right : CPU_Time) return Boolean with
- Global => null;
- function ">=" (Left, Right : CPU_Time) return Boolean with
- Global => null;
-
- procedure Split
- (T : CPU_Time;
- SC : out Ada.Real_Time.Seconds_Count;
- TS : out Ada.Real_Time.Time_Span)
- with
- Global => null;
-
- function Time_Of
- (SC : Ada.Real_Time.Seconds_Count;
- TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
- return CPU_Time
- with
- Global => null;
-
- Interrupt_Clocks_Supported : constant Boolean := False;
- Separate_Interrupt_Clocks_Supported : constant Boolean := False;
-
- pragma Warnings (Off, "check will fail at run time");
- function Clock_For_Interrupts return CPU_Time with
- Volatile_Function,
- Global => Ada.Real_Time.Clock_Time,
- Pre => Interrupt_Clocks_Supported;
- pragma Warnings (On, "check will fail at run time");
-
-private
- pragma SPARK_Mode (Off);
-
- type CPU_Time is new Ada.Real_Time.Time;
-
- CPU_Time_First : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_First);
- CPU_Time_Last : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_Last);
-
- CPU_Tick : constant Ada.Real_Time.Time_Span := Ada.Real_Time.Tick;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
-
-end Ada.Execution_Time;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . E X E C U T I O N _ T I M E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2007-2012, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Windows native version of this package
-
-with Ada.Task_Identification; use Ada.Task_Identification;
-with Ada.Unchecked_Conversion;
-
-with System.OS_Interface; use System.OS_Interface;
-with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
-with System.Tasking; use System.Tasking;
-with System.Win32; use System.Win32;
-
-package body Ada.Execution_Time with
- SPARK_Mode => Off
-is
-
- ---------
- -- "+" --
- ---------
-
- function "+"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Ada.Real_Time.Time (Left) + Right);
- end "+";
-
- function "+"
- (Left : Ada.Real_Time.Time_Span;
- Right : CPU_Time) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Left + Ada.Real_Time.Time (Right));
- end "+";
-
- ---------
- -- "-" --
- ---------
-
- function "-"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Ada.Real_Time.Time (Left) - Right);
- end "-";
-
- function "-"
- (Left : CPU_Time;
- Right : CPU_Time) return Ada.Real_Time.Time_Span
- is
- use type Ada.Real_Time.Time;
- begin
- return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
- end "-";
-
- -----------
- -- Clock --
- -----------
-
- function Clock
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task) return CPU_Time
- is
- Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7;
-
- function To_Time is new Ada.Unchecked_Conversion
- (Duration, Ada.Real_Time.Time);
-
- function To_Task_Id is new Ada.Unchecked_Conversion
- (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id);
-
- C_Time : aliased Long_Long_Integer;
- E_Time : aliased Long_Long_Integer;
- K_Time : aliased Long_Long_Integer;
- U_Time : aliased Long_Long_Integer;
- Res : BOOL;
-
- begin
- if T = Ada.Task_Identification.Null_Task_Id then
- raise Program_Error;
- end if;
-
- Res :=
- GetThreadTimes
- (HANDLE (Get_Thread_Id (To_Task_Id (T))),
- C_Time'Access, E_Time'Access, K_Time'Access, U_Time'Access);
-
- if Res = System.Win32.FALSE then
- raise Program_Error;
- end if;
-
- return
- CPU_Time
- (To_Time
- (Duration
- ((Long_Long_Float (K_Time) / Hundreds_Nano_In_Sec)
- + (Long_Long_Float (U_Time) / Hundreds_Nano_In_Sec))));
- end Clock;
-
- --------------------------
- -- Clock_For_Interrupts --
- --------------------------
-
- function Clock_For_Interrupts return CPU_Time is
- begin
- -- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
- -- is set to False the function raises Program_Error.
-
- raise Program_Error;
- return CPU_Time_First;
- end Clock_For_Interrupts;
-
- -----------
- -- Split --
- -----------
-
- procedure Split
- (T : CPU_Time;
- SC : out Ada.Real_Time.Seconds_Count;
- TS : out Ada.Real_Time.Time_Span)
- is
- use type Ada.Real_Time.Time;
- begin
- Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
- end Split;
-
- -------------
- -- Time_Of --
- -------------
-
- function Time_Of
- (SC : Ada.Real_Time.Seconds_Count;
- TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
- return CPU_Time
- is
- begin
- return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
- end Time_Of;
-
-end Ada.Execution_Time;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . E X E C U T I O N _ T I M E --
--- --
--- S p e c --
--- --
--- Copyright (C) 2009-2017, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Windows native version of this package
-
-with Ada.Task_Identification;
-with Ada.Real_Time;
-
-package Ada.Execution_Time with
- SPARK_Mode
-is
- type CPU_Time is private;
-
- CPU_Time_First : constant CPU_Time;
- CPU_Time_Last : constant CPU_Time;
- CPU_Time_Unit : constant := 0.000001;
- CPU_Tick : constant Ada.Real_Time.Time_Span;
-
- use type Ada.Task_Identification.Task_Id;
-
- function Clock
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task)
- return CPU_Time
- with
- Volatile_Function,
- Global => Ada.Real_Time.Clock_Time,
- Pre => T /= Ada.Task_Identification.Null_Task_Id;
-
- function "+"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- with
- Global => null;
-
- function "+"
- (Left : Ada.Real_Time.Time_Span;
- Right : CPU_Time) return CPU_Time
- with
- Global => null;
-
- function "-"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- with
- Global => null;
-
- function "-"
- (Left : CPU_Time;
- Right : CPU_Time) return Ada.Real_Time.Time_Span
- with
- Global => null;
-
- function "<" (Left, Right : CPU_Time) return Boolean with
- Global => null;
- function "<=" (Left, Right : CPU_Time) return Boolean with
- Global => null;
- function ">" (Left, Right : CPU_Time) return Boolean with
- Global => null;
- function ">=" (Left, Right : CPU_Time) return Boolean with
- Global => null;
-
- procedure Split
- (T : CPU_Time;
- SC : out Ada.Real_Time.Seconds_Count;
- TS : out Ada.Real_Time.Time_Span)
- with
- Global => null;
-
- function Time_Of
- (SC : Ada.Real_Time.Seconds_Count;
- TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
- return CPU_Time
- with
- Global => null;
-
- Interrupt_Clocks_Supported : constant Boolean := False;
- Separate_Interrupt_Clocks_Supported : constant Boolean := False;
-
- pragma Warnings (Off, "check will fail at run time");
- function Clock_For_Interrupts return CPU_Time with
- Volatile_Function,
- Global => Ada.Real_Time.Clock_Time,
- Pre => Interrupt_Clocks_Supported;
- pragma Warnings (On, "check will fail at run time");
-
-private
- pragma SPARK_Mode (Off);
-
- type CPU_Time is new Ada.Real_Time.Time;
-
- CPU_Time_First : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_First);
- CPU_Time_Last : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_Last);
-
- CPU_Tick : constant Ada.Real_Time.Time_Span := Ada.Real_Time.Tick;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
-
-end Ada.Execution_Time;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . E X E C U T I O N _ T I M E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2007-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the POSIX (Realtime Extension) version of this package
-
-with Ada.Task_Identification; use Ada.Task_Identification;
-with Ada.Unchecked_Conversion;
-
-with System.Tasking;
-with System.OS_Interface; use System.OS_Interface;
-with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
-
-with Interfaces.C; use Interfaces.C;
-
-package body Ada.Execution_Time is
-
- pragma Linker_Options ("-lrt");
- -- POSIX.1b Realtime Extensions library. Needed to have access to function
- -- clock_gettime.
-
- ---------
- -- "+" --
- ---------
-
- function "+"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Ada.Real_Time.Time (Left) + Right);
- end "+";
-
- function "+"
- (Left : Ada.Real_Time.Time_Span;
- Right : CPU_Time) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Left + Ada.Real_Time.Time (Right));
- end "+";
-
- ---------
- -- "-" --
- ---------
-
- function "-"
- (Left : CPU_Time;
- Right : Ada.Real_Time.Time_Span) return CPU_Time
- is
- use type Ada.Real_Time.Time;
- begin
- return CPU_Time (Ada.Real_Time.Time (Left) - Right);
- end "-";
-
- function "-"
- (Left : CPU_Time;
- Right : CPU_Time) return Ada.Real_Time.Time_Span
- is
- use type Ada.Real_Time.Time;
- begin
- return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
- end "-";
-
- -----------
- -- Clock --
- -----------
-
- function Clock
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task) return CPU_Time
- is
- TS : aliased timespec;
- Clock_Id : aliased Interfaces.C.int;
- Result : Interfaces.C.int;
-
- function To_CPU_Time is
- new Ada.Unchecked_Conversion (Duration, CPU_Time);
- -- Time is equal to Duration (although it is a private type) and
- -- CPU_Time is equal to Time.
-
- function Convert_Ids is new
- Ada.Unchecked_Conversion (Task_Id, System.Tasking.Task_Id);
-
- function clock_gettime
- (clock_id : Interfaces.C.int;
- tp : access timespec)
- return int;
- pragma Import (C, clock_gettime, "clock_gettime");
- -- Function from the POSIX.1b Realtime Extensions library
-
- function pthread_getcpuclockid
- (tid : Thread_Id;
- clock_id : access Interfaces.C.int)
- return int;
- pragma Import (C, pthread_getcpuclockid, "pthread_getcpuclockid");
- -- Function from the Thread CPU-Time Clocks option
-
- begin
- if T = Ada.Task_Identification.Null_Task_Id then
- raise Program_Error;
- else
- -- Get the CPU clock for the task passed as parameter
-
- Result := pthread_getcpuclockid
- (Get_Thread_Id (Convert_Ids (T)), Clock_Id'Access);
- pragma Assert (Result = 0);
- end if;
-
- Result := clock_gettime
- (clock_id => Clock_Id, tp => TS'Unchecked_Access);
- pragma Assert (Result = 0);
-
- return To_CPU_Time (To_Duration (TS));
- end Clock;
-
- --------------------------
- -- Clock_For_Interrupts --
- --------------------------
-
- function Clock_For_Interrupts return CPU_Time is
- begin
- -- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
- -- is set to False the function raises Program_Error.
-
- raise Program_Error;
- return CPU_Time_First;
- end Clock_For_Interrupts;
-
- -----------
- -- Split --
- -----------
-
- procedure Split
- (T : CPU_Time;
- SC : out Ada.Real_Time.Seconds_Count;
- TS : out Ada.Real_Time.Time_Span)
- is
-
- begin
- Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
- end Split;
-
- -------------
- -- Time_Of --
- -------------
-
- function Time_Of
- (SC : Ada.Real_Time.Seconds_Count;
- TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
- return CPU_Time
- is
- begin
- return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
- end Time_Of;
-
-end Ada.Execution_Time;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . E X E C U T I O N _ T I M E --
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . I N T E R R U P T S . N A M E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2011, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a AIX version of this package
-
--- The following signals are reserved by the run time (native threads):
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGEMT
--- SIGSTOP, SIGKILL
-
--- The following signals are reserved by the run time (FSU threads):
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGALRM,
--- SIGWAITING, SIGSTOP, SIGKILL
-
--- The pragma Unreserve_All_Interrupts affects the following signal(s):
-
--- SIGINT: made available for Ada handler
-
--- This target-dependent package spec contains names of interrupts
--- supported by the local system.
-
-with System.OS_Interface;
-
-package Ada.Interrupts.Names is
-
- -- All identifiers in this unit are implementation defined
-
- pragma Implementation_Defined;
-
- -- Beware that the mapping of names to signals may be many-to-one. There
- -- may be aliases. Also, for all signal names that are not supported on
- -- the current system the value of the corresponding constant will be zero.
-
- SIGHUP : constant Interrupt_ID :=
- System.OS_Interface.SIGHUP; -- hangup
-
- SIGINT : constant Interrupt_ID :=
- System.OS_Interface.SIGINT; -- interrupt (rubout)
-
- SIGQUIT : constant Interrupt_ID :=
- System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
-
- SIGILL : constant Interrupt_ID :=
- System.OS_Interface.SIGILL; -- illegal instruction (not reset)
-
- SIGTRAP : constant Interrupt_ID :=
- System.OS_Interface.SIGTRAP; -- trace trap (not reset)
-
- SIGIOT : constant Interrupt_ID :=
- System.OS_Interface.SIGIOT; -- IOT instruction
-
- SIGABRT : constant Interrupt_ID := -- used by abort,
- System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
-
- SIGEMT : constant Interrupt_ID :=
- System.OS_Interface.SIGEMT; -- EMT instruction
-
- SIGFPE : constant Interrupt_ID :=
- System.OS_Interface.SIGFPE; -- floating point exception
-
- SIGKILL : constant Interrupt_ID :=
- System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
-
- SIGBUS : constant Interrupt_ID :=
- System.OS_Interface.SIGBUS; -- bus error
-
- SIGSEGV : constant Interrupt_ID :=
- System.OS_Interface.SIGSEGV; -- segmentation violation
-
- SIGSYS : constant Interrupt_ID :=
- System.OS_Interface.SIGSYS; -- bad argument to system call
-
- SIGPIPE : constant Interrupt_ID := -- write on a pipe with
- System.OS_Interface.SIGPIPE; -- no one to read it
-
- SIGALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGALRM; -- alarm clock
-
- SIGTERM : constant Interrupt_ID :=
- System.OS_Interface.SIGTERM; -- software termination signal from kill
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
- SIGCLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCLD; -- child status change
-
- SIGCHLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
-
- SIGPWR : constant Interrupt_ID :=
- System.OS_Interface.SIGPWR; -- power-fail restart
-
- SIGWINCH : constant Interrupt_ID :=
- System.OS_Interface.SIGWINCH; -- window size change
-
- SIGURG : constant Interrupt_ID :=
- System.OS_Interface.SIGURG; -- urgent condition on IO channel
-
- SIGPOLL : constant Interrupt_ID :=
- System.OS_Interface.SIGPOLL; -- pollable event occurred
-
- SIGIO : constant Interrupt_ID := -- input/output possible,
- System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
-
- SIGSTOP : constant Interrupt_ID :=
- System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
-
- SIGTSTP : constant Interrupt_ID :=
- System.OS_Interface.SIGTSTP; -- user stop requested from tty
-
- SIGCONT : constant Interrupt_ID :=
- System.OS_Interface.SIGCONT; -- stopped process has been continued
-
- SIGTTIN : constant Interrupt_ID :=
- System.OS_Interface.SIGTTIN; -- background tty read attempted
-
- SIGTTOU : constant Interrupt_ID :=
- System.OS_Interface.SIGTTOU; -- background tty write attempted
-
- SIGVTALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGVTALRM; -- virtual timer expired
-
- SIGPROF : constant Interrupt_ID :=
- System.OS_Interface.SIGPROF; -- profiling timer expired
-
- SIGXCPU : constant Interrupt_ID :=
- System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
-
- SIGXFSZ : constant Interrupt_ID :=
- System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
-
- SIGMSG : constant Interrupt_ID :=
- System.OS_Interface.SIGMSG; -- input data is in the ring buffer
-
- SIGDANGER : constant Interrupt_ID :=
- System.OS_Interface.SIGDANGER; -- system crash imminent;
-
- SIGMIGRATE : constant Interrupt_ID :=
- System.OS_Interface.SIGMIGRATE; -- migrate process
-
- SIGPRE : constant Interrupt_ID :=
- System.OS_Interface.SIGPRE; -- programming exception
-
- SIGVIRT : constant Interrupt_ID :=
- System.OS_Interface.SIGVIRT; -- AIX virtual time alarm
-
- SIGALRM1 : constant Interrupt_ID :=
- System.OS_Interface.SIGALRM1; -- m:n condition variables
-
- SIGWAITING : constant Interrupt_ID :=
- System.OS_Interface.SIGWAITING; -- m:n scheduling
-
- SIGKAP : constant Interrupt_ID :=
- System.OS_Interface.SIGKAP; -- keep alive poll from native keyboard
-
- SIGGRANT : constant Interrupt_ID :=
- System.OS_Interface.SIGGRANT; -- monitor mode granted
-
- SIGRETRACT : constant Interrupt_ID :=
- System.OS_Interface.SIGRETRACT; -- monitor mode should be relinquished
-
- SIGSOUND : constant Interrupt_ID :=
- System.OS_Interface.SIGSOUND; -- sound control has completed
-
- SIGSAK : constant Interrupt_ID :=
- System.OS_Interface.SIGSAK; -- secure attention key
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . I N T E R R U P T S . N A M E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2011, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Darwin version of this package
-
--- The following signals are reserved by the run time:
-
--- SIGSTOP, SIGKILL
-
--- The pragma Unreserve_All_Interrupts affects the following signal(s):
-
--- SIGINT: made available for Ada handler
-
--- This target-dependent package spec contains names of interrupts
--- supported by the local system.
-
-with System.OS_Interface;
-
-package Ada.Interrupts.Names is
-
- -- All identifiers in this unit are implementation defined
-
- pragma Implementation_Defined;
-
- -- Beware that the mapping of names to signals may be many-to-one. There
- -- may be aliases. Also, for all signal names that are not supported on the
- -- current system the value of the corresponding constant will be zero.
-
- SIGHUP : constant Interrupt_ID :=
- System.OS_Interface.SIGHUP; -- hangup
-
- SIGINT : constant Interrupt_ID :=
- System.OS_Interface.SIGINT; -- interrupt (rubout)
-
- SIGQUIT : constant Interrupt_ID :=
- System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
-
- SIGILL : constant Interrupt_ID :=
- System.OS_Interface.SIGILL; -- illegal instruction (not reset)
-
- SIGTRAP : constant Interrupt_ID :=
- System.OS_Interface.SIGTRAP; -- trace trap (not reset)
-
- SIGIOT : constant Interrupt_ID :=
- System.OS_Interface.SIGIOT; -- IOT instruction
-
- SIGABRT : constant Interrupt_ID := -- used by abort,
- System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
-
- SIGEMT : constant Interrupt_ID :=
- System.OS_Interface.SIGEMT; -- EMT instruction
-
- SIGFPE : constant Interrupt_ID :=
- System.OS_Interface.SIGFPE; -- floating point exception
-
- SIGKILL : constant Interrupt_ID :=
- System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
-
- SIGBUS : constant Interrupt_ID :=
- System.OS_Interface.SIGBUS; -- bus error
-
- SIGSEGV : constant Interrupt_ID :=
- System.OS_Interface.SIGSEGV; -- segmentation violation
-
- SIGSYS : constant Interrupt_ID :=
- System.OS_Interface.SIGSYS; -- bad argument to system call
-
- SIGPIPE : constant Interrupt_ID := -- write on a pipe with
- System.OS_Interface.SIGPIPE; -- no one to read it
-
- SIGALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGALRM; -- alarm clock
-
- SIGTERM : constant Interrupt_ID :=
- System.OS_Interface.SIGTERM; -- software termination signal from kill
-
- SIGURG : constant Interrupt_ID :=
- System.OS_Interface.SIGURG; -- urgent condition on IO channel
-
- SIGSTOP : constant Interrupt_ID :=
- System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
-
- SIGTSTP : constant Interrupt_ID :=
- System.OS_Interface.SIGTSTP; -- user stop requested from tty
-
- SIGCONT : constant Interrupt_ID :=
- System.OS_Interface.SIGCONT; -- stopped process has been continued
-
- SIGCHLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
-
- SIGTTIN : constant Interrupt_ID :=
- System.OS_Interface.SIGTTIN; -- background tty read attempted
-
- SIGTTOU : constant Interrupt_ID :=
- System.OS_Interface.SIGTTOU; -- background tty write attempted
-
- SIGIO : constant Interrupt_ID := -- input/output possible,
- System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
-
- SIGXCPU : constant Interrupt_ID :=
- System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
-
- SIGXFSZ : constant Interrupt_ID :=
- System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
-
- SIGVTALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGVTALRM; -- virtual timer expired
-
- SIGPROF : constant Interrupt_ID :=
- System.OS_Interface.SIGPROF; -- profiling timer expired
-
- SIGWINCH : constant Interrupt_ID :=
- System.OS_Interface.SIGWINCH; -- window size change
-
- SIGINFO : constant Interrupt_ID :=
- System.OS_Interface.SIGINFO; -- information request
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . I N T E R R U P T S . N A M E S --
--- --
--- S p e c --
--- (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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- The standard implementation of this spec contains only dummy interrupt
--- names. These dummy entries permit checking out code for correctness of
--- semantics, even if interrupts are not supported.
-
--- For specific implementations that fully support interrupts, this package
--- spec is replaced by an implementation dependent version that defines the
--- interrupts available on the system.
-
-package Ada.Interrupts.Names is
-
- -- All identifiers in this unit are implementation defined
-
- pragma Implementation_Defined;
-
- DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1;
- DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2;
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . I N T E R R U P T S . N A M E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2011, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the FreeBSD THREADS version of this package
-
-with System.OS_Interface;
-
-package Ada.Interrupts.Names is
-
- -- All identifiers in this unit are implementation defined
-
- pragma Implementation_Defined;
-
- -- Beware that the mapping of names to signals may be many-to-one. There
- -- may be aliases. Also, for all signal names that are not supported on
- -- the current system the value of the corresponding constant will be zero.
-
- SIGHUP : constant Interrupt_ID :=
- System.OS_Interface.SIGHUP; -- hangup
-
- SIGINT : constant Interrupt_ID :=
- System.OS_Interface.SIGINT; -- interrupt (rubout)
-
- SIGQUIT : constant Interrupt_ID :=
- System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
-
- SIGILL : constant Interrupt_ID :=
- System.OS_Interface.SIGILL; -- illegal instruction (not reset)
-
- SIGTRAP : constant Interrupt_ID :=
- System.OS_Interface.SIGTRAP; -- trace trap (not reset)
-
- SIGIOT : constant Interrupt_ID :=
- System.OS_Interface.SIGIOT; -- IOT instruction
-
- SIGABRT : constant Interrupt_ID := -- used by abort,
- System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
-
- SIGFPE : constant Interrupt_ID :=
- System.OS_Interface.SIGFPE; -- floating point exception
-
- SIGKILL : constant Interrupt_ID :=
- System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
-
- SIGBUS : constant Interrupt_ID :=
- System.OS_Interface.SIGBUS; -- bus error
-
- SIGSEGV : constant Interrupt_ID :=
- System.OS_Interface.SIGSEGV; -- segmentation violation
-
- SIGPIPE : constant Interrupt_ID := -- write on a pipe with
- System.OS_Interface.SIGPIPE; -- no one to read it
-
- SIGALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGALRM; -- alarm clock
-
- SIGTERM : constant Interrupt_ID :=
- System.OS_Interface.SIGTERM; -- software termination signal from kill
-
- SIGURG : constant Interrupt_ID :=
- System.OS_Interface.SIGURG; -- urgent condition on IO channel
-
- SIGSTOP : constant Interrupt_ID :=
- System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
-
- SIGTSTP : constant Interrupt_ID :=
- System.OS_Interface.SIGTSTP; -- user stop requested from tty
-
- SIGCONT : constant Interrupt_ID :=
- System.OS_Interface.SIGCONT; -- stopped process has been continued
-
- SIGCHLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
-
- SIGCLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCLD; -- child status change
-
- SIGTTIN : constant Interrupt_ID :=
- System.OS_Interface.SIGTTIN; -- background tty read attempted
-
- SIGTTOU : constant Interrupt_ID :=
- System.OS_Interface.SIGTTOU; -- background tty write attempted
-
- SIGIO : constant Interrupt_ID := -- input/output possible,
- System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
-
- SIGXCPU : constant Interrupt_ID :=
- System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
-
- SIGXFSZ : constant Interrupt_ID :=
- System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
-
- SIGVTALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGVTALRM; -- virtual timer expired
-
- SIGPROF : constant Interrupt_ID :=
- System.OS_Interface.SIGPROF; -- profiling timer expired
-
- SIGWINCH : constant Interrupt_ID :=
- System.OS_Interface.SIGWINCH; -- window size change
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . I N T E R R U P T S . N A M E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2011, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a HP-UX version of this package
-
--- The following signals are reserved by the run time:
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT,
--- SIGALRM, SIGSTOP, SIGKILL
-
--- The pragma Unreserve_All_Interrupts affects the following signal(s):
-
--- SIGINT: made available for Ada handler
-
--- This target-dependent package spec contains names of interrupts
--- supported by the local system.
-
-with System.OS_Interface;
-
-package Ada.Interrupts.Names is
-
- -- All identifiers in this unit are implementation defined
-
- pragma Implementation_Defined;
-
- -- Beware that the mapping of names to signals may be many-to-one. There
- -- may be aliases. Also, for all signal names that are not supported on
- -- the current system the value of the corresponding constant will be zero.
-
- SIGHUP : constant Interrupt_ID :=
- System.OS_Interface.SIGHUP; -- hangup
-
- SIGINT : constant Interrupt_ID :=
- System.OS_Interface.SIGINT; -- interrupt (rubout)
-
- SIGQUIT : constant Interrupt_ID :=
- System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
-
- SIGILL : constant Interrupt_ID :=
- System.OS_Interface.SIGILL; -- illegal instruction (not reset)
-
- SIGTRAP : constant Interrupt_ID :=
- System.OS_Interface.SIGTRAP; -- trace trap (not reset)
-
- SIGIOT : constant Interrupt_ID :=
- System.OS_Interface.SIGIOT; -- IOT instruction
-
- SIGABRT : constant Interrupt_ID := -- used by abort,
- System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
-
- SIGEMT : constant Interrupt_ID :=
- System.OS_Interface.SIGEMT; -- EMT instruction
-
- SIGFPE : constant Interrupt_ID :=
- System.OS_Interface.SIGFPE; -- floating point exception
-
- SIGKILL : constant Interrupt_ID :=
- System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
-
- SIGBUS : constant Interrupt_ID :=
- System.OS_Interface.SIGBUS; -- bus error
-
- SIGSEGV : constant Interrupt_ID :=
- System.OS_Interface.SIGSEGV; -- segmentation violation
-
- SIGSYS : constant Interrupt_ID :=
- System.OS_Interface.SIGSYS; -- bad argument to system call
-
- SIGPIPE : constant Interrupt_ID := -- write on a pipe with
- System.OS_Interface.SIGPIPE; -- no one to read it
-
- SIGALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGALRM; -- alarm clock
-
- SIGTERM : constant Interrupt_ID :=
- System.OS_Interface.SIGTERM; -- software termination signal from kill
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
- SIGCLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCLD; -- child status change
-
- SIGCHLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
-
- SIGWINCH : constant Interrupt_ID :=
- System.OS_Interface.SIGWINCH; -- window size change
-
- SIGURG : constant Interrupt_ID :=
- System.OS_Interface.SIGURG; -- urgent condition on IO channel
-
- SIGPOLL : constant Interrupt_ID :=
- System.OS_Interface.SIGPOLL; -- pollable event occurred
-
- SIGIO : constant Interrupt_ID := -- input/output possible,
- System.OS_Interface.SIGIO; -- SIGPOLL alias
-
- SIGSTOP : constant Interrupt_ID :=
- System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
-
- SIGTSTP : constant Interrupt_ID :=
- System.OS_Interface.SIGTSTP; -- user stop requested from tty
-
- SIGCONT : constant Interrupt_ID :=
- System.OS_Interface.SIGCONT; -- stopped process has been continued
-
- SIGTTIN : constant Interrupt_ID :=
- System.OS_Interface.SIGTTIN; -- background tty read attempted
-
- SIGTTOU : constant Interrupt_ID :=
- System.OS_Interface.SIGTTOU; -- background tty write attempted
-
- SIGVTALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGVTALRM; -- virtual timer expired
-
- SIGPROF : constant Interrupt_ID :=
- System.OS_Interface.SIGPROF; -- profiling timer expired
-
- SIGPWR : constant Interrupt_ID :=
- System.OS_Interface.SIGPWR; -- power-fail restart
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . I N T E R R U P T S . N A M E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a GNU/Linux version of this package
-
--- The following signals are reserved by the run time:
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
--- SIGUSR1, SIGUSR2, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL
-
--- The pragma Unreserve_All_Interrupts affects the following signal(s):
-
--- SIGINT: made available for Ada handler
-
--- This target-dependent package spec contains names of interrupts
--- supported by the local system.
-
-with System.OS_Interface;
-
-package Ada.Interrupts.Names is
-
- -- All identifiers in this unit are implementation defined
-
- pragma Implementation_Defined;
-
- -- Beware that the mapping of names to signals may be many-to-one. There
- -- may be aliases. Also, for all signal names that are not supported on the
- -- current system the value of the corresponding constant will be zero.
-
- SIGHUP : constant Interrupt_ID :=
- System.OS_Interface.SIGHUP; -- hangup
-
- SIGINT : constant Interrupt_ID :=
- System.OS_Interface.SIGINT; -- interrupt (rubout)
-
- SIGQUIT : constant Interrupt_ID :=
- System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
-
- SIGILL : constant Interrupt_ID :=
- System.OS_Interface.SIGILL; -- illegal instruction (not reset)
-
- SIGTRAP : constant Interrupt_ID :=
- System.OS_Interface.SIGTRAP; -- trace trap (not reset)
-
- SIGIOT : constant Interrupt_ID :=
- System.OS_Interface.SIGIOT; -- IOT instruction
-
- SIGABRT : constant Interrupt_ID := -- used by abort,
- System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
-
- SIGFPE : constant Interrupt_ID :=
- System.OS_Interface.SIGFPE; -- floating point exception
-
- SIGKILL : constant Interrupt_ID :=
- System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
-
- SIGBUS : constant Interrupt_ID :=
- System.OS_Interface.SIGBUS; -- bus error
-
- SIGSEGV : constant Interrupt_ID :=
- System.OS_Interface.SIGSEGV; -- segmentation violation
-
- SIGPIPE : constant Interrupt_ID := -- write on a pipe with
- System.OS_Interface.SIGPIPE; -- no one to read it
-
- SIGALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGALRM; -- alarm clock
-
- SIGTERM : constant Interrupt_ID :=
- System.OS_Interface.SIGTERM; -- software termination signal from kill
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
- SIGCLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCLD; -- child status change
-
- SIGCHLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
-
- SIGWINCH : constant Interrupt_ID :=
- System.OS_Interface.SIGWINCH; -- window size change
-
- SIGURG : constant Interrupt_ID :=
- System.OS_Interface.SIGURG; -- urgent condition on IO channel
-
- SIGPOLL : constant Interrupt_ID :=
- System.OS_Interface.SIGPOLL; -- pollable event occurred
-
- SIGIO : constant Interrupt_ID := -- input/output possible,
- System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
-
- SIGSTOP : constant Interrupt_ID :=
- System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
-
- SIGTSTP : constant Interrupt_ID :=
- System.OS_Interface.SIGTSTP; -- user stop requested from tty
-
- SIGCONT : constant Interrupt_ID :=
- System.OS_Interface.SIGCONT; -- stopped process has been continued
-
- SIGTTIN : constant Interrupt_ID :=
- System.OS_Interface.SIGTTIN; -- background tty read attempted
-
- SIGTTOU : constant Interrupt_ID :=
- System.OS_Interface.SIGTTOU; -- background tty write attempted
-
- SIGVTALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGVTALRM; -- virtual timer expired
-
- SIGPROF : constant Interrupt_ID :=
- System.OS_Interface.SIGPROF; -- profiling timer expired
-
- SIGXCPU : constant Interrupt_ID :=
- System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
-
- SIGXFSZ : constant Interrupt_ID :=
- System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
-
- SIGUNUSED : constant Interrupt_ID :=
- System.OS_Interface.SIGUNUSED; -- unused signal
-
- SIGSTKFLT : constant Interrupt_ID :=
- System.OS_Interface.SIGSTKFLT; -- stack fault on coprocessor
-
- SIGLOST : constant Interrupt_ID :=
- System.OS_Interface.SIGLOST; -- Linux alias for SIGIO
-
- SIGPWR : constant Interrupt_ID :=
- System.OS_Interface.SIGPWR; -- Power failure
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . I N T E R R U P T S . N A M E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a NT (native) version of this package
-
--- This target-dependent package spec contains names of interrupts supported
--- by the local system.
-
-with System.OS_Interface;
-
-package Ada.Interrupts.Names is
-
- -- All identifiers in this unit are implementation defined
-
- pragma Implementation_Defined;
-
- -- Beware that the mapping of names to signals may be many-to-one. There
- -- may be aliases. Also, for all signal names that are not supported on the
- -- current system the value of the corresponding constant will be zero.
-
- SIGINT : constant Interrupt_ID := -- interrupt (rubout)
- System.OS_Interface.SIGINT;
-
- SIGILL : constant Interrupt_ID := -- illegal instruction (not reset)
- System.OS_Interface.SIGILL;
-
- SIGABRT : constant Interrupt_ID := -- used by abort (use SIGIOT in future)
- System.OS_Interface.SIGABRT;
-
- SIGFPE : constant Interrupt_ID := -- floating point exception
- System.OS_Interface.SIGFPE;
-
- SIGSEGV : constant Interrupt_ID := -- segmentation violation
- System.OS_Interface.SIGSEGV;
-
- SIGTERM : constant Interrupt_ID := -- software termination signal from kill
- System.OS_Interface.SIGTERM;
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a Solaris version of this package
-
--- The following signals are reserved by the run time (native threads):
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
--- SIGLWP, SIGWAITING, SIGCANCEL, SIGSTOP, SIGKILL
-
--- The following signals are reserved by the run time (FSU threads):
-
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT,
--- SIGLWP, SIGALRM, SIGVTALRM, SIGWAITING, SIGSTOP, SIGKILL
-
--- The pragma Unreserve_All_Interrupts affects the following signal(s):
-
--- SIGINT: made available for Ada handlers
-
-with System.OS_Interface;
-
-package Ada.Interrupts.Names is
-
- -- All identifiers in this unit are implementation defined
-
- pragma Implementation_Defined;
-
- -- Beware that the mapping of names to signals may be many-to-one. There
- -- may be aliases. Also, for all signal names that are not supported on the
- -- current system the value of the corresponding constant will be zero.
-
- SIGHUP : constant Interrupt_ID :=
- System.OS_Interface.SIGHUP; -- hangup
-
- SIGINT : constant Interrupt_ID :=
- System.OS_Interface.SIGINT; -- interrupt (rubout)
-
- SIGQUIT : constant Interrupt_ID :=
- System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
-
- SIGILL : constant Interrupt_ID :=
- System.OS_Interface.SIGILL; -- illegal instruction (not reset)
-
- SIGTRAP : constant Interrupt_ID :=
- System.OS_Interface.SIGTRAP; -- trace trap (not reset)
-
- SIGIOT : constant Interrupt_ID :=
- System.OS_Interface.SIGIOT; -- IOT instruction
-
- SIGABRT : constant Interrupt_ID := -- used by abort,
- System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
-
- SIGEMT : constant Interrupt_ID :=
- System.OS_Interface.SIGEMT; -- EMT instruction
-
- SIGFPE : constant Interrupt_ID :=
- System.OS_Interface.SIGFPE; -- floating point exception
-
- SIGKILL : constant Interrupt_ID :=
- System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
-
- SIGBUS : constant Interrupt_ID :=
- System.OS_Interface.SIGBUS; -- bus error
-
- SIGSEGV : constant Interrupt_ID :=
- System.OS_Interface.SIGSEGV; -- segmentation violation
-
- SIGSYS : constant Interrupt_ID :=
- System.OS_Interface.SIGSYS; -- bad argument to system call
-
- SIGPIPE : constant Interrupt_ID := -- write on a pipe with
- System.OS_Interface.SIGPIPE; -- no one to read it
-
- SIGALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGALRM; -- alarm clock
-
- SIGTERM : constant Interrupt_ID :=
- System.OS_Interface.SIGTERM; -- software termination signal from kill
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
- SIGCLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCLD; -- child status change
-
- SIGCHLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
-
- SIGWINCH : constant Interrupt_ID :=
- System.OS_Interface.SIGWINCH; -- window size change
-
- SIGURG : constant Interrupt_ID :=
- System.OS_Interface.SIGURG; -- urgent condition on IO channel
-
- SIGPOLL : constant Interrupt_ID :=
- System.OS_Interface.SIGPOLL; -- pollable event occurred
-
- SIGIO : constant Interrupt_ID := -- input/output possible,
- System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
-
- SIGSTOP : constant Interrupt_ID :=
- System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
-
- SIGTSTP : constant Interrupt_ID :=
- System.OS_Interface.SIGTSTP; -- user stop requested from tty
-
- SIGCONT : constant Interrupt_ID :=
- System.OS_Interface.SIGCONT; -- stopped process has been continued
-
- SIGTTIN : constant Interrupt_ID :=
- System.OS_Interface.SIGTTIN; -- background tty read attempted
-
- SIGTTOU : constant Interrupt_ID :=
- System.OS_Interface.SIGTTOU; -- background tty write attempted
-
- SIGVTALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGVTALRM; -- virtual timer expired
-
- SIGPROF : constant Interrupt_ID :=
- System.OS_Interface.SIGPROF; -- profiling timer expired
-
- SIGXCPU : constant Interrupt_ID :=
- System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
-
- SIGXFSZ : constant Interrupt_ID :=
- System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
-
- SIGPWR : constant Interrupt_ID :=
- System.OS_Interface.SIGPWR; -- power-fail restart
-
- SIGWAITING : constant Interrupt_ID :=
- System.OS_Interface.SIGWAITING; -- process's lwps blocked (Solaris)
-
- SIGLWP : constant Interrupt_ID :=
- System.OS_Interface.SIGLWP; -- used by thread library (Solaris)
-
- SIGFREEZE : constant Interrupt_ID :=
- System.OS_Interface.SIGFREEZE; -- used by CPR (Solaris)
-
--- what is CPR????
-
- SIGTHAW : constant Interrupt_ID :=
- System.OS_Interface.SIGTHAW; -- used by CPR (Solaris)
-
- SIGCANCEL : constant Interrupt_ID :=
- System.OS_Interface.SIGCANCEL; -- used for thread cancel (Solaris)
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . I N T E R R U P T S . N A M E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1998-2011, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the VxWorks version of this package
-
-with System.OS_Interface;
-
-package Ada.Interrupts.Names is
-
- -- All identifiers in this unit are implementation defined
-
- pragma Implementation_Defined;
-
- subtype Hardware_Interrupts is Interrupt_ID
- range Interrupt_ID'First .. System.OS_Interface.Max_HW_Interrupt;
- -- Range of values that can be used for hardware interrupts
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- The standard implementation of this spec contains only dummy interrupt
--- names. These dummy entries permit checking out code for correctness of
--- semantics, even if interrupts are not supported.
-
--- For specific implementations that fully support interrupts, this package
--- spec is replaced by an implementation dependent version that defines the
--- interrupts available on the system.
-
-package Ada.Interrupts.Names is
-
- -- All identifiers in this unit are implementation defined
-
- pragma Implementation_Defined;
-
- DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1;
- DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2;
-
-end Ada.Interrupts.Names;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S Y N C H R O N O U S _ B A R R I E R S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the body of this package using POSIX barriers
-
-with Interfaces.C; use Interfaces.C;
-
-package body Ada.Synchronous_Barriers is
-
- --------------------
- -- POSIX barriers --
- --------------------
-
- function pthread_barrier_init
- (barrier : not null access pthread_barrier_t;
- attr : System.Address := System.Null_Address;
- count : unsigned) return int;
- pragma Import (C, pthread_barrier_init, "pthread_barrier_init");
- -- Initialize barrier with the attributes in attr. The barrier is opened
- -- when count waiters arrived. If attr is null the default barrier
- -- attributes are used.
-
- function pthread_barrier_destroy
- (barrier : not null access pthread_barrier_t) return int;
- pragma Import (C, pthread_barrier_destroy, "pthread_barrier_destroy");
- -- Destroy a previously dynamically initialized barrier
-
- function pthread_barrier_wait
- (barrier : not null access pthread_barrier_t) return int;
- pragma Import (C, pthread_barrier_wait, "pthread_barrier_wait");
- -- Wait on barrier
-
- --------------
- -- Finalize --
- --------------
-
- overriding procedure Finalize (Barrier : in out Synchronous_Barrier) is
- Result : int;
- begin
- Result := pthread_barrier_destroy (Barrier.POSIX_Barrier'Access);
- pragma Assert (Result = 0);
- end Finalize;
-
- overriding procedure Initialize (Barrier : in out Synchronous_Barrier) is
- Result : int;
- begin
- Result :=
- pthread_barrier_init
- (barrier => Barrier.POSIX_Barrier'Access,
- attr => System.Null_Address,
- count => unsigned (Barrier.Release_Threshold));
- pragma Assert (Result = 0);
- end Initialize;
-
- ----------------------
- -- Wait_For_Release --
- ----------------------
-
- procedure Wait_For_Release
- (The_Barrier : in out Synchronous_Barrier;
- Notified : out Boolean)
- is
- Result : int;
-
- PTHREAD_BARRIER_SERIAL_THREAD : constant := -1;
- -- Value used to indicate the task which receives the notification for
- -- the barrier open.
-
- begin
- Result :=
- pthread_barrier_wait
- (barrier => The_Barrier.POSIX_Barrier'Access);
- pragma Assert
- (Result = 0 or else Result = PTHREAD_BARRIER_SERIAL_THREAD);
-
- Notified := (Result = PTHREAD_BARRIER_SERIAL_THREAD);
- end Wait_For_Release;
-
-end Ada.Synchronous_Barriers;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S Y N C H R O N O U S _ B A R R I E R S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the spec of this package using POSIX barriers
-
-with System;
-private with Ada.Finalization;
-private with Interfaces.C;
-
-package Ada.Synchronous_Barriers is
- pragma Preelaborate (Synchronous_Barriers);
-
- subtype Barrier_Limit is Positive range 1 .. Positive'Last;
-
- type Synchronous_Barrier (Release_Threshold : Barrier_Limit) is
- limited private;
-
- procedure Wait_For_Release
- (The_Barrier : in out Synchronous_Barrier;
- Notified : out Boolean);
-
-private
- -- POSIX barrier data type
-
- SIZEOF_PTHREAD_BARRIER_T : constant :=
- (if System.Word_Size = 64 then 32 else 20);
- -- Value defined according to the linux definition in pthreadtypes.h. On
- -- other system, e.g. MIPS IRIX, the object is smaller, so it works
- -- correctly although we are wasting some space.
-
- type pthread_barrier_t_view is (size_based, align_based);
-
- type pthread_barrier_t (Kind : pthread_barrier_t_view := size_based) is
- record
- case Kind is
- when size_based =>
- size : Interfaces.C.char_array (1 .. SIZEOF_PTHREAD_BARRIER_T);
- when align_based =>
- align : Interfaces.C.long;
- end case;
- end record;
- pragma Unchecked_Union (pthread_barrier_t);
-
- type Synchronous_Barrier (Release_Threshold : Barrier_Limit) is
- new Ada.Finalization.Limited_Controlled with
- record
- POSIX_Barrier : aliased pthread_barrier_t;
- end record;
-
- overriding procedure Initialize (Barrier : in out Synchronous_Barrier);
- overriding procedure Finalize (Barrier : in out Synchronous_Barrier);
-end Ada.Synchronous_Barriers;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S Y N C H R O N O U S _ B A R R I E R S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S Y N C H R O N O U S _ B A R R I E R S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Task_Identification;
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Task_Identification; 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package 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;
# Non-tasking case:
LIBGNAT_TARGET_PAIRS = \
-a-intnam.ads<a-intnam-dummy.ads \
-s-inmaop.adb<s-inmaop-dummy.adb \
-s-intman.adb<s-intman-dummy.adb \
-s-osinte.ads<s-osinte-dummy.ads \
+a-intnam.ads<libgnarl/a-intnam-dummy.ads \
+s-inmaop.adb<libgnarl/s-inmaop-dummy.adb \
+s-intman.adb<libgnarl/s-intman-dummy.adb \
+s-osinte.ads<libgnarl/s-osinte-dummy.ads \
s-osprim.adb<s-osprim-posix.adb \
-s-taprop.adb<s-taprop-dummy.adb \
-s-taspri.ads<s-taspri-dummy.ads
+s-taprop.adb<libgnarl/s-taprop-dummy.adb \
+s-taspri.ads<libgnarl/s-taspri-dummy.ads
# When using the GCC exception handling mechanism, we need to use an
# alternate body for a-exexpr.adb (a-exexpr-gcc.adb)
endif
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-vxworks.ads \
+ a-intnam.ads<libgnarl/a-intnam-vxworks.ads \
a-numaux.ads<a-numaux-vxworks.ads \
- s-inmaop.adb<s-inmaop-vxworks.adb \
- s-intman.ads<s-intman-vxworks.ads \
- s-intman.adb<s-intman-vxworks.adb \
- s-osinte.ads<s-osinte-vxworks.ads \
- s-osinte.adb<s-osinte-vxworks.adb \
+ s-inmaop.adb<libgnarl/s-inmaop-vxworks.adb \
+ s-intman.ads<libgnarl/s-intman-vxworks.ads \
+ s-intman.adb<libgnarl/s-intman-vxworks.adb \
+ s-osinte.ads<libgnarl/s-osinte-vxworks.ads \
+ s-osinte.adb<libgnarl/s-osinte-vxworks.adb \
s-osprim.adb<s-osprim-vxworks.adb \
s-parame.ads<s-parame-vxworks.ads \
s-parame.adb<s-parame-vxworks.adb \
- s-taprop.adb<s-taprop-vxworks.adb \
- s-tasinf.ads<s-tasinf-vxworks.ads \
- s-taspri.ads<s-taspri-vxworks.ads \
- s-vxwork.ads<s-vxwork-ppc.ads \
+ s-taprop.adb<libgnarl/s-taprop-vxworks.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-vxworks.ads \
+ s-taspri.ads<libgnarl/s-taspri-vxworks.ads \
+ s-vxwork.ads<libgnarl/s-vxwork-ppc.ads \
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
ifeq ($(strip $(filter-out rtp,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
- s-vxwext.ads<s-vxwext-rtp.ads \
- s-vxwext.adb<s-vxwext-rtp.adb \
+ s-vxwext.ads<libgnarl/s-vxwext-rtp.ads \
+ s-vxwext.adb<libgnarl/s-vxwext-rtp.adb \
s-tpopsp.adb<s-tpopsp-vxworks-rtp.adb \
system.ads<system-vxworks-$(ARCH_STR)-rtp.ads
else
ifeq ($(strip $(filter-out rtp-smp,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
- s-mudido.adb<s-mudido-affinity.adb \
- s-vxwext.ads<s-vxwext-rtp.ads \
- s-vxwext.adb<s-vxwext-rtp-smp.adb \
- s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-vxwext.ads<libgnarl/s-vxwext-rtp.ads \
+ s-vxwext.adb<libgnarl/s-vxwext-rtp-smp.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-vxworks-tls.adb \
system.ads<$(SVX)-$(ARCH_STR)-rtp-smp.ads
EH_MECHANISM=-gcc
else
ifeq ($(strip $(filter-out kernel-smp,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
- s-interr.adb<s-interr-vxworks.adb \
- s-mudido.adb<s-mudido-affinity.adb \
- s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
- s-vxwext.ads<s-vxwext-kernel.ads \
+ s-interr.adb<libgnarl/s-interr-vxworks.adb \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-vxworks-tls.adb \
+ s-vxwext.ads<libgnarl/s-vxwext-kernel.ads \
s-vxwext.adb<s-vxwext-kernel-smp.adb \
system.ads<system-vxworks-$(ARCH_STR)-kernel.ads
EXTRA_LIBGNAT_OBJS+=affinity.o
else
LIBGNAT_TARGET_PAIRS += \
- s-interr.adb<s-interr-vxworks.adb \
- s-tpopsp.adb<s-tpopsp-vxworks.adb
+ s-interr.adb<libgnarl/s-interr-vxworks.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-vxworks.adb
ifeq ($(strip $(filter-out kernel,$(THREAD_KIND))),)
EH_MECHANISM=-gcc
LIBGNAT_TARGET_PAIRS += \
- s-vxwext.ads<s-vxwext-kernel.ads \
- s-vxwext.adb<s-vxwext-kernel.adb \
+ s-vxwext.ads<libgnarl/s-vxwext-kernel.ads \
+ s-vxwext.adb<libgnarl/s-vxwext-kernel.adb \
system.ads<system-vxworks-$(ARCH_STR)-kernel.ads
else
LIBGNAT_TARGET_PAIRS += \
# target pairs for vthreads runtime
LIBGNAT_TARGET_PAIRS = \
a-elchha.adb<a-elchha-vxworks-ppc-full.adb \
- a-intnam.ads<a-intnam-vxworks.ads \
+ a-intnam.ads<libgnarl/a-intnam-vxworks.ads \
a-numaux.ads<a-numaux-vxworks.ads \
g-io.adb<g-io-vxworks-ppc-cert.adb \
- s-inmaop.adb<s-inmaop-vxworks.adb \
- s-interr.adb<s-interr-vxworks.adb \
- s-intman.ads<s-intman-vxworks.ads \
- s-intman.adb<s-intman-vxworks.adb \
- s-osinte.adb<s-osinte-vxworks.adb \
- s-osinte.ads<s-osinte-vxworks.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-vxworks.adb \
+ s-interr.adb<libgnarl/s-interr-vxworks.adb \
+ s-intman.ads<libgnarl/s-intman-vxworks.ads \
+ s-intman.adb<libgnarl/s-intman-vxworks.adb \
+ s-osinte.adb<libgnarl/s-osinte-vxworks.adb \
+ s-osinte.ads<libgnarl/s-osinte-vxworks.ads \
s-osprim.adb<s-osprim-vxworks.adb \
s-parame.ads<s-parame-ae653.ads \
s-parame.adb<s-parame-vxworks.adb \
- s-taprop.adb<s-taprop-vxworks.adb \
- s-tasinf.ads<s-tasinf-vxworks.ads \
- s-taspri.ads<s-taspri-vxworks.ads \
- s-tpopsp.adb<s-tpopsp-vxworks.adb \
+ s-taprop.adb<libgnarl/s-taprop-vxworks.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-vxworks.ads \
+ s-taspri.ads<libgnarl/s-taspri-vxworks.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-vxworks.adb \
s-vxwext.adb<s-vxwext-noints.adb \
- s-vxwext.ads<s-vxwext-vthreads.ads \
- s-vxwork.ads<s-vxwork-ppc.ads \
+ s-vxwext.ads<libgnarl/s-vxwext-vthreads.ads \
+ s-vxwork.ads<libgnarl/s-vxwork-ppc.ads \
system.ads<system-vxworks-$(ARCH_STR)-vthread.ads \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
# target pairs for kernel + vthreads runtime
LIBGNAT_TARGET_PAIRS = \
a-elchha.adb<a-elchha-vxworks-ppc-full.adb \
- a-intnam.ads<a-intnam-vxworks.ads \
+ a-intnam.ads<libgnarl/a-intnam-vxworks.ads \
a-numaux.ads<a-numaux-vxworks.ads \
g-io.adb<g-io-vxworks-ppc-cert.adb \
- s-inmaop.adb<s-inmaop-vxworks.adb \
- s-interr.adb<s-interr-vxworks.adb \
- s-intman.ads<s-intman-vxworks.ads \
- s-intman.adb<s-intman-vxworks.adb \
- s-osinte.adb<s-osinte-vxworks.adb \
- s-osinte.ads<s-osinte-vxworks.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-vxworks.adb \
+ s-interr.adb<libgnarl/s-interr-vxworks.adb \
+ s-intman.ads<libgnarl/s-intman-vxworks.ads \
+ s-intman.adb<libgnarl/s-intman-vxworks.adb \
+ s-osinte.adb<libgnarl/s-osinte-vxworks.adb \
+ s-osinte.ads<libgnarl/s-osinte-vxworks.ads \
s-osprim.adb<s-osprim-vxworks.adb \
s-parame.ads<s-parame-ae653.ads \
s-parame.adb<s-parame-vxworks.adb \
- s-taprop.adb<s-taprop-vxworks.adb \
- s-tasinf.ads<s-tasinf-vxworks.ads \
- s-taspri.ads<s-taspri-vxworks.ads \
- s-tpopsp.adb<s-tpopsp-vxworks.adb \
+ s-taprop.adb<libgnarl/s-taprop-vxworks.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-vxworks.ads \
+ s-taspri.ads<libgnarl/s-taspri-vxworks.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-vxworks.adb \
s-vxwext.adb<s-vxwext-noints.adb \
- s-vxwext.ads<s-vxwext-vthreads.ads \
- s-vxwork.ads<s-vxwork-x86.ads \
+ s-vxwext.ads<libgnarl/s-vxwext-vthreads.ads \
+ s-vxwork.ads<libgnarl/s-vxwork-x86.ads \
system.ads<system-vxworks-x86-vthread.ads \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
endif
LIBGNAT_TARGET_PAIRS+= \
- a-intnam.ads<a-intnam-vxworks.ads \
+ a-intnam.ads<libgnarl/a-intnam-vxworks.ads \
i-vxwork.ads<i-vxwork-x86.ads \
- s-osinte.adb<s-osinte-vxworks.adb \
- s-osinte.ads<s-osinte-vxworks.ads \
- s-inmaop.adb<s-inmaop-vxworks.adb \
- s-intman.ads<s-intman-vxworks.ads \
- s-intman.adb<s-intman-vxworks.adb \
+ s-osinte.adb<libgnarl/s-osinte-vxworks.adb \
+ s-osinte.ads<libgnarl/s-osinte-vxworks.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-vxworks.adb \
+ s-intman.ads<libgnarl/s-intman-vxworks.ads \
+ s-intman.adb<libgnarl/s-intman-vxworks.adb \
s-osprim.adb<s-osprim-vxworks.adb \
s-parame.ads<s-parame-vxworks.ads \
s-parame.adb<s-parame-vxworks.adb \
s-stchop.ads<s-stchop-limit.ads \
s-stchop.adb<s-stchop-vxworks.adb \
- s-taprop.adb<s-taprop-vxworks.adb \
- s-tasinf.ads<s-tasinf-vxworks.ads \
- s-taspri.ads<s-taspri-vxworks.ads \
- s-vxwork.ads<s-vxwork-x86.ads \
+ s-taprop.adb<libgnarl/s-taprop-vxworks.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-vxworks.ads \
+ s-taspri.ads<libgnarl/s-taspri-vxworks.ads \
+ s-vxwork.ads<libgnarl/s-vxwork-x86.ads \
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
ifeq ($(strip $(filter-out rtp,$(THREAD_KIND))),)
# Runtime N/A for VxWorks7 (non-existent system file)
LIBGNAT_TARGET_PAIRS += \
- s-vxwext.ads<s-vxwext-rtp.ads \
- s-vxwext.adb<s-vxwext-rtp.adb \
+ s-vxwext.ads<libgnarl/s-vxwext-rtp.ads \
+ s-vxwext.adb<libgnarl/s-vxwext-rtp.adb \
s-tpopsp.adb<s-tpopsp-vxworks-rtp.adb \
system.ads<system-vxworks-x86-rtp.ads
else
ifeq ($(strip $(filter-out rtp-smp, $(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
- s-mudido.adb<s-mudido-affinity.adb \
- s-vxwext.ads<s-vxwext-rtp.ads \
- s-vxwext.adb<s-vxwext-rtp-smp.adb \
- s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-vxwext.ads<libgnarl/s-vxwext-rtp.ads \
+ s-vxwext.adb<libgnarl/s-vxwext-rtp-smp.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-vxworks-tls.adb \
system.ads<$(SVX)-$(X86CPU)-rtp-smp.ads
EXTRA_LIBGNAT_OBJS+=affinity.o
else
ifeq ($(strip $(filter-out kernel-smp, $(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
- s-interr.adb<s-interr-vxworks.adb \
- s-mudido.adb<s-mudido-affinity.adb \
- s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
- s-vxwext.ads<s-vxwext-kernel.ads \
+ s-interr.adb<libgnarl/s-interr-vxworks.adb \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-vxworks-tls.adb \
+ s-vxwext.ads<libgnarl/s-vxwext-kernel.ads \
s-vxwext.adb<s-vxwext-kernel-smp.adb \
system.ads<$(SVX)-$(X86CPU)-kernel.ads
EXTRA_LIBGNAT_OBJS+=affinity.o
else
LIBGNAT_TARGET_PAIRS += \
- s-interr.adb<s-interr-vxworks.adb \
- s-tpopsp.adb<s-tpopsp-vxworks.adb
+ s-interr.adb<libgnarl/s-interr-vxworks.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-vxworks.adb
ifeq ($(strip $(filter-out kernel,$(THREAD_KIND))),)
# Runtime N/A for VxWorks7 (non-existent system file)
LIBGNAT_TARGET_PAIRS += \
- s-vxwext.ads<s-vxwext-kernel.ads \
- s-vxwext.adb<s-vxwext-kernel.adb \
+ s-vxwext.ads<libgnarl/s-vxwext-kernel.ads \
+ s-vxwext.adb<libgnarl/s-vxwext-kernel.adb \
system.ads<$(SVX)-x86-kernel.ads
else
LIBGNAT_TARGET_PAIRS += \
endif
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-vxworks.ads \
+ a-intnam.ads<libgnarl/a-intnam-vxworks.ads \
a-numaux.ads<a-numaux-vxworks.ads \
- s-inmaop.adb<s-inmaop-vxworks.adb \
- s-interr.adb<s-interr-vxworks.adb \
- s-intman.ads<s-intman-vxworks.ads \
- s-intman.adb<s-intman-vxworks.adb \
- s-osinte.adb<s-osinte-vxworks.adb \
- s-osinte.ads<s-osinte-vxworks.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-vxworks.adb \
+ s-interr.adb<libgnarl/s-interr-vxworks.adb \
+ s-intman.ads<libgnarl/s-intman-vxworks.ads \
+ s-intman.adb<libgnarl/s-intman-vxworks.adb \
+ s-osinte.adb<libgnarl/s-osinte-vxworks.adb \
+ s-osinte.ads<libgnarl/s-osinte-vxworks.ads \
s-osprim.adb<s-osprim-vxworks.adb \
s-parame.ads<s-parame-vxworks.ads \
s-parame.adb<s-parame-vxworks.adb \
s-stchop.ads<s-stchop-limit.ads \
s-stchop.adb<s-stchop-vxworks.adb \
- s-taprop.adb<s-taprop-vxworks.adb \
- s-tasinf.ads<s-tasinf-vxworks.ads \
- s-taspri.ads<s-taspri-vxworks.ads \
- s-vxwork.ads<s-vxwork-arm.ads \
+ s-taprop.adb<libgnarl/s-taprop-vxworks.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-vxworks.ads \
+ s-taspri.ads<libgnarl/s-taspri-vxworks.ads \
+ s-vxwork.ads<libgnarl/s-vxwork-arm.ads \
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb
ifeq ($(strip $(filter-out rtp-smp,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
- s-mudido.adb<s-mudido-affinity.adb \
- s-vxwext.ads<s-vxwext-rtp.ads \
- s-vxwext.adb<s-vxwext-rtp-smp.adb \
- s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-vxwext.ads<libgnarl/s-vxwext-rtp.ads \
+ s-vxwext.adb<libgnarl/s-vxwext-rtp-smp.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-vxworks-tls.adb \
system.ads<$(SVX)-arm-rtp-smp.ads
EXTRA_LIBGNAT_OBJS+=affinity.o
else
ifeq ($(strip $(filter-out kernel-smp,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
- s-mudido.adb<s-mudido-affinity.adb \
- s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
- s-vxwext.ads<s-vxwext-kernel.ads \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-vxworks-tls.adb \
+ s-vxwext.ads<libgnarl/s-vxwext-kernel.ads \
s-vxwext.adb<s-vxwext-kernel-smp.adb \
system.ads<$(SVX)-arm.ads
EXTRA_LIBGNAT_SRCS+=$(VX_SIGTRAMP_EXTRA_SRCS)
else
LIBGNAT_TARGET_PAIRS += \
- s-tpopsp.adb<s-tpopsp-vxworks.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-vxworks.adb \
system.ads<$(SVX)-arm.ads
ifeq ($(strip $(filter-out kernel,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
- s-vxwext.ads<s-vxwext-kernel.ads \
- s-vxwext.adb<s-vxwext-kernel.adb
+ s-vxwext.ads<libgnarl/s-vxwext-kernel.ads \
+ s-vxwext.adb<libgnarl/s-vxwext-kernel.adb
EXTRA_LIBGNAT_OBJS+=$(SIGTRAMP_OBJ)
EXTRA_LIBGNAT_SRCS+=$(VX_SIGTRAMP_EXTRA_SRCS)
# ARM android
ifeq ($(strip $(filter-out arm% linux-androideabi,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-linux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-android.adb \
- s-linux.ads<s-linux-android.ads \
- s-osinte.adb<s-osinte-android.adb \
- s-osinte.ads<s-osinte-android.ads \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-android.adb \
+ s-linux.ads<libgnarl/s-linux-android.ads \
+ s-osinte.adb<libgnarl/s-osinte-android.adb \
+ s-osinte.ads<libgnarl/s-osinte-android.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-taprop.adb<libgnarl/s-taprop-posix.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<system-linux-arm.ads
# Sparc Solaris
ifeq ($(strip $(filter-out sparc% sun solaris%,$(target_cpu) $(target_vendor) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-solaris.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-solaris.adb \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.adb<s-osinte-solaris.adb \
- s-osinte.ads<s-osinte-solaris.ads \
+ a-intnam.ads<libgnarl/a-intnam-solaris.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-solaris.adb \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-osinte.adb<libgnarl/s-osinte-solaris.adb \
+ s-osinte.ads<libgnarl/s-osinte-solaris.ads \
s-osprim.adb<s-osprim-solaris.adb \
- s-taprop.adb<s-taprop-solaris.adb \
- s-tasinf.adb<s-tasinf-solaris.adb \
- s-tasinf.ads<s-tasinf-solaris.ads \
- s-taspri.ads<s-taspri-solaris.ads \
- s-tpopsp.adb<s-tpopsp-solaris.adb \
+ s-taprop.adb<libgnarl/s-taprop-solaris.adb \
+ s-tasinf.adb<libgnarl/s-tasinf-solaris.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-solaris.ads \
+ s-taspri.ads<libgnarl/s-taspri-solaris.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-solaris.adb \
g-soliop.ads<g-soliop-solaris.ads \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
# x86 and x86-64 solaris
ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS_COMMON = \
- a-intnam.ads<a-intnam-solaris.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-solaris.adb \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.adb<s-osinte-solaris.adb \
- s-osinte.ads<s-osinte-solaris.ads \
+ a-intnam.ads<libgnarl/a-intnam-solaris.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-solaris.adb \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-osinte.adb<libgnarl/s-osinte-solaris.adb \
+ s-osinte.ads<libgnarl/s-osinte-solaris.ads \
s-osprim.adb<s-osprim-solaris.adb \
- s-taprop.adb<s-taprop-solaris.adb \
- s-tasinf.adb<s-tasinf-solaris.adb \
- s-tasinf.ads<s-tasinf-solaris.ads \
- s-taspri.ads<s-taspri-solaris.ads \
- s-tpopsp.adb<s-tpopsp-solaris.adb \
+ s-taprop.adb<libgnarl/s-taprop-solaris.adb \
+ s-tasinf.adb<libgnarl/s-tasinf-solaris.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-solaris.ads \
+ s-taspri.ads<libgnarl/s-taspri-solaris.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-solaris.adb \
g-soliop.ads<g-soliop-solaris.ads \
$(ATOMICS_TARGET_PAIRS) \
system.ads<system-solaris-x86.ads
# x86 Linux
ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-linux.ads \
- a-synbar.adb<a-synbar-posix.adb \
- a-synbar.ads<a-synbar-posix.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-tpopsp.adb<s-tpopsp-tls.adb \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ a-synbar.adb<libgnarl/a-synbar-posix.adb \
+ a-synbar.ads<libgnarl/a-synbar-posix.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-tls.adb \
$(TRASYM_DWARF_UNIX_PAIRS) \
g-sercom.adb<g-sercom-linux.adb \
s-tsmona.adb<s-tsmona-linux.adb \
- a-exetim.adb<a-exetim-posix.adb \
- a-exetim.ads<a-exetim-default.ads \
- s-linux.ads<s-linux.ads \
- s-osinte.adb<s-osinte-posix.adb \
+ a-exetim.adb<libgnarl/a-exetim-posix.adb \
+ a-exetim.ads<libgnarl/a-exetim-default.ads \
+ s-linux.ads<libgnarl/s-linux.ads \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
$(ATOMICS_TARGET_PAIRS) \
system.ads<system-linux-x86.ads
endif
LIBGNAT_TARGET_PAIRS += \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.ads<s-osinte-linux.ads \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-taspri.ads<s-taspri-posix.ads
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads
EH_MECHANISM=-gcc
THREADSLIB = -lpthread -lrt
# x86 kfreebsd
ifeq ($(strip $(filter-out %86 kfreebsd%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-freebsd.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-posix.adb \
+ a-intnam.ads<libgnarl/a-intnam-freebsd.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
s-osinte.ads<s-osinte-kfreebsd-gnu.ads \
- s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-osprim.adb<libgnarl/s-osprim-posix.adb \
+ s-taprop.adb<libgnarl/s-taprop-posix.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_TARGET_PAIRS) \
system.ads<system-freebsd.ads
# i[3456]86-pc-gnu i.e. GNU Hurd
ifeq ($(strip $(filter-out %86 pc gnu,$(target_cpu) $(target_vendor) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-freebsd.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-gnu.adb \
- s-osinte.ads<s-osinte-gnu.ads \
+ a-intnam.ads<libgnarl/a-intnam-freebsd.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-osinte.adb<libgnarl/s-osinte-gnu.adb \
+ s-osinte.ads<libgnarl/s-osinte-gnu.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-taprop.adb<libgnarl/s-taprop-posix.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_TARGET_PAIRS) \
system.ads<system-freebsd.ads
ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-freebsd.ads \
+ a-intnam.ads<libgnarl/a-intnam-freebsd.ads \
a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<a-numaux-x86.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-posix.adb \
- s-osinte.ads<s-osinte-kfreebsd-gnu.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
+ s-osinte.ads<libgnarl/s-osinte-kfreebsd-gnu.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-taprop.adb<libgnarl/s-taprop-posix.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb \
system.ads<system-freebsd.ads
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
# aarch64 FreeBSD
ifeq ($(strip $(filter-out %aarch64 freebsd%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-freebsd.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.adb<s-osinte-freebsd.adb \
- s-osinte.ads<s-osinte-freebsd.ads \
+ a-intnam.ads<libgnarl/a-intnam-freebsd.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-osinte.adb<libgnarl/s-osinte-freebsd.adb \
+ s-osinte.ads<libgnarl/s-osinte-freebsd.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix.adb \
+ s-taprop.adb<libgnarl/s-taprop-posix.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<system-freebsd.ads
# x86 FreeBSD
ifeq ($(strip $(filter-out %86 freebsd%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-freebsd.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.adb<s-osinte-freebsd.adb \
- s-osinte.ads<s-osinte-freebsd.ads \
+ a-intnam.ads<libgnarl/a-intnam-freebsd.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-osinte.adb<libgnarl/s-osinte-freebsd.adb \
+ s-osinte.ads<libgnarl/s-osinte-freebsd.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix.adb \
+ s-taprop.adb<libgnarl/s-taprop-posix.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_TARGET_PAIRS) \
system.ads<system-freebsd.ads
# x86-64 FreeBSD
ifeq ($(strip $(filter-out %86_64 freebsd%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-freebsd.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.adb<s-osinte-freebsd.adb \
- s-osinte.ads<s-osinte-freebsd.ads \
+ a-intnam.ads<libgnarl/a-intnam-freebsd.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-osinte.adb<libgnarl/s-osinte-freebsd.adb \
+ s-osinte.ads<libgnarl/s-osinte-freebsd.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix.adb \
+ s-taprop.adb<libgnarl/s-taprop-posix.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_64_TARGET_PAIRS) \
system.ads<system-freebsd.ads
# x86-64 DragonFly
ifeq ($(strip $(filter-out %86_64 dragonfly%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-dragonfly.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.adb<s-osinte-dragonfly.adb \
- s-osinte.ads<s-osinte-dragonfly.ads \
+ a-intnam.ads<libgnarl/a-intnam-dragonfly.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-osinte.adb<libgnarl/s-osinte-dragonfly.adb \
+ s-osinte.ads<libgnarl/s-osinte-dragonfly.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix.adb \
+ s-taprop.adb<libgnarl/s-taprop-posix.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_64_TARGET_PAIRS) \
system.ads<system-dragonfly-x86_64.ads
# S390 Linux
ifeq ($(strip $(filter-out s390% linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-linux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux.ads \
- s-osinte.adb<s-osinte-posix.adb \
- s-osinte.ads<s-osinte-linux.ads \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-linux.ads<libgnarl/s-linux.ads \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-taspri.ads<s-taspri-posix-noaltstack.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix-noaltstack.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb \
system.ads<system-linux-s390.ads
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
ifeq ($(strip $(filter-out hppa% hp hpux10%,$(target_cpu) $(target_vendor) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
a-excpol.adb<a-excpol-abort.adb \
- a-intnam.ads<a-intnam-hpux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-interr.adb<s-interr-sigaction.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-hpux-dce.adb \
- s-osinte.ads<s-osinte-hpux-dce.ads \
+ a-intnam.ads<libgnarl/a-intnam-hpux.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-interr.adb<libgnarl/s-interr-sigaction.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-osinte.adb<libgnarl/s-osinte-hpux-dce.adb \
+ s-osinte.ads<libgnarl/s-osinte-hpux-dce.ads \
s-parame.ads<s-parame-hpux.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-hpux-dce.adb \
- s-taspri.ads<s-taspri-hpux-dce.ads \
- s-tpopsp.adb<s-tpopsp-posix.adb \
+ s-taprop.adb<libgnarl/s-taprop-hpux-dce.adb \
+ s-taspri.ads<libgnarl/s-taspri-hpux-dce.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix.adb \
system.ads<system-hpux.ads
EH_MECHANISM=-gcc
# HP/PA HP-UX 11
ifeq ($(strip $(filter-out hppa% hp hpux11%,$(target_cpu) $(target_vendor) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-hpux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-posix.adb \
- s-osinte.ads<s-osinte-hpux.ads \
+ a-intnam.ads<libgnarl/a-intnam-hpux.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
+ s-osinte.ads<libgnarl/s-osinte-hpux.ads \
s-parame.ads<s-parame-hpux.ads \
s-osprim.adb<s-osprim-posix.adb \
s-traceb.adb<s-traceb-hpux.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-taprop.adb<libgnarl/s-taprop-posix.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb \
system.ads<system-hpux.ads
EH_MECHANISM=-gcc
# IBM AIX
ifeq ($(strip $(filter-out ibm aix%,$(target_vendor) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-aix.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-aix.adb \
- s-osinte.ads<s-osinte-aix.ads \
+ a-intnam.ads<libgnarl/a-intnam-aix.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-osinte.adb<libgnarl/s-osinte-aix.adb \
+ s-osinte.ads<libgnarl/s-osinte-aix.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix.adb \
+ s-taprop.adb<libgnarl/s-taprop-posix.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<system-aix.ads
LIBGNAT_TARGET_PAIRS = \
system.ads<system-rtems.ads \
a-intnam.ads<a-intnam-rtems.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-rtems.adb \
- s-osinte.ads<s-osinte-rtems.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-osinte.adb<libgnarl/s-osinte-rtems.adb \
+ s-osinte.ads<libgnarl/s-osinte-rtems.ads \
s-osprim.adb<s-osprim-posix.adb \
s-parame.adb<s-parame-rtems.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
+ s-taprop.adb<libgnarl/s-taprop-posix.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
s-tpopsp.adb<s-tpopsp-tls.adb \
s-stchop.adb<s-stchop-rtems.adb \
- s-interr.adb<s-interr-hwint.adb
+ s-interr.adb<libgnarl/s-interr-hwint.adb
endif
# PikeOS
GNATRTL_SOCKETS_OBJS =
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-dummy.ads \
- s-inmaop.adb<s-inmaop-dummy.adb \
- s-intman.adb<s-intman-dummy.adb \
- s-osinte.ads<s-osinte-dummy.ads \
+ a-intnam.ads<libgnarl/a-intnam-dummy.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-dummy.adb \
+ s-intman.adb<libgnarl/s-intman-dummy.adb \
+ s-osinte.ads<libgnarl/s-osinte-dummy.ads \
s-osprim.adb<s-osprim-unix.adb \
- s-taprop.adb<s-taprop-dummy.adb \
- s-taspri.ads<s-taspri-dummy.ads \
+ s-taprop.adb<libgnarl/s-taprop-dummy.adb \
+ s-taspri.ads<libgnarl/s-taspri-dummy.ads \
system.ads<system-djgpp.ads \
$(DUMMY_SOCKETS_TARGET_PAIRS)
a-dirval.adb<a-dirval-mingw.adb \
a-excpol.adb<a-excpol-abort.adb \
s-gloloc.adb<s-gloloc-mingw.adb \
- s-inmaop.adb<s-inmaop-dummy.adb \
- s-taspri.ads<s-taspri-mingw.ads \
- s-tasinf.adb<s-tasinf-mingw.adb \
- s-tasinf.ads<s-tasinf-mingw.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-dummy.adb \
+ s-taspri.ads<libgnarl/s-taspri-mingw.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-mingw.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-mingw.ads \
g-stsifd.adb<g-stsifd-sockets.adb \
g-soliop.ads<g-soliop-mingw.ads \
$(ATOMICS_TARGET_PAIRS) \
system.ads<system-mingw.ads
LIBGNAT_TARGET_PAIRS += \
- a-exetim.adb<a-exetim-mingw.adb \
- a-exetim.ads<a-exetim-mingw.ads \
- a-intnam.ads<a-intnam-mingw.ads \
+ a-exetim.adb<libgnarl/a-exetim-mingw.adb \
+ a-exetim.ads<libgnarl/a-exetim-mingw.ads \
+ a-intnam.ads<libgnarl/a-intnam-mingw.ads \
g-sercom.adb<g-sercom-mingw.adb \
- s-interr.adb<s-interr-sigaction.adb \
- s-intman.adb<s-intman-mingw.adb \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.ads<s-osinte-mingw.ads \
+ s-tsmona.adb<s-tsmona-mingw.adb \
+ s-interr.adb<libgnarl/s-interr-sigaction.adb \
+ s-intman.adb<libgnarl/s-intman-mingw.adb \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-osinte.ads<libgnarl/s-osinte-mingw.ads \
s-osprim.adb<s-osprim-mingw.adb \
- s-taprop.adb<s-taprop-mingw.adb
+ s-taprop.adb<libgnarl/s-taprop-mingw.adb
ifeq ($(strip $(filter-out x86_64%,$(target_cpu))),)
ifeq ($(strip $(MULTISUBDIR)),/32)
# Mips Linux
ifeq ($(strip $(filter-out mips% linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-linux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux-mips.ads \
- s-osinte.adb<s-osinte-posix.adb \
- s-osinte.ads<s-osinte-linux.ads \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-linux.ads<libgnarl/s-linux-mips.ads \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-taspri.ads<s-taspri-posix-noaltstack.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix-noaltstack.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb \
g-sercom.adb<g-sercom-linux.adb \
system.ads<system-linux-mips.ads
# PowerPC and e500v2 Linux
ifeq ($(strip $(filter-out powerpc% linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS_COMMON = \
- a-exetim.adb<a-exetim-posix.adb \
- a-exetim.ads<a-exetim-default.ads \
- a-intnam.ads<a-intnam-linux.ads \
- a-synbar.adb<a-synbar-posix.adb \
- a-synbar.ads<a-synbar-posix.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux.ads \
- s-osinte.adb<s-osinte-posix.adb \
- s-tpopsp.adb<s-tpopsp-tls.adb \
+ a-exetim.adb<libgnarl/a-exetim-posix.adb \
+ a-exetim.ads<libgnarl/a-exetim-default.ads \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ a-synbar.adb<libgnarl/a-synbar-posix.adb \
+ a-synbar.ads<libgnarl/a-synbar-posix.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-linux.ads<libgnarl/s-linux.ads \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-tls.adb \
g-sercom.adb<g-sercom-linux.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
LIBGNAT_TARGET_PAIRS = \
$(LIBGNAT_TARGET_PAIRS_COMMON) \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.ads<s-osinte-linux.ads \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-taspri.ads<s-taspri-posix-noaltstack.ads
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix-noaltstack.ads
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
# ARM linux, GNU eabi
ifeq ($(strip $(filter-out arm% linux-gnueabi%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-linux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux.ads \
- s-osinte.adb<s-osinte-posix.adb \
- s-osinte.ads<s-osinte-linux.ads \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-linux.ads<libgnarl/s-linux.ads \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-taspri.ads<s-taspri-posix-noaltstack.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix-noaltstack.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<system-linux-arm.ads
# AArch64 Linux
ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-exetim.adb<a-exetim-posix.adb \
- a-exetim.ads<a-exetim-default.ads \
- a-intnam.ads<a-intnam-linux.ads \
- a-synbar.adb<a-synbar-posix.adb \
- a-synbar.ads<a-synbar-posix.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux.ads \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.ads<s-osinte-linux.ads \
- s-osinte.adb<s-osinte-posix.adb \
+ a-exetim.adb<libgnarl/a-exetim-posix.adb \
+ a-exetim.ads<libgnarl/a-exetim-default.ads \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ a-synbar.adb<libgnarl/a-synbar-posix.adb \
+ a-synbar.ads<libgnarl/a-synbar-posix.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-linux.ads<libgnarl/s-linux.ads \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-tpopsp.adb<s-tpopsp-tls.adb \
- s-taspri.ads<s-taspri-posix.ads \
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-tls.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
g-sercom.adb<g-sercom-linux.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
# Sparc Linux
ifeq ($(strip $(filter-out sparc% linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-linux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux-sparc.ads \
- s-osinte.adb<s-osinte-posix.adb \
- s-osinte.ads<s-osinte-linux.ads \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-linux.ads<libgnarl/s-linux-sparc.ads \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-taspri.ads<s-taspri-posix-noaltstack.ads \
- s-tpopsp.adb<s-tpopsp-tls.adb \
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix-noaltstack.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-tls.adb \
system.ads<system-linux-sparc.ads
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
# HP/PA Linux
ifeq ($(strip $(filter-out hppa% linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-linux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux-hppa.ads \
- s-osinte.adb<s-osinte-posix.adb \
- s-osinte.ads<s-osinte-linux.ads \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-linux.ads<libgnarl/s-linux-hppa.ads \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-taspri.ads<s-taspri-posix-noaltstack.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix-noaltstack.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb \
system.ads<system-linux-hppa.ads
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
# M68K Linux
ifeq ($(strip $(filter-out m68k% linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-linux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
s-linux.ads<s-linux.ads \
- s-osinte.adb<s-osinte-posix.adb \
- s-osinte.ads<s-osinte-linux.ads \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb \
system.ads<system-linux-m68k.ads
TOOLS_TARGET_PAIRS = \
# SH4 Linux
ifeq ($(strip $(filter-out sh4% linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-linux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux.ads \
- s-osinte.adb<s-osinte-posix.adb \
- s-osinte.ads<s-osinte-linux.ads \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-linux.ads<libgnarl/s-linux.ads \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-taspri.ads<s-taspri-posix-noaltstack.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix-noaltstack.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb \
system.ads<system-linux-sh4.ads
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-linux.adb
# IA64 Linux
ifeq ($(strip $(filter-out %ia64 linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-exetim.adb<a-exetim-posix.adb \
- a-exetim.ads<a-exetim-default.ads \
- a-intnam.ads<a-intnam-linux.ads \
+ a-exetim.adb<libgnarl/a-exetim-posix.adb \
+ a-exetim.ads<libgnarl/a-exetim-default.ads \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
a-numaux.ads<a-numaux-libc-x86.ads \
- a-synbar.adb<a-synbar-posix.adb \
- a-synbar.ads<a-synbar-posix.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux.ads \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.ads<s-osinte-linux.ads \
- s-osinte.adb<s-osinte-posix.adb \
+ a-synbar.adb<libgnarl/a-synbar-posix.adb \
+ a-synbar.ads<libgnarl/a-synbar-posix.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-linux.ads<libgnarl/s-linux.ads \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-tpopsp.adb<s-tpopsp-tls.adb \
- s-taspri.ads<s-taspri-posix-noaltstack.ads \
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-tls.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix-noaltstack.ads \
g-sercom.adb<g-sercom-linux.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
# IA64 HP-UX
ifeq ($(strip $(filter-out ia64% hp hpux%,$(target_cpu) $(target_vendor) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-hpux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-osinte.adb<s-osinte-posix.adb \
- s-osinte.ads<s-osinte-hpux.ads \
+ a-intnam.ads<libgnarl/a-intnam-hpux.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
+ s-osinte.ads<libgnarl/s-osinte-hpux.ads \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ s-taprop.adb<libgnarl/s-taprop-posix.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<system-hpux-ia64.ads
# Alpha Linux
ifeq ($(strip $(filter-out alpha% linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-linux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux-alpha.ads \
- s-osinte.ads<s-osinte-linux.ads \
- s-osinte.adb<s-osinte-posix.adb \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-linux.ads<libgnarl/s-linux-alpha.ads \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
- s-taspri.ads<s-taspri-posix-noaltstack.ads \
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix-noaltstack.ads \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<system-linux-alpha.ads
# x86-64 Linux
ifeq ($(strip $(filter-out %x86_64 linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-exetim.adb<a-exetim-posix.adb \
- a-exetim.ads<a-exetim-default.ads \
- a-intnam.ads<a-intnam-linux.ads \
- a-synbar.adb<a-synbar-posix.adb \
- a-synbar.ads<a-synbar-posix.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux.ads \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.ads<s-osinte-linux.ads \
- s-osinte.adb<s-osinte-posix.adb \
+ a-exetim.adb<libgnarl/a-exetim-posix.adb \
+ a-exetim.ads<libgnarl/a-exetim-default.ads \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ a-synbar.adb<libgnarl/a-synbar-posix.adb \
+ a-synbar.ads<libgnarl/a-synbar-posix.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-linux.ads<libgnarl/s-linux.ads \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
+ s-osinte.adb<libgnarl/s-osinte-posix.adb \
s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-tpopsp.adb<s-tpopsp-tls.adb \
- s-taspri.ads<s-taspri-posix.ads \
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-tls.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
g-sercom.adb<g-sercom-linux.adb \
$(TRASYM_DWARF_UNIX_PAIRS) \
s-tsmona.adb<s-tsmona-linux.adb \
ifeq ($(strip $(filter-out %x32 linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-exetim.adb<a-exetim-posix.adb \
- a-exetim.ads<a-exetim-default.ads \
- a-intnam.ads<a-intnam-linux.ads \
- a-synbar.adb<a-synbar-posix.adb \
- a-synbar.ads<a-synbar-posix.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux-x32.ads \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.ads<s-osinte-linux.ads \
- s-osinte.adb<s-osinte-x32.adb \
+ a-exetim.adb<libgnarl/a-exetim-posix.adb \
+ a-exetim.ads<libgnarl/a-exetim-default.ads \
+ a-intnam.ads<libgnarl/a-intnam-linux.ads \
+ a-synbar.adb<libgnarl/a-synbar-posix.adb \
+ a-synbar.ads<libgnarl/a-synbar-posix.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
+ s-linux.ads<libgnarl/s-linux-x32.ads \
+ s-mudido.adb<libgnarl/s-mudido-affinity.adb \
+ s-osinte.ads<libgnarl/s-osinte-linux.ads \
+ s-osinte.adb<libgnarl/s-osinte-x32.adb \
s-osprim.adb<s-osprim-x32.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-tpopsp.adb<s-tpopsp-tls.adb \
- s-taspri.ads<s-taspri-posix.ads \
+ s-taprop.adb<libgnarl/s-taprop-linux.adb \
+ s-tasinf.ads<libgnarl/s-tasinf-linux.ads \
+ s-tasinf.adb<libgnarl/s-tasinf-linux.adb \
+ s-tpopsp.adb<libgnarl/s-tpopsp-tls.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
g-sercom.adb<g-sercom-linux.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_64_TARGET_PAIRS) \
ifeq ($(strip $(filter-out darwin%,$(target_os))),)
SO_OPTS = -shared-libgcc
LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<a-intnam-darwin.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-osinte.adb<s-osinte-darwin.adb \
- s-osinte.ads<s-osinte-darwin.ads \
- s-taprop.adb<s-taprop-posix.adb \
- s-taspri.ads<s-taspri-posix.ads \
+ a-intnam.ads<libgnarl/a-intnam-darwin.ads \
+ s-inmaop.adb<libgnarl/s-inmaop-posix.adb \
+ s-osinte.adb<libgnarl/s-osinte-darwin.adb \
+ s-osinte.ads<libgnarl/s-osinte-darwin.ads \
+ s-taprop.adb<libgnarl/s-taprop-posix.adb \
+ s-taspri.ads<libgnarl/s-taspri-posix.ads \
g-sercom.adb<g-sercom-linux.adb \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb
+ s-tpopsp.adb<libgnarl/s-tpopsp-posix-foreign.adb
ifeq ($(strip $(filter-out %86,$(target_cpu))),)
LIBGNAT_TARGET_PAIRS += \
- s-intman.adb<s-intman-susv3.adb \
+ s-intman.adb<libgnarl/s-intman-susv3.adb \
s-osprim.adb<s-osprim-darwin.adb \
$(ATOMICS_TARGET_PAIRS) \
system.ads<system-darwin-x86.ads
ifeq ($(strip $(filter-out %x86_64,$(target_cpu))),)
LIBGNAT_TARGET_PAIRS += \
- s-intman.adb<s-intman-susv3.adb \
+ s-intman.adb<libgnarl/s-intman-susv3.adb \
s-osprim.adb<s-osprim-darwin.adb \
- a-exetim.ads<a-exetim-default.ads \
- a-exetim.adb<a-exetim-darwin.adb \
+ a-exetim.ads<libgnarl/a-exetim-default.ads \
+ a-exetim.adb<libgnarl/a-exetim-darwin.adb \
$(ATOMICS_TARGET_PAIRS) \
system.ads<system-darwin-x86.ads
ifeq ($(strip $(filter-out powerpc%,$(target_cpu))),)
LIBGNAT_TARGET_PAIRS += \
- s-intman.adb<s-intman-posix.adb \
+ s-intman.adb<libgnarl/s-intman-posix.adb \
s-osprim.adb<s-osprim-posix.adb \
a-numaux.ads<a-numaux-darwin.ads \
a-numaux.adb<a-numaux-darwin.adb \
ifeq ($(strip $(filter-out arm,$(target_cpu))),)
LIBGNAT_TARGET_PAIRS += \
- s-intman.adb<s-intman-susv3.adb \
+ s-intman.adb<libgnarl/s-intman-susv3.adb \
s-osprim.adb<s-osprim-darwin.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
ifeq ($(strip $(filter-out arm64 aarch64,$(target_cpu))),)
LIBGNAT_TARGET_PAIRS += \
- s-intman.adb<s-intman-susv3.adb \
+ s-intman.adb<libgnarl/s-intman-susv3.adb \
s-osprim.adb<s-osprim-darwin.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
LIBGNAT_SRCS = $(patsubst %.o,%.c,$(LIBGNAT_OBJS)) \
adadecode.h adaint.h env.h gsocket.h raise.h standard.ads.h \
- tb-gcc.c thread.c $(EXTRA_LIBGNAT_SRCS)
+ tb-gcc.c libgnarl/thread.c $(EXTRA_LIBGNAT_SRCS)
# GNATRTL_NONTASKING_OBJS and GNATRTL_TASKING_OBJS can be found in
# the following include file:
machcode.ads text_io.ads unchconv.ads unchdeal.ads \
sequenio.ads system.ads memtrack.adb \
a-[a-o]*.adb a-[p-z]*.adb a-[a-o]*.ads a-[p-z]*.ads g-*.ad? i-*.ad? \
- s-[a-o]*.adb s-[p-z]*.adb s-[a-o]*.ads s-[p-z]*.ads libgnarl/*.ads \
- libgnarl/*.adb
+ s-[a-o]*.adb s-[p-z]*.adb s-[a-o]*.ads s-[p-z]*.ads \
+ libgnarl/[agis]-[a-z]*.ad[sb]
# Files that are in ADA_INCLUDE_SRCS but not in all configurations.
# They will be removed from the run time if not used.
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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, 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X E C U T I O N _ T I M E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Darwin version of this package
+
+with Ada.Task_Identification; use Ada.Task_Identification;
+with Ada.Unchecked_Conversion;
+
+with System.Tasking;
+with System.OS_Interface; use System.OS_Interface;
+with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
+
+with Interfaces.C; use Interfaces.C;
+
+package body Ada.Execution_Time is
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) + Right);
+ end "+";
+
+ function "+"
+ (Left : Ada.Real_Time.Time_Span;
+ Right : CPU_Time) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Left + Ada.Real_Time.Time (Right));
+ end "+";
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) - Right);
+ end "-";
+
+ function "-"
+ (Left : CPU_Time;
+ Right : CPU_Time) return Ada.Real_Time.Time_Span
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
+ end "-";
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task) return CPU_Time
+ is
+ function Convert_Ids is new
+ Ada.Unchecked_Conversion (Task_Id, System.Tasking.Task_Id);
+
+ function To_CPU_Time is
+ new Ada.Unchecked_Conversion (Duration, CPU_Time);
+ -- Time is equal to Duration (although it is a private type) and
+ -- CPU_Time is equal to Time.
+
+ subtype integer_t is Interfaces.C.int;
+ subtype mach_port_t is integer_t;
+ -- Type definition for Mach.
+
+ type time_value_t is record
+ seconds : integer_t;
+ microseconds : integer_t;
+ end record;
+ pragma Convention (C, time_value_t);
+ -- Mach time_value_t
+
+ type thread_basic_info_t is record
+ user_time : time_value_t;
+ system_time : time_value_t;
+ cpu_usage : integer_t;
+ policy : integer_t;
+ run_state : integer_t;
+ flags : integer_t;
+ suspend_count : integer_t;
+ sleep_time : integer_t;
+ end record;
+ pragma Convention (C, thread_basic_info_t);
+ -- Mach structure from thread_info.h
+
+ THREAD_BASIC_INFO : constant := 3;
+ THREAD_BASIC_INFO_COUNT : constant := 10;
+ -- Flavors for basic info
+
+ function thread_info (Target : mach_port_t;
+ Flavor : integer_t;
+ Thread_Info : System.Address;
+ Count : System.Address) return integer_t;
+ pragma Import (C, thread_info);
+ -- Mach call to get info on a thread
+
+ function pthread_mach_thread_np (Thread : pthread_t) return mach_port_t;
+ pragma Import (C, pthread_mach_thread_np);
+ -- Get Mach thread from posix thread
+
+ Result : Interfaces.C.int;
+ Thread : pthread_t;
+ Port : mach_port_t;
+ Ti : thread_basic_info_t;
+ Count : integer_t;
+ begin
+ if T = Ada.Task_Identification.Null_Task_Id then
+ raise Program_Error;
+ end if;
+
+ Thread := Get_Thread_Id (Convert_Ids (T));
+ Port := pthread_mach_thread_np (Thread);
+ pragma Assert (Port > 0);
+
+ Count := THREAD_BASIC_INFO_COUNT;
+ Result := thread_info (Port, THREAD_BASIC_INFO,
+ Ti'Address, Count'Address);
+ pragma Assert (Result = 0);
+ pragma Assert (Count = THREAD_BASIC_INFO_COUNT);
+
+ return To_CPU_Time
+ (Duration (Ti.user_time.seconds + Ti.system_time.seconds)
+ + Duration (Ti.user_time.microseconds
+ + Ti.system_time.microseconds) / 1E6);
+ end Clock;
+
+ --------------------------
+ -- Clock_For_Interrupts --
+ --------------------------
+
+ function Clock_For_Interrupts return CPU_Time is
+ begin
+ -- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
+ -- is set to False the function raises Program_Error.
+
+ raise Program_Error;
+ return CPU_Time_First;
+ end Clock_For_Interrupts;
+
+ -----------
+ -- Split --
+ -----------
+
+ procedure Split
+ (T : CPU_Time;
+ SC : out Ada.Real_Time.Seconds_Count;
+ TS : out Ada.Real_Time.Time_Span)
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
+ end Split;
+
+ -------------
+ -- Time_Of --
+ -------------
+
+ function Time_Of
+ (SC : Ada.Real_Time.Seconds_Count;
+ TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
+ return CPU_Time
+ is
+ begin
+ return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
+ end Time_Of;
+
+end Ada.Execution_Time;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X E C U T I O N _ T I M E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2017, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Task_Identification;
+with Ada.Real_Time;
+
+package Ada.Execution_Time with
+ SPARK_Mode
+is
+
+ type CPU_Time is private;
+
+ CPU_Time_First : constant CPU_Time;
+ CPU_Time_Last : constant CPU_Time;
+ CPU_Time_Unit : constant := Ada.Real_Time.Time_Unit;
+ CPU_Tick : constant Ada.Real_Time.Time_Span;
+
+ use type Ada.Task_Identification.Task_Id;
+
+ function Clock
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task)
+ return CPU_Time
+ with
+ Volatile_Function,
+ Global => Ada.Real_Time.Clock_Time,
+ Pre => T /= Ada.Task_Identification.Null_Task_Id;
+
+ function "+"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ with
+ Global => null;
+
+ function "+"
+ (Left : Ada.Real_Time.Time_Span;
+ Right : CPU_Time) return CPU_Time
+ with
+ Global => null;
+
+ function "-"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ with
+ Global => null;
+
+ function "-"
+ (Left : CPU_Time;
+ Right : CPU_Time) return Ada.Real_Time.Time_Span
+ with
+ Global => null;
+
+ function "<" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+ function "<=" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+ function ">" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+ function ">=" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+
+ procedure Split
+ (T : CPU_Time;
+ SC : out Ada.Real_Time.Seconds_Count;
+ TS : out Ada.Real_Time.Time_Span)
+ with
+ Global => null;
+
+ function Time_Of
+ (SC : Ada.Real_Time.Seconds_Count;
+ TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
+ return CPU_Time
+ with
+ Global => null;
+
+ Interrupt_Clocks_Supported : constant Boolean := False;
+ Separate_Interrupt_Clocks_Supported : constant Boolean := False;
+
+ pragma Warnings (Off, "check will fail at run time");
+ function Clock_For_Interrupts return CPU_Time with
+ Volatile_Function,
+ Global => Ada.Real_Time.Clock_Time,
+ Pre => Interrupt_Clocks_Supported;
+ pragma Warnings (On, "check will fail at run time");
+
+private
+ pragma SPARK_Mode (Off);
+
+ type CPU_Time is new Ada.Real_Time.Time;
+
+ CPU_Time_First : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_First);
+ CPU_Time_Last : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_Last);
+
+ CPU_Tick : constant Ada.Real_Time.Time_Span := Ada.Real_Time.Tick;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+
+end Ada.Execution_Time;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X E C U T I O N _ T I M E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Windows native version of this package
+
+with Ada.Task_Identification; use Ada.Task_Identification;
+with Ada.Unchecked_Conversion;
+
+with System.OS_Interface; use System.OS_Interface;
+with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
+with System.Tasking; use System.Tasking;
+with System.Win32; use System.Win32;
+
+package body Ada.Execution_Time with
+ SPARK_Mode => Off
+is
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) + Right);
+ end "+";
+
+ function "+"
+ (Left : Ada.Real_Time.Time_Span;
+ Right : CPU_Time) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Left + Ada.Real_Time.Time (Right));
+ end "+";
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) - Right);
+ end "-";
+
+ function "-"
+ (Left : CPU_Time;
+ Right : CPU_Time) return Ada.Real_Time.Time_Span
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
+ end "-";
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task) return CPU_Time
+ is
+ Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7;
+
+ function To_Time is new Ada.Unchecked_Conversion
+ (Duration, Ada.Real_Time.Time);
+
+ function To_Task_Id is new Ada.Unchecked_Conversion
+ (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id);
+
+ C_Time : aliased Long_Long_Integer;
+ E_Time : aliased Long_Long_Integer;
+ K_Time : aliased Long_Long_Integer;
+ U_Time : aliased Long_Long_Integer;
+ Res : BOOL;
+
+ begin
+ if T = Ada.Task_Identification.Null_Task_Id then
+ raise Program_Error;
+ end if;
+
+ Res :=
+ GetThreadTimes
+ (HANDLE (Get_Thread_Id (To_Task_Id (T))),
+ C_Time'Access, E_Time'Access, K_Time'Access, U_Time'Access);
+
+ if Res = System.Win32.FALSE then
+ raise Program_Error;
+ end if;
+
+ return
+ CPU_Time
+ (To_Time
+ (Duration
+ ((Long_Long_Float (K_Time) / Hundreds_Nano_In_Sec)
+ + (Long_Long_Float (U_Time) / Hundreds_Nano_In_Sec))));
+ end Clock;
+
+ --------------------------
+ -- Clock_For_Interrupts --
+ --------------------------
+
+ function Clock_For_Interrupts return CPU_Time is
+ begin
+ -- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
+ -- is set to False the function raises Program_Error.
+
+ raise Program_Error;
+ return CPU_Time_First;
+ end Clock_For_Interrupts;
+
+ -----------
+ -- Split --
+ -----------
+
+ procedure Split
+ (T : CPU_Time;
+ SC : out Ada.Real_Time.Seconds_Count;
+ TS : out Ada.Real_Time.Time_Span)
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
+ end Split;
+
+ -------------
+ -- Time_Of --
+ -------------
+
+ function Time_Of
+ (SC : Ada.Real_Time.Seconds_Count;
+ TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
+ return CPU_Time
+ is
+ begin
+ return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
+ end Time_Of;
+
+end Ada.Execution_Time;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X E C U T I O N _ T I M E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2009-2017, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Windows native version of this package
+
+with Ada.Task_Identification;
+with Ada.Real_Time;
+
+package Ada.Execution_Time with
+ SPARK_Mode
+is
+ type CPU_Time is private;
+
+ CPU_Time_First : constant CPU_Time;
+ CPU_Time_Last : constant CPU_Time;
+ CPU_Time_Unit : constant := 0.000001;
+ CPU_Tick : constant Ada.Real_Time.Time_Span;
+
+ use type Ada.Task_Identification.Task_Id;
+
+ function Clock
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task)
+ return CPU_Time
+ with
+ Volatile_Function,
+ Global => Ada.Real_Time.Clock_Time,
+ Pre => T /= Ada.Task_Identification.Null_Task_Id;
+
+ function "+"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ with
+ Global => null;
+
+ function "+"
+ (Left : Ada.Real_Time.Time_Span;
+ Right : CPU_Time) return CPU_Time
+ with
+ Global => null;
+
+ function "-"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ with
+ Global => null;
+
+ function "-"
+ (Left : CPU_Time;
+ Right : CPU_Time) return Ada.Real_Time.Time_Span
+ with
+ Global => null;
+
+ function "<" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+ function "<=" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+ function ">" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+ function ">=" (Left, Right : CPU_Time) return Boolean with
+ Global => null;
+
+ procedure Split
+ (T : CPU_Time;
+ SC : out Ada.Real_Time.Seconds_Count;
+ TS : out Ada.Real_Time.Time_Span)
+ with
+ Global => null;
+
+ function Time_Of
+ (SC : Ada.Real_Time.Seconds_Count;
+ TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
+ return CPU_Time
+ with
+ Global => null;
+
+ Interrupt_Clocks_Supported : constant Boolean := False;
+ Separate_Interrupt_Clocks_Supported : constant Boolean := False;
+
+ pragma Warnings (Off, "check will fail at run time");
+ function Clock_For_Interrupts return CPU_Time with
+ Volatile_Function,
+ Global => Ada.Real_Time.Clock_Time,
+ Pre => Interrupt_Clocks_Supported;
+ pragma Warnings (On, "check will fail at run time");
+
+private
+ pragma SPARK_Mode (Off);
+
+ type CPU_Time is new Ada.Real_Time.Time;
+
+ CPU_Time_First : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_First);
+ CPU_Time_Last : constant CPU_Time := CPU_Time (Ada.Real_Time.Time_Last);
+
+ CPU_Tick : constant Ada.Real_Time.Time_Span := Ada.Real_Time.Tick;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+
+end Ada.Execution_Time;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X E C U T I O N _ T I M E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the POSIX (Realtime Extension) version of this package
+
+with Ada.Task_Identification; use Ada.Task_Identification;
+with Ada.Unchecked_Conversion;
+
+with System.Tasking;
+with System.OS_Interface; use System.OS_Interface;
+with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
+
+with Interfaces.C; use Interfaces.C;
+
+package body Ada.Execution_Time is
+
+ pragma Linker_Options ("-lrt");
+ -- POSIX.1b Realtime Extensions library. Needed to have access to function
+ -- clock_gettime.
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) + Right);
+ end "+";
+
+ function "+"
+ (Left : Ada.Real_Time.Time_Span;
+ Right : CPU_Time) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Left + Ada.Real_Time.Time (Right));
+ end "+";
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) - Right);
+ end "-";
+
+ function "-"
+ (Left : CPU_Time;
+ Right : CPU_Time) return Ada.Real_Time.Time_Span
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
+ end "-";
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task) return CPU_Time
+ is
+ TS : aliased timespec;
+ Clock_Id : aliased Interfaces.C.int;
+ Result : Interfaces.C.int;
+
+ function To_CPU_Time is
+ new Ada.Unchecked_Conversion (Duration, CPU_Time);
+ -- Time is equal to Duration (although it is a private type) and
+ -- CPU_Time is equal to Time.
+
+ function Convert_Ids is new
+ Ada.Unchecked_Conversion (Task_Id, System.Tasking.Task_Id);
+
+ function clock_gettime
+ (clock_id : Interfaces.C.int;
+ tp : access timespec)
+ return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+ -- Function from the POSIX.1b Realtime Extensions library
+
+ function pthread_getcpuclockid
+ (tid : Thread_Id;
+ clock_id : access Interfaces.C.int)
+ return int;
+ pragma Import (C, pthread_getcpuclockid, "pthread_getcpuclockid");
+ -- Function from the Thread CPU-Time Clocks option
+
+ begin
+ if T = Ada.Task_Identification.Null_Task_Id then
+ raise Program_Error;
+ else
+ -- Get the CPU clock for the task passed as parameter
+
+ Result := pthread_getcpuclockid
+ (Get_Thread_Id (Convert_Ids (T)), Clock_Id'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := clock_gettime
+ (clock_id => Clock_Id, tp => TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ return To_CPU_Time (To_Duration (TS));
+ end Clock;
+
+ --------------------------
+ -- Clock_For_Interrupts --
+ --------------------------
+
+ function Clock_For_Interrupts return CPU_Time is
+ begin
+ -- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
+ -- is set to False the function raises Program_Error.
+
+ raise Program_Error;
+ return CPU_Time_First;
+ end Clock_For_Interrupts;
+
+ -----------
+ -- Split --
+ -----------
+
+ procedure Split
+ (T : CPU_Time;
+ SC : out Ada.Real_Time.Seconds_Count;
+ TS : out Ada.Real_Time.Time_Span)
+ is
+
+ begin
+ Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
+ end Split;
+
+ -------------
+ -- Time_Of --
+ -------------
+
+ function Time_Of
+ (SC : Ada.Real_Time.Seconds_Count;
+ TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
+ return CPU_Time
+ is
+ begin
+ return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
+ end Time_Of;
+
+end Ada.Execution_Time;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X E C U T I O N _ T I M E --
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a AIX version of this package
+
+-- The following signals are reserved by the run time (native threads):
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGEMT
+-- SIGSTOP, SIGKILL
+
+-- The following signals are reserved by the run time (FSU threads):
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGALRM,
+-- SIGWAITING, SIGSTOP, SIGKILL
+
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+
+-- SIGINT: made available for Ada handler
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+
+package Ada.Interrupts.Names is
+
+ -- All identifiers in this unit are implementation defined
+
+ pragma Implementation_Defined;
+
+ -- Beware that the mapping of names to signals may be many-to-one. There
+ -- may be aliases. Also, for all signal names that are not supported on
+ -- the current system the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- used by abort,
+ System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
+
+ SIGEMT : constant Interrupt_ID :=
+ System.OS_Interface.SIGEMT; -- EMT instruction
+
+ SIGFPE : constant Interrupt_ID :=
+ System.OS_Interface.SIGFPE; -- floating point exception
+
+ SIGKILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
+
+ SIGBUS : constant Interrupt_ID :=
+ System.OS_Interface.SIGBUS; -- bus error
+
+ SIGSEGV : constant Interrupt_ID :=
+ System.OS_Interface.SIGSEGV; -- segmentation violation
+
+ SIGSYS : constant Interrupt_ID :=
+ System.OS_Interface.SIGSYS; -- bad argument to system call
+
+ SIGPIPE : constant Interrupt_ID := -- write on a pipe with
+ System.OS_Interface.SIGPIPE; -- no one to read it
+
+ SIGALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGALRM; -- alarm clock
+
+ SIGTERM : constant Interrupt_ID :=
+ System.OS_Interface.SIGTERM; -- software termination signal from kill
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+ SIGCLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCLD; -- child status change
+
+ SIGCHLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
+
+ SIGPWR : constant Interrupt_ID :=
+ System.OS_Interface.SIGPWR; -- power-fail restart
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ SIGPOLL : constant Interrupt_ID :=
+ System.OS_Interface.SIGPOLL; -- pollable event occurred
+
+ SIGIO : constant Interrupt_ID := -- input/output possible,
+ System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
+
+ SIGSTOP : constant Interrupt_ID :=
+ System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
+
+ SIGTSTP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTSTP; -- user stop requested from tty
+
+ SIGCONT : constant Interrupt_ID :=
+ System.OS_Interface.SIGCONT; -- stopped process has been continued
+
+ SIGTTIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTIN; -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTOU; -- background tty write attempted
+
+ SIGVTALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGVTALRM; -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID :=
+ System.OS_Interface.SIGPROF; -- profiling timer expired
+
+ SIGXCPU : constant Interrupt_ID :=
+ System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
+
+ SIGXFSZ : constant Interrupt_ID :=
+ System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
+
+ SIGMSG : constant Interrupt_ID :=
+ System.OS_Interface.SIGMSG; -- input data is in the ring buffer
+
+ SIGDANGER : constant Interrupt_ID :=
+ System.OS_Interface.SIGDANGER; -- system crash imminent;
+
+ SIGMIGRATE : constant Interrupt_ID :=
+ System.OS_Interface.SIGMIGRATE; -- migrate process
+
+ SIGPRE : constant Interrupt_ID :=
+ System.OS_Interface.SIGPRE; -- programming exception
+
+ SIGVIRT : constant Interrupt_ID :=
+ System.OS_Interface.SIGVIRT; -- AIX virtual time alarm
+
+ SIGALRM1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGALRM1; -- m:n condition variables
+
+ SIGWAITING : constant Interrupt_ID :=
+ System.OS_Interface.SIGWAITING; -- m:n scheduling
+
+ SIGKAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGKAP; -- keep alive poll from native keyboard
+
+ SIGGRANT : constant Interrupt_ID :=
+ System.OS_Interface.SIGGRANT; -- monitor mode granted
+
+ SIGRETRACT : constant Interrupt_ID :=
+ System.OS_Interface.SIGRETRACT; -- monitor mode should be relinquished
+
+ SIGSOUND : constant Interrupt_ID :=
+ System.OS_Interface.SIGSOUND; -- sound control has completed
+
+ SIGSAK : constant Interrupt_ID :=
+ System.OS_Interface.SIGSAK; -- secure attention key
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Darwin version of this package
+
+-- The following signals are reserved by the run time:
+
+-- SIGSTOP, SIGKILL
+
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+
+-- SIGINT: made available for Ada handler
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+
+package Ada.Interrupts.Names is
+
+ -- All identifiers in this unit are implementation defined
+
+ pragma Implementation_Defined;
+
+ -- Beware that the mapping of names to signals may be many-to-one. There
+ -- may be aliases. Also, for all signal names that are not supported on the
+ -- current system the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- used by abort,
+ System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
+
+ SIGEMT : constant Interrupt_ID :=
+ System.OS_Interface.SIGEMT; -- EMT instruction
+
+ SIGFPE : constant Interrupt_ID :=
+ System.OS_Interface.SIGFPE; -- floating point exception
+
+ SIGKILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
+
+ SIGBUS : constant Interrupt_ID :=
+ System.OS_Interface.SIGBUS; -- bus error
+
+ SIGSEGV : constant Interrupt_ID :=
+ System.OS_Interface.SIGSEGV; -- segmentation violation
+
+ SIGSYS : constant Interrupt_ID :=
+ System.OS_Interface.SIGSYS; -- bad argument to system call
+
+ SIGPIPE : constant Interrupt_ID := -- write on a pipe with
+ System.OS_Interface.SIGPIPE; -- no one to read it
+
+ SIGALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGALRM; -- alarm clock
+
+ SIGTERM : constant Interrupt_ID :=
+ System.OS_Interface.SIGTERM; -- software termination signal from kill
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ SIGSTOP : constant Interrupt_ID :=
+ System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
+
+ SIGTSTP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTSTP; -- user stop requested from tty
+
+ SIGCONT : constant Interrupt_ID :=
+ System.OS_Interface.SIGCONT; -- stopped process has been continued
+
+ SIGCHLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
+
+ SIGTTIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTIN; -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTOU; -- background tty write attempted
+
+ SIGIO : constant Interrupt_ID := -- input/output possible,
+ System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
+
+ SIGXCPU : constant Interrupt_ID :=
+ System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
+
+ SIGXFSZ : constant Interrupt_ID :=
+ System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
+
+ SIGVTALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGVTALRM; -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID :=
+ System.OS_Interface.SIGPROF; -- profiling timer expired
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGINFO : constant Interrupt_ID :=
+ System.OS_Interface.SIGINFO; -- information request
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- (No Tasking Version) --
+-- --
+-- Copyright (C) 1991-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- The standard implementation of this spec contains only dummy interrupt
+-- names. These dummy entries permit checking out code for correctness of
+-- semantics, even if interrupts are not supported.
+
+-- For specific implementations that fully support interrupts, this package
+-- spec is replaced by an implementation dependent version that defines the
+-- interrupts available on the system.
+
+package Ada.Interrupts.Names is
+
+ -- All identifiers in this unit are implementation defined
+
+ pragma Implementation_Defined;
+
+ DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1;
+ DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2;
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the FreeBSD THREADS version of this package
+
+with System.OS_Interface;
+
+package Ada.Interrupts.Names is
+
+ -- All identifiers in this unit are implementation defined
+
+ pragma Implementation_Defined;
+
+ -- Beware that the mapping of names to signals may be many-to-one. There
+ -- may be aliases. Also, for all signal names that are not supported on
+ -- the current system the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- used by abort,
+ System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
+
+ SIGFPE : constant Interrupt_ID :=
+ System.OS_Interface.SIGFPE; -- floating point exception
+
+ SIGKILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
+
+ SIGBUS : constant Interrupt_ID :=
+ System.OS_Interface.SIGBUS; -- bus error
+
+ SIGSEGV : constant Interrupt_ID :=
+ System.OS_Interface.SIGSEGV; -- segmentation violation
+
+ SIGPIPE : constant Interrupt_ID := -- write on a pipe with
+ System.OS_Interface.SIGPIPE; -- no one to read it
+
+ SIGALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGALRM; -- alarm clock
+
+ SIGTERM : constant Interrupt_ID :=
+ System.OS_Interface.SIGTERM; -- software termination signal from kill
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ SIGSTOP : constant Interrupt_ID :=
+ System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
+
+ SIGTSTP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTSTP; -- user stop requested from tty
+
+ SIGCONT : constant Interrupt_ID :=
+ System.OS_Interface.SIGCONT; -- stopped process has been continued
+
+ SIGCHLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
+
+ SIGCLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCLD; -- child status change
+
+ SIGTTIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTIN; -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTOU; -- background tty write attempted
+
+ SIGIO : constant Interrupt_ID := -- input/output possible,
+ System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
+
+ SIGXCPU : constant Interrupt_ID :=
+ System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
+
+ SIGXFSZ : constant Interrupt_ID :=
+ System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
+
+ SIGVTALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGVTALRM; -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID :=
+ System.OS_Interface.SIGPROF; -- profiling timer expired
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a HP-UX version of this package
+
+-- The following signals are reserved by the run time:
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT,
+-- SIGALRM, SIGSTOP, SIGKILL
+
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+
+-- SIGINT: made available for Ada handler
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+
+package Ada.Interrupts.Names is
+
+ -- All identifiers in this unit are implementation defined
+
+ pragma Implementation_Defined;
+
+ -- Beware that the mapping of names to signals may be many-to-one. There
+ -- may be aliases. Also, for all signal names that are not supported on
+ -- the current system the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- used by abort,
+ System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
+
+ SIGEMT : constant Interrupt_ID :=
+ System.OS_Interface.SIGEMT; -- EMT instruction
+
+ SIGFPE : constant Interrupt_ID :=
+ System.OS_Interface.SIGFPE; -- floating point exception
+
+ SIGKILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
+
+ SIGBUS : constant Interrupt_ID :=
+ System.OS_Interface.SIGBUS; -- bus error
+
+ SIGSEGV : constant Interrupt_ID :=
+ System.OS_Interface.SIGSEGV; -- segmentation violation
+
+ SIGSYS : constant Interrupt_ID :=
+ System.OS_Interface.SIGSYS; -- bad argument to system call
+
+ SIGPIPE : constant Interrupt_ID := -- write on a pipe with
+ System.OS_Interface.SIGPIPE; -- no one to read it
+
+ SIGALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGALRM; -- alarm clock
+
+ SIGTERM : constant Interrupt_ID :=
+ System.OS_Interface.SIGTERM; -- software termination signal from kill
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+ SIGCLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCLD; -- child status change
+
+ SIGCHLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ SIGPOLL : constant Interrupt_ID :=
+ System.OS_Interface.SIGPOLL; -- pollable event occurred
+
+ SIGIO : constant Interrupt_ID := -- input/output possible,
+ System.OS_Interface.SIGIO; -- SIGPOLL alias
+
+ SIGSTOP : constant Interrupt_ID :=
+ System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
+
+ SIGTSTP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTSTP; -- user stop requested from tty
+
+ SIGCONT : constant Interrupt_ID :=
+ System.OS_Interface.SIGCONT; -- stopped process has been continued
+
+ SIGTTIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTIN; -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTOU; -- background tty write attempted
+
+ SIGVTALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGVTALRM; -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID :=
+ System.OS_Interface.SIGPROF; -- profiling timer expired
+
+ SIGPWR : constant Interrupt_ID :=
+ System.OS_Interface.SIGPWR; -- power-fail restart
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a GNU/Linux version of this package
+
+-- The following signals are reserved by the run time:
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGUSR1, SIGUSR2, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL
+
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+
+-- SIGINT: made available for Ada handler
+
+-- This target-dependent package spec contains names of interrupts
+-- supported by the local system.
+
+with System.OS_Interface;
+
+package Ada.Interrupts.Names is
+
+ -- All identifiers in this unit are implementation defined
+
+ pragma Implementation_Defined;
+
+ -- Beware that the mapping of names to signals may be many-to-one. There
+ -- may be aliases. Also, for all signal names that are not supported on the
+ -- current system the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- used by abort,
+ System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
+
+ SIGFPE : constant Interrupt_ID :=
+ System.OS_Interface.SIGFPE; -- floating point exception
+
+ SIGKILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
+
+ SIGBUS : constant Interrupt_ID :=
+ System.OS_Interface.SIGBUS; -- bus error
+
+ SIGSEGV : constant Interrupt_ID :=
+ System.OS_Interface.SIGSEGV; -- segmentation violation
+
+ SIGPIPE : constant Interrupt_ID := -- write on a pipe with
+ System.OS_Interface.SIGPIPE; -- no one to read it
+
+ SIGALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGALRM; -- alarm clock
+
+ SIGTERM : constant Interrupt_ID :=
+ System.OS_Interface.SIGTERM; -- software termination signal from kill
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+ SIGCLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCLD; -- child status change
+
+ SIGCHLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ SIGPOLL : constant Interrupt_ID :=
+ System.OS_Interface.SIGPOLL; -- pollable event occurred
+
+ SIGIO : constant Interrupt_ID := -- input/output possible,
+ System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
+
+ SIGSTOP : constant Interrupt_ID :=
+ System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
+
+ SIGTSTP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTSTP; -- user stop requested from tty
+
+ SIGCONT : constant Interrupt_ID :=
+ System.OS_Interface.SIGCONT; -- stopped process has been continued
+
+ SIGTTIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTIN; -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTOU; -- background tty write attempted
+
+ SIGVTALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGVTALRM; -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID :=
+ System.OS_Interface.SIGPROF; -- profiling timer expired
+
+ SIGXCPU : constant Interrupt_ID :=
+ System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
+
+ SIGXFSZ : constant Interrupt_ID :=
+ System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
+
+ SIGUNUSED : constant Interrupt_ID :=
+ System.OS_Interface.SIGUNUSED; -- unused signal
+
+ SIGSTKFLT : constant Interrupt_ID :=
+ System.OS_Interface.SIGSTKFLT; -- stack fault on coprocessor
+
+ SIGLOST : constant Interrupt_ID :=
+ System.OS_Interface.SIGLOST; -- Linux alias for SIGIO
+
+ SIGPWR : constant Interrupt_ID :=
+ System.OS_Interface.SIGPWR; -- Power failure
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1997-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a NT (native) version of this package
+
+-- This target-dependent package spec contains names of interrupts supported
+-- by the local system.
+
+with System.OS_Interface;
+
+package Ada.Interrupts.Names is
+
+ -- All identifiers in this unit are implementation defined
+
+ pragma Implementation_Defined;
+
+ -- Beware that the mapping of names to signals may be many-to-one. There
+ -- may be aliases. Also, for all signal names that are not supported on the
+ -- current system the value of the corresponding constant will be zero.
+
+ SIGINT : constant Interrupt_ID := -- interrupt (rubout)
+ System.OS_Interface.SIGINT;
+
+ SIGILL : constant Interrupt_ID := -- illegal instruction (not reset)
+ System.OS_Interface.SIGILL;
+
+ SIGABRT : constant Interrupt_ID := -- used by abort (use SIGIOT in future)
+ System.OS_Interface.SIGABRT;
+
+ SIGFPE : constant Interrupt_ID := -- floating point exception
+ System.OS_Interface.SIGFPE;
+
+ SIGSEGV : constant Interrupt_ID := -- segmentation violation
+ System.OS_Interface.SIGSEGV;
+
+ SIGTERM : constant Interrupt_ID := -- software termination signal from kill
+ System.OS_Interface.SIGTERM;
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris version of this package
+
+-- The following signals are reserved by the run time (native threads):
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
+-- SIGLWP, SIGWAITING, SIGCANCEL, SIGSTOP, SIGKILL
+
+-- The following signals are reserved by the run time (FSU threads):
+
+-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT,
+-- SIGLWP, SIGALRM, SIGVTALRM, SIGWAITING, SIGSTOP, SIGKILL
+
+-- The pragma Unreserve_All_Interrupts affects the following signal(s):
+
+-- SIGINT: made available for Ada handlers
+
+with System.OS_Interface;
+
+package Ada.Interrupts.Names is
+
+ -- All identifiers in this unit are implementation defined
+
+ pragma Implementation_Defined;
+
+ -- Beware that the mapping of names to signals may be many-to-one. There
+ -- may be aliases. Also, for all signal names that are not supported on the
+ -- current system the value of the corresponding constant will be zero.
+
+ SIGHUP : constant Interrupt_ID :=
+ System.OS_Interface.SIGHUP; -- hangup
+
+ SIGINT : constant Interrupt_ID :=
+ System.OS_Interface.SIGINT; -- interrupt (rubout)
+
+ SIGQUIT : constant Interrupt_ID :=
+ System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
+
+ SIGILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+
+ SIGTRAP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTRAP; -- trace trap (not reset)
+
+ SIGIOT : constant Interrupt_ID :=
+ System.OS_Interface.SIGIOT; -- IOT instruction
+
+ SIGABRT : constant Interrupt_ID := -- used by abort,
+ System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
+
+ SIGEMT : constant Interrupt_ID :=
+ System.OS_Interface.SIGEMT; -- EMT instruction
+
+ SIGFPE : constant Interrupt_ID :=
+ System.OS_Interface.SIGFPE; -- floating point exception
+
+ SIGKILL : constant Interrupt_ID :=
+ System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
+
+ SIGBUS : constant Interrupt_ID :=
+ System.OS_Interface.SIGBUS; -- bus error
+
+ SIGSEGV : constant Interrupt_ID :=
+ System.OS_Interface.SIGSEGV; -- segmentation violation
+
+ SIGSYS : constant Interrupt_ID :=
+ System.OS_Interface.SIGSYS; -- bad argument to system call
+
+ SIGPIPE : constant Interrupt_ID := -- write on a pipe with
+ System.OS_Interface.SIGPIPE; -- no one to read it
+
+ SIGALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGALRM; -- alarm clock
+
+ SIGTERM : constant Interrupt_ID :=
+ System.OS_Interface.SIGTERM; -- software termination signal from kill
+
+ SIGUSR1 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR1; -- user defined signal 1
+
+ SIGUSR2 : constant Interrupt_ID :=
+ System.OS_Interface.SIGUSR2; -- user defined signal 2
+
+ SIGCLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCLD; -- child status change
+
+ SIGCHLD : constant Interrupt_ID :=
+ System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
+
+ SIGWINCH : constant Interrupt_ID :=
+ System.OS_Interface.SIGWINCH; -- window size change
+
+ SIGURG : constant Interrupt_ID :=
+ System.OS_Interface.SIGURG; -- urgent condition on IO channel
+
+ SIGPOLL : constant Interrupt_ID :=
+ System.OS_Interface.SIGPOLL; -- pollable event occurred
+
+ SIGIO : constant Interrupt_ID := -- input/output possible,
+ System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
+
+ SIGSTOP : constant Interrupt_ID :=
+ System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
+
+ SIGTSTP : constant Interrupt_ID :=
+ System.OS_Interface.SIGTSTP; -- user stop requested from tty
+
+ SIGCONT : constant Interrupt_ID :=
+ System.OS_Interface.SIGCONT; -- stopped process has been continued
+
+ SIGTTIN : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTIN; -- background tty read attempted
+
+ SIGTTOU : constant Interrupt_ID :=
+ System.OS_Interface.SIGTTOU; -- background tty write attempted
+
+ SIGVTALRM : constant Interrupt_ID :=
+ System.OS_Interface.SIGVTALRM; -- virtual timer expired
+
+ SIGPROF : constant Interrupt_ID :=
+ System.OS_Interface.SIGPROF; -- profiling timer expired
+
+ SIGXCPU : constant Interrupt_ID :=
+ System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
+
+ SIGXFSZ : constant Interrupt_ID :=
+ System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
+
+ SIGPWR : constant Interrupt_ID :=
+ System.OS_Interface.SIGPWR; -- power-fail restart
+
+ SIGWAITING : constant Interrupt_ID :=
+ System.OS_Interface.SIGWAITING; -- process's lwps blocked (Solaris)
+
+ SIGLWP : constant Interrupt_ID :=
+ System.OS_Interface.SIGLWP; -- used by thread library (Solaris)
+
+ SIGFREEZE : constant Interrupt_ID :=
+ System.OS_Interface.SIGFREEZE; -- used by CPR (Solaris)
+
+-- what is CPR????
+
+ SIGTHAW : constant Interrupt_ID :=
+ System.OS_Interface.SIGTHAW; -- used by CPR (Solaris)
+
+ SIGCANCEL : constant Interrupt_ID :=
+ System.OS_Interface.SIGCANCEL; -- used for thread cancel (Solaris)
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . I N T E R R U P T S . N A M E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks version of this package
+
+with System.OS_Interface;
+
+package Ada.Interrupts.Names is
+
+ -- All identifiers in this unit are implementation defined
+
+ pragma Implementation_Defined;
+
+ subtype Hardware_Interrupts is Interrupt_ID
+ range Interrupt_ID'First .. System.OS_Interface.Max_HW_Interrupt;
+ -- Range of values that can be used for hardware interrupts
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- The standard implementation of this spec contains only dummy interrupt
+-- names. These dummy entries permit checking out code for correctness of
+-- semantics, even if interrupts are not supported.
+
+-- For specific implementations that fully support interrupts, this package
+-- spec is replaced by an implementation dependent version that defines the
+-- interrupts available on the system.
+
+package Ada.Interrupts.Names is
+
+ -- All identifiers in this unit are implementation defined
+
+ pragma Implementation_Defined;
+
+ DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1;
+ DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2;
+
+end Ada.Interrupts.Names;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S Y N C H R O N O U S _ B A R R I E R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the body of this package using POSIX barriers
+
+with Interfaces.C; use Interfaces.C;
+
+package body Ada.Synchronous_Barriers is
+
+ --------------------
+ -- POSIX barriers --
+ --------------------
+
+ function pthread_barrier_init
+ (barrier : not null access pthread_barrier_t;
+ attr : System.Address := System.Null_Address;
+ count : unsigned) return int;
+ pragma Import (C, pthread_barrier_init, "pthread_barrier_init");
+ -- Initialize barrier with the attributes in attr. The barrier is opened
+ -- when count waiters arrived. If attr is null the default barrier
+ -- attributes are used.
+
+ function pthread_barrier_destroy
+ (barrier : not null access pthread_barrier_t) return int;
+ pragma Import (C, pthread_barrier_destroy, "pthread_barrier_destroy");
+ -- Destroy a previously dynamically initialized barrier
+
+ function pthread_barrier_wait
+ (barrier : not null access pthread_barrier_t) return int;
+ pragma Import (C, pthread_barrier_wait, "pthread_barrier_wait");
+ -- Wait on barrier
+
+ --------------
+ -- Finalize --
+ --------------
+
+ overriding procedure Finalize (Barrier : in out Synchronous_Barrier) is
+ Result : int;
+ begin
+ Result := pthread_barrier_destroy (Barrier.POSIX_Barrier'Access);
+ pragma Assert (Result = 0);
+ end Finalize;
+
+ overriding procedure Initialize (Barrier : in out Synchronous_Barrier) is
+ Result : int;
+ begin
+ Result :=
+ pthread_barrier_init
+ (barrier => Barrier.POSIX_Barrier'Access,
+ attr => System.Null_Address,
+ count => unsigned (Barrier.Release_Threshold));
+ pragma Assert (Result = 0);
+ end Initialize;
+
+ ----------------------
+ -- Wait_For_Release --
+ ----------------------
+
+ procedure Wait_For_Release
+ (The_Barrier : in out Synchronous_Barrier;
+ Notified : out Boolean)
+ is
+ Result : int;
+
+ PTHREAD_BARRIER_SERIAL_THREAD : constant := -1;
+ -- Value used to indicate the task which receives the notification for
+ -- the barrier open.
+
+ begin
+ Result :=
+ pthread_barrier_wait
+ (barrier => The_Barrier.POSIX_Barrier'Access);
+ pragma Assert
+ (Result = 0 or else Result = PTHREAD_BARRIER_SERIAL_THREAD);
+
+ Notified := (Result = PTHREAD_BARRIER_SERIAL_THREAD);
+ end Wait_For_Release;
+
+end Ada.Synchronous_Barriers;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S Y N C H R O N O U S _ B A R R I E R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the spec of this package using POSIX barriers
+
+with System;
+private with Ada.Finalization;
+private with Interfaces.C;
+
+package Ada.Synchronous_Barriers is
+ pragma Preelaborate (Synchronous_Barriers);
+
+ subtype Barrier_Limit is Positive range 1 .. Positive'Last;
+
+ type Synchronous_Barrier (Release_Threshold : Barrier_Limit) is
+ limited private;
+
+ procedure Wait_For_Release
+ (The_Barrier : in out Synchronous_Barrier;
+ Notified : out Boolean);
+
+private
+ -- POSIX barrier data type
+
+ SIZEOF_PTHREAD_BARRIER_T : constant :=
+ (if System.Word_Size = 64 then 32 else 20);
+ -- Value defined according to the linux definition in pthreadtypes.h. On
+ -- other system, e.g. MIPS IRIX, the object is smaller, so it works
+ -- correctly although we are wasting some space.
+
+ type pthread_barrier_t_view is (size_based, align_based);
+
+ type pthread_barrier_t (Kind : pthread_barrier_t_view := size_based) is
+ record
+ case Kind is
+ when size_based =>
+ size : Interfaces.C.char_array (1 .. SIZEOF_PTHREAD_BARRIER_T);
+ when align_based =>
+ align : Interfaces.C.long;
+ end case;
+ end record;
+ pragma Unchecked_Union (pthread_barrier_t);
+
+ type Synchronous_Barrier (Release_Threshold : Barrier_Limit) is
+ new Ada.Finalization.Limited_Controlled with
+ record
+ POSIX_Barrier : aliased pthread_barrier_t;
+ end record;
+
+ overriding procedure Initialize (Barrier : in out Synchronous_Barrier);
+ overriding procedure Finalize (Barrier : in out Synchronous_Barrier);
+end Ada.Synchronous_Barriers;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S Y N C H R O N O U S _ B A R R I E R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S Y N C H R O N O U S _ B A R R I E R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Task_Identification;
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Task_Identification; 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a NO tasking version of this package
+
+package body System.Interrupt_Management.Operations is
+
+ -- Turn off warnings since many unused formals
+
+ pragma Warnings (Off);
+
+ ----------------------------
+ -- Thread_Block_Interrupt --
+ ----------------------------
+
+ procedure Thread_Block_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ begin
+ null;
+ end Thread_Block_Interrupt;
+
+ ------------------------------
+ -- Thread_Unblock_Interrupt --
+ ------------------------------
+
+ procedure Thread_Unblock_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ begin
+ null;
+ end Thread_Unblock_Interrupt;
+
+ ------------------------
+ -- Set_Interrupt_Mask --
+ ------------------------
+
+ procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Set_Interrupt_Mask;
+
+ procedure Set_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ OMask : access Interrupt_Mask) is
+ begin
+ null;
+ end Set_Interrupt_Mask;
+
+ ------------------------
+ -- Get_Interrupt_Mask --
+ ------------------------
+
+ procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Get_Interrupt_Mask;
+
+ --------------------
+ -- Interrupt_Wait --
+ --------------------
+
+ function Interrupt_Wait
+ (Mask : access Interrupt_Mask)
+ return Interrupt_ID
+ is
+ begin
+ return 0;
+ end Interrupt_Wait;
+
+ ----------------------------
+ -- Install_Default_Action --
+ ----------------------------
+
+ procedure Install_Default_Action (Interrupt : Interrupt_ID) is
+ begin
+ null;
+ end Install_Default_Action;
+
+ ---------------------------
+ -- Install_Ignore_Action --
+ ---------------------------
+
+ procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
+ begin
+ null;
+ end Install_Ignore_Action;
+
+ -------------------------
+ -- Fill_Interrupt_Mask --
+ -------------------------
+
+ procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Fill_Interrupt_Mask;
+
+ --------------------------
+ -- Empty_Interrupt_Mask --
+ --------------------------
+
+ procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ begin
+ null;
+ end Empty_Interrupt_Mask;
+
+ ---------------------------
+ -- Add_To_Interrupt_Mask --
+ ---------------------------
+
+ procedure Add_To_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ begin
+ null;
+ end Add_To_Interrupt_Mask;
+
+ --------------------------------
+ -- Delete_From_Interrupt_Mask --
+ --------------------------------
+
+ procedure Delete_From_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ begin
+ null;
+ end Delete_From_Interrupt_Mask;
+
+ ---------------
+ -- Is_Member --
+ ---------------
+
+ function Is_Member
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID) return Boolean
+ is
+ begin
+ return False;
+ end Is_Member;
+
+ -------------------------
+ -- Copy_Interrupt_Mask --
+ -------------------------
+
+ procedure Copy_Interrupt_Mask
+ (X : out Interrupt_Mask;
+ Y : Interrupt_Mask)
+ is
+ begin
+ X := Y;
+ end Copy_Interrupt_Mask;
+
+ -------------------------
+ -- Interrupt_Self_Process --
+ -------------------------
+
+ procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
+ begin
+ null;
+ end Interrupt_Self_Process;
+
+ --------------------------
+ -- Setup_Interrupt_Mask --
+ --------------------------
+
+ procedure Setup_Interrupt_Mask is
+ begin
+ null;
+ end Setup_Interrupt_Mask;
+
+end System.Interrupt_Management.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a POSIX-like version of this package
+
+-- Note: this file can only be used for POSIX compliant systems
+
+with Interfaces.C;
+
+with System.OS_Interface;
+with System.Storage_Elements;
+
+package body System.Interrupt_Management.Operations is
+
+ use Interfaces.C;
+ use System.OS_Interface;
+
+ ---------------------
+ -- Local Variables --
+ ---------------------
+
+ Initial_Action : array (Signal) of aliased struct_sigaction;
+
+ Default_Action : aliased struct_sigaction;
+ pragma Warnings (Off, Default_Action);
+
+ Ignore_Action : aliased struct_sigaction;
+
+ ----------------------------
+ -- Thread_Block_Interrupt --
+ ----------------------------
+
+ procedure Thread_Block_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ Result : Interfaces.C.int;
+ Mask : aliased sigset_t;
+ begin
+ Result := sigemptyset (Mask'Access);
+ pragma Assert (Result = 0);
+ Result := sigaddset (Mask'Access, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ Result := pthread_sigmask (SIG_BLOCK, Mask'Access, null);
+ pragma Assert (Result = 0);
+ end Thread_Block_Interrupt;
+
+ ------------------------------
+ -- Thread_Unblock_Interrupt --
+ ------------------------------
+
+ procedure Thread_Unblock_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ Mask : aliased sigset_t;
+ Result : Interfaces.C.int;
+ begin
+ Result := sigemptyset (Mask'Access);
+ pragma Assert (Result = 0);
+ Result := sigaddset (Mask'Access, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ Result := pthread_sigmask (SIG_UNBLOCK, Mask'Access, null);
+ pragma Assert (Result = 0);
+ end Thread_Unblock_Interrupt;
+
+ ------------------------
+ -- Set_Interrupt_Mask --
+ ------------------------
+
+ procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_sigmask (SIG_SETMASK, Mask, null);
+ pragma Assert (Result = 0);
+ end Set_Interrupt_Mask;
+
+ procedure Set_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ OMask : access Interrupt_Mask)
+ is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_sigmask (SIG_SETMASK, Mask, OMask);
+ pragma Assert (Result = 0);
+ end Set_Interrupt_Mask;
+
+ ------------------------
+ -- Get_Interrupt_Mask --
+ ------------------------
+
+ procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_sigmask (SIG_SETMASK, null, Mask);
+ pragma Assert (Result = 0);
+ end Get_Interrupt_Mask;
+
+ --------------------
+ -- Interrupt_Wait --
+ --------------------
+
+ function Interrupt_Wait
+ (Mask : access Interrupt_Mask) return Interrupt_ID
+ is
+ Result : Interfaces.C.int;
+ Sig : aliased Signal;
+
+ begin
+ Result := sigwait (Mask, Sig'Access);
+
+ if Result /= 0 then
+ return 0;
+ end if;
+
+ return Interrupt_ID (Sig);
+ end Interrupt_Wait;
+
+ ----------------------------
+ -- Install_Default_Action --
+ ----------------------------
+
+ procedure Install_Default_Action (Interrupt : Interrupt_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigaction
+ (Signal (Interrupt),
+ Initial_Action (Signal (Interrupt))'Access, null);
+ pragma Assert (Result = 0);
+ end Install_Default_Action;
+
+ ---------------------------
+ -- Install_Ignore_Action --
+ ---------------------------
+
+ procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
+ pragma Assert (Result = 0);
+ end Install_Ignore_Action;
+
+ -------------------------
+ -- Fill_Interrupt_Mask --
+ -------------------------
+
+ procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigfillset (Mask);
+ pragma Assert (Result = 0);
+ end Fill_Interrupt_Mask;
+
+ --------------------------
+ -- Empty_Interrupt_Mask --
+ --------------------------
+
+ procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigemptyset (Mask);
+ pragma Assert (Result = 0);
+ end Empty_Interrupt_Mask;
+
+ ---------------------------
+ -- Add_To_Interrupt_Mask --
+ ---------------------------
+
+ procedure Add_To_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigaddset (Mask, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ end Add_To_Interrupt_Mask;
+
+ --------------------------------
+ -- Delete_From_Interrupt_Mask --
+ --------------------------------
+
+ procedure Delete_From_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigdelset (Mask, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ end Delete_From_Interrupt_Mask;
+
+ ---------------
+ -- Is_Member --
+ ---------------
+
+ function Is_Member
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID) return Boolean
+ is
+ Result : Interfaces.C.int;
+ begin
+ Result := sigismember (Mask, Signal (Interrupt));
+ pragma Assert (Result = 0 or else Result = 1);
+ return Result = 1;
+ end Is_Member;
+
+ -------------------------
+ -- Copy_Interrupt_Mask --
+ -------------------------
+
+ procedure Copy_Interrupt_Mask
+ (X : out Interrupt_Mask;
+ Y : Interrupt_Mask) is
+ begin
+ X := Y;
+ end Copy_Interrupt_Mask;
+
+ ----------------------------
+ -- Interrupt_Self_Process --
+ ----------------------------
+
+ procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := kill (getpid, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ end Interrupt_Self_Process;
+
+ --------------------------
+ -- Setup_Interrupt_Mask --
+ --------------------------
+
+ procedure Setup_Interrupt_Mask is
+ begin
+ -- Mask task for all signals. The original mask of the Environment task
+ -- will be recovered by Interrupt_Manager task during the elaboration
+ -- of s-interr.adb.
+
+ Set_Interrupt_Mask (All_Tasks_Mask'Access);
+ end Setup_Interrupt_Mask;
+
+begin
+ declare
+ mask : aliased sigset_t;
+ allmask : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ begin
+ Interrupt_Management.Initialize;
+
+ for Sig in 1 .. Signal'Last loop
+ Result := sigaction
+ (Sig, null, Initial_Action (Sig)'Access);
+
+ -- ??? [assert 1]
+ -- we can't check Result here since sigaction will fail on
+ -- SIGKILL, SIGSTOP, and possibly other signals
+ -- pragma Assert (Result = 0);
+
+ end loop;
+
+ -- Setup the masks to be exported
+
+ Result := sigemptyset (mask'Access);
+ pragma Assert (Result = 0);
+
+ Result := sigfillset (allmask'Access);
+ pragma Assert (Result = 0);
+
+ Default_Action.sa_flags := 0;
+ Default_Action.sa_mask := mask;
+ Default_Action.sa_handler :=
+ Storage_Elements.To_Address
+ (Storage_Elements.Integer_Address (SIG_DFL));
+
+ Ignore_Action.sa_flags := 0;
+ Ignore_Action.sa_mask := mask;
+ Ignore_Action.sa_handler :=
+ Storage_Elements.To_Address
+ (Storage_Elements.Integer_Address (SIG_IGN));
+
+ for J in Interrupt_ID loop
+ if Keep_Unmasked (J) then
+ Result := sigaddset (mask'Access, Signal (J));
+ pragma Assert (Result = 0);
+ Result := sigdelset (allmask'Access, Signal (J));
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ -- The Keep_Unmasked signals should be unmasked for Environment task
+
+ Result := pthread_sigmask (SIG_UNBLOCK, mask'Access, null);
+ pragma Assert (Result = 0);
+
+ -- Get the signal mask of the Environment Task
+
+ Result := pthread_sigmask (SIG_SETMASK, null, mask'Access);
+ pragma Assert (Result = 0);
+
+ -- Setup the constants exported
+
+ Environment_Mask := Interrupt_Mask (mask);
+
+ All_Tasks_Mask := Interrupt_Mask (allmask);
+ end;
+
+end System.Interrupt_Management.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a VxWorks version of this package. Many operations are null as this
+-- package supports the use of Ada interrupt handling facilities for signals,
+-- while those facilities are used for hardware interrupts on these targets.
+
+with Ada.Exceptions;
+
+with Interfaces.C;
+
+with System.OS_Interface;
+
+package body System.Interrupt_Management.Operations is
+
+ use Ada.Exceptions;
+ use Interfaces.C;
+ use System.OS_Interface;
+
+ ----------------------------
+ -- Thread_Block_Interrupt --
+ ----------------------------
+
+ procedure Thread_Block_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ pragma Unreferenced (Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Thread_Block_Interrupt unimplemented");
+ end Thread_Block_Interrupt;
+
+ ------------------------------
+ -- Thread_Unblock_Interrupt --
+ ------------------------------
+
+ procedure Thread_Unblock_Interrupt
+ (Interrupt : Interrupt_ID)
+ is
+ pragma Unreferenced (Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Thread_Unblock_Interrupt unimplemented");
+ end Thread_Unblock_Interrupt;
+
+ ------------------------
+ -- Set_Interrupt_Mask --
+ ------------------------
+
+ procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ pragma Unreferenced (Mask);
+ begin
+ null;
+ end Set_Interrupt_Mask;
+
+ procedure Set_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ OMask : access Interrupt_Mask)
+ is
+ pragma Unreferenced (Mask, OMask);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Set_Interrupt_Mask unimplemented");
+ end Set_Interrupt_Mask;
+
+ ------------------------
+ -- Get_Interrupt_Mask --
+ ------------------------
+
+ procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ pragma Unreferenced (Mask);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Get_Interrupt_Mask unimplemented");
+ end Get_Interrupt_Mask;
+
+ --------------------
+ -- Interrupt_Wait --
+ --------------------
+
+ function Interrupt_Wait
+ (Mask : access Interrupt_Mask) return Interrupt_ID
+ is
+ pragma Unreferenced (Mask);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Interrupt_Wait unimplemented");
+ return 0;
+ end Interrupt_Wait;
+
+ ----------------------------
+ -- Install_Default_Action --
+ ----------------------------
+
+ procedure Install_Default_Action (Interrupt : Interrupt_ID) is
+ pragma Unreferenced (Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Install_Default_Action unimplemented");
+ end Install_Default_Action;
+
+ ---------------------------
+ -- Install_Ignore_Action --
+ ---------------------------
+
+ procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
+ pragma Unreferenced (Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Install_Ignore_Action unimplemented");
+ end Install_Ignore_Action;
+
+ -------------------------
+ -- Fill_Interrupt_Mask --
+ -------------------------
+
+ procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ pragma Unreferenced (Mask);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Fill_Interrupt_Mask unimplemented");
+ end Fill_Interrupt_Mask;
+
+ --------------------------
+ -- Empty_Interrupt_Mask --
+ --------------------------
+
+ procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ pragma Unreferenced (Mask);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Empty_Interrupt_Mask unimplemented");
+ end Empty_Interrupt_Mask;
+
+ ---------------------------
+ -- Add_To_Interrupt_Mask --
+ ---------------------------
+
+ procedure Add_To_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ pragma Unreferenced (Mask, Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Add_To_Interrupt_Mask unimplemented");
+ end Add_To_Interrupt_Mask;
+
+ --------------------------------
+ -- Delete_From_Interrupt_Mask --
+ --------------------------------
+
+ procedure Delete_From_Interrupt_Mask
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID)
+ is
+ pragma Unreferenced (Mask, Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Delete_From_Interrupt_Mask unimplemented");
+ end Delete_From_Interrupt_Mask;
+
+ ---------------
+ -- Is_Member --
+ ---------------
+
+ function Is_Member
+ (Mask : access Interrupt_Mask;
+ Interrupt : Interrupt_ID) return Boolean
+ is
+ pragma Unreferenced (Mask, Interrupt);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Is_Member unimplemented");
+ return False;
+ end Is_Member;
+
+ -------------------------
+ -- Copy_Interrupt_Mask --
+ -------------------------
+
+ procedure Copy_Interrupt_Mask
+ (X : out Interrupt_Mask;
+ Y : Interrupt_Mask) is
+ pragma Unreferenced (X, Y);
+ begin
+ Raise_Exception
+ (Program_Error'Identity,
+ "Copy_Interrupt_Mask unimplemented");
+ end Copy_Interrupt_Mask;
+
+ ----------------------------
+ -- Interrupt_Self_Process --
+ ----------------------------
+
+ procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := kill (getpid, Signal (Interrupt));
+ pragma Assert (Result = 0);
+ end Interrupt_Self_Process;
+
+ --------------------------
+ -- Setup_Interrupt_Mask --
+ --------------------------
+
+ procedure Setup_Interrupt_Mask is
+ begin
+ -- Nothing to be done. Ada interrupt facilities on VxWorks do not use
+ -- signals but hardware interrupts. Therefore, interrupt management does
+ -- not need anything related to signal masking. Note that this procedure
+ -- cannot raise an exception (as some others in this package) because
+ -- the generic implementation of the Timer_Server and timing events make
+ -- explicit calls to this routine to make ensure proper signal masking
+ -- on targets needed that.
+
+ null;
+ end Setup_Interrupt_Mask;
+
+end System.Interrupt_Management.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for systems that do not support interrupts (or signals)
+
+package body System.Interrupts is
+
+ pragma Warnings (Off); -- kill warnings on unreferenced formals
+
+ use System.Tasking;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Unimplemented;
+ -- This procedure raises a Program_Error with an appropriate message
+ -- indicating that an unimplemented feature has been used.
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Unimplemented;
+ end Attach_Handler;
+
+ -----------------------------
+ -- Bind_Interrupt_To_Entry --
+ -----------------------------
+
+ procedure Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Int_Ref : System.Address)
+ is
+ begin
+ Unimplemented;
+ end Bind_Interrupt_To_Entry;
+
+ ---------------------
+ -- Block_Interrupt --
+ ---------------------
+
+ procedure Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented;
+ end Block_Interrupt;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
+ is
+ begin
+ Unimplemented;
+ return null;
+ end Current_Handler;
+
+ --------------------
+ -- Detach_Handler --
+ --------------------
+
+ procedure Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Unimplemented;
+ end Detach_Handler;
+
+ ------------------------------
+ -- Detach_Interrupt_Entries --
+ ------------------------------
+
+ procedure Detach_Interrupt_Entries (T : Task_Id) is
+ begin
+ Unimplemented;
+ end Detach_Interrupt_Entries;
+
+ ----------------------
+ -- Exchange_Handler --
+ ----------------------
+
+ procedure Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Old_Handler := null;
+ Unimplemented;
+ end Exchange_Handler;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Static_Interrupt_Protection) is
+ begin
+ Unimplemented;
+ end Finalize;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Dynamic_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Warnings (Off, Object);
+ begin
+ Unimplemented;
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Static_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Warnings (Off, Object);
+ begin
+ Unimplemented;
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------------
+ -- Ignore_Interrupt --
+ ----------------------
+
+ procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented;
+ end Ignore_Interrupt;
+
+ ----------------------
+ -- Install_Handlers --
+ ----------------------
+
+ procedure Install_Handlers
+ (Object : access Static_Interrupt_Protection;
+ New_Handlers : New_Handler_Array)
+ is
+ begin
+ Unimplemented;
+ end Install_Handlers;
+
+ ---------------------------------
+ -- Install_Restricted_Handlers --
+ ---------------------------------
+
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array)
+ is
+ begin
+ Unimplemented;
+ end Install_Restricted_Handlers;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Blocked;
+
+ -----------------------
+ -- Is_Entry_Attached --
+ -----------------------
+
+ function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Entry_Attached;
+
+ -------------------------
+ -- Is_Handler_Attached --
+ -------------------------
+
+ function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Handler_Attached;
+
+ ----------------
+ -- Is_Ignored --
+ ----------------
+
+ function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Ignored;
+
+ -----------------
+ -- Is_Reserved --
+ -----------------
+
+ function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented;
+ return True;
+ end Is_Reserved;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ begin
+ Unimplemented;
+ return Interrupt'Address;
+ end Reference;
+
+ --------------------------------
+ -- Register_Interrupt_Handler --
+ --------------------------------
+
+ procedure Register_Interrupt_Handler
+ (Handler_Addr : System.Address)
+ is
+ begin
+ Unimplemented;
+ end Register_Interrupt_Handler;
+
+ -----------------------
+ -- Unblock_Interrupt --
+ -----------------------
+
+ procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented;
+ end Unblock_Interrupt;
+
+ ------------------
+ -- Unblocked_By --
+ ------------------
+
+ function Unblocked_By (Interrupt : Interrupt_ID)
+ return System.Tasking.Task_Id is
+ begin
+ Unimplemented;
+ return null;
+ end Unblocked_By;
+
+ ------------------------
+ -- Unignore_Interrupt --
+ ------------------------
+
+ procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented;
+ end Unignore_Interrupt;
+
+ -------------------
+ -- Unimplemented; --
+ -------------------
+
+ procedure Unimplemented is
+ begin
+ raise Program_Error with "interrupts/signals not implemented";
+ end Unimplemented;
+
+end System.Interrupts;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Invariants:
+
+-- All user-handlable signals are masked at all times in all tasks/threads
+-- except possibly for the Interrupt_Manager task.
+
+-- When a user task wants to have the effect of masking/unmasking an signal,
+-- it must call Block_Interrupt/Unblock_Interrupt, which will have the effect
+-- of unmasking/masking the signal in the Interrupt_Manager task. These
+-- comments do not apply to vectored hardware interrupts, which may be masked
+-- or unmasked using routined interfaced to the relevant embedded RTOS system
+-- calls.
+
+-- Once we associate a Signal_Server_Task with an signal, the task never goes
+-- away, and we never remove the association. On the other hand, it is more
+-- convenient to terminate an associated Interrupt_Server_Task for a vectored
+-- hardware interrupt (since we use a binary semaphore for synchronization
+-- with the umbrella handler).
+
+-- There is no more than one signal per Signal_Server_Task and no more than
+-- one Signal_Server_Task per signal. The same relation holds for hardware
+-- interrupts and Interrupt_Server_Task's at any given time. That is, only
+-- one non-terminated Interrupt_Server_Task exists for a give interrupt at
+-- any time.
+
+-- Within this package, the lock L is used to protect the various status
+-- tables. If there is a Server_Task associated with a signal or interrupt,
+-- we use the per-task lock of the Server_Task instead so that we protect the
+-- status between Interrupt_Manager and Server_Task. Protection among service
+-- requests are ensured via user calls to the Interrupt_Manager entries.
+
+-- This is reasonably generic version of this package, supporting vectored
+-- hardware interrupts using non-RTOS specific adapter routines which should
+-- easily implemented on any RTOS capable of supporting GNAT.
+
+with Ada.Unchecked_Conversion;
+with Ada.Task_Identification;
+
+with Interfaces.C; use Interfaces.C;
+with System.OS_Interface; use System.OS_Interface;
+with System.Interrupt_Management;
+with System.Task_Primitives.Operations;
+with System.Storage_Elements;
+with System.Tasking.Utilities;
+
+with System.Tasking.Rendezvous;
+pragma Elaborate_All (System.Tasking.Rendezvous);
+
+package body System.Interrupts is
+
+ use Tasking;
+
+ package POP renames System.Task_Primitives.Operations;
+
+ function To_Ada is new Ada.Unchecked_Conversion
+ (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id);
+
+ function To_System is new Ada.Unchecked_Conversion
+ (Ada.Task_Identification.Task_Id, Task_Id);
+
+ -----------------
+ -- Local Tasks --
+ -----------------
+
+ -- WARNING: System.Tasking.Stages performs calls to this task with low-
+ -- level constructs. Do not change this spec without synchronizing it.
+
+ task Interrupt_Manager is
+ entry Detach_Interrupt_Entries (T : Task_Id);
+
+ entry Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
+
+ entry Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ entry Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ entry Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID);
+
+ pragma Interrupt_Priority (System.Interrupt_Priority'First);
+ end Interrupt_Manager;
+
+ task type Interrupt_Server_Task
+ (Interrupt : Interrupt_ID;
+ Int_Sema : Binary_Semaphore_Id)
+ is
+ -- Server task for vectored hardware interrupt handling
+
+ pragma Interrupt_Priority (System.Interrupt_Priority'First + 2);
+ end Interrupt_Server_Task;
+
+ type Interrupt_Task_Access is access Interrupt_Server_Task;
+
+ -------------------------------
+ -- Local Types and Variables --
+ -------------------------------
+
+ type Entry_Assoc is record
+ T : Task_Id;
+ E : Task_Entry_Index;
+ end record;
+
+ type Handler_Assoc is record
+ H : Parameterless_Handler;
+ Static : Boolean; -- Indicates static binding;
+ end record;
+
+ User_Handler : array (Interrupt_ID) of Handler_Assoc :=
+ (others => (null, Static => False));
+ pragma Volatile_Components (User_Handler);
+ -- Holds the protected procedure handler (if any) and its Static
+ -- information for each interrupt or signal. A handler is static iff it
+ -- is specified through the pragma Attach_Handler.
+
+ User_Entry : array (Interrupt_ID) of Entry_Assoc :=
+ (others => (T => Null_Task, E => Null_Task_Entry));
+ pragma Volatile_Components (User_Entry);
+ -- Holds the task and entry index (if any) for each interrupt / signal
+
+ -- Type and Head, Tail of the list containing Registered Interrupt
+ -- Handlers. These definitions are used to register the handlers
+ -- specified by the pragma Interrupt_Handler.
+
+ type Registered_Handler;
+ type R_Link is access all Registered_Handler;
+
+ type Registered_Handler is record
+ H : System.Address := System.Null_Address;
+ Next : R_Link := null;
+ end record;
+
+ Registered_Handler_Head : R_Link := null;
+ Registered_Handler_Tail : R_Link := null;
+
+ Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id :=
+ (others => System.Tasking.Null_Task);
+ pragma Atomic_Components (Server_ID);
+ -- Holds the Task_Id of the Server_Task for each interrupt / signal.
+ -- Task_Id is needed to accomplish locking per interrupt base. Also
+ -- is needed to determine whether to create a new Server_Task.
+
+ Semaphore_ID_Map : array
+ (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) of
+ Binary_Semaphore_Id := (others => 0);
+ -- Array of binary semaphores associated with vectored interrupts. Note
+ -- that the last bound should be Max_HW_Interrupt, but this will raise
+ -- Storage_Error if Num_HW_Interrupts is null so use extra 4 bytes instead.
+
+ Interrupt_Access_Hold : Interrupt_Task_Access;
+ -- Variable for allocating an Interrupt_Server_Task
+
+ Handler_Installed : array (HW_Interrupt) of Boolean := (others => False);
+ -- True if Notify_Interrupt was connected to the interrupt. Handlers can
+ -- be connected but disconnection is not possible on VxWorks. Therefore
+ -- we ensure Notify_Installed is connected at most once.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID);
+ -- Check if Id is a reserved interrupt, and if so raise Program_Error
+ -- with an appropriate message, otherwise return.
+
+ procedure Finalize_Interrupt_Servers;
+ -- Unbind the handlers for hardware interrupt server tasks at program
+ -- termination.
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean;
+ -- See if Handler has been "pragma"ed using Interrupt_Handler.
+ -- Always consider a null handler as registered.
+
+ procedure Notify_Interrupt (Param : System.Address);
+ pragma Convention (C, Notify_Interrupt);
+ -- Umbrella handler for vectored interrupts (not signals)
+
+ procedure Install_Umbrella_Handler
+ (Interrupt : HW_Interrupt;
+ Handler : System.OS_Interface.Interrupt_Handler);
+ -- Install the runtime umbrella handler for a vectored hardware
+ -- interrupt
+
+ procedure Unimplemented (Feature : String);
+ pragma No_Return (Unimplemented);
+ -- Used to mark a call to an unimplemented function. Raises Program_Error
+ -- with an appropriate message noting that Feature is unimplemented.
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ -- Calling this procedure with New_Handler = null and Static = True
+ -- means we want to detach the current handler regardless of the previous
+ -- handler's binding status (i.e. do not care if it is a dynamic or static
+ -- handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False) is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
+ end Attach_Handler;
+
+ -----------------------------
+ -- Bind_Interrupt_To_Entry --
+ -----------------------------
+
+ -- This procedure raises a Program_Error if it tries to
+ -- bind an interrupt to which an Entry or a Procedure is
+ -- already bound.
+
+ procedure Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Int_Ref : System.Address)
+ is
+ Interrupt : constant Interrupt_ID :=
+ Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
+ end Bind_Interrupt_To_Entry;
+
+ ---------------------
+ -- Block_Interrupt --
+ ---------------------
+
+ procedure Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Block_Interrupt");
+ end Block_Interrupt;
+
+ ------------------------------
+ -- Check_Reserved_Interrupt --
+ ------------------------------
+
+ procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error with
+ "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
+ else
+ return;
+ end if;
+ end Check_Reserved_Interrupt;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+
+ -- ??? Since Parameterless_Handler is not Atomic, the current
+ -- implementation is wrong. We need a new service in Interrupt_Manager
+ -- to ensure atomicity.
+
+ return User_Handler (Interrupt).H;
+ end Current_Handler;
+
+ --------------------
+ -- Detach_Handler --
+ --------------------
+
+ -- Calling this procedure with Static = True means we want to Detach the
+ -- current handler regardless of the previous handler's binding status
+ -- (i.e. do not care if it is a dynamic or static handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Detach_Handler (Interrupt, Static);
+ end Detach_Handler;
+
+ ------------------------------
+ -- Detach_Interrupt_Entries --
+ ------------------------------
+
+ procedure Detach_Interrupt_Entries (T : Task_Id) is
+ begin
+ Interrupt_Manager.Detach_Interrupt_Entries (T);
+ end Detach_Interrupt_Entries;
+
+ ----------------------
+ -- Exchange_Handler --
+ ----------------------
+
+ -- Calling this procedure with New_Handler = null and Static = True
+ -- means we want to detach the current handler regardless of the previous
+ -- handler's binding status (i.e. we do not care if it is a dynamic or
+ -- static handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static);
+ end Exchange_Handler;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Static_Interrupt_Protection) is
+ begin
+ -- ??? loop to be executed only when we're not doing library level
+ -- finalization, since in this case all interrupt / signal tasks are
+ -- gone.
+
+ if not Interrupt_Manager'Terminated then
+ for N in reverse Object.Previous_Handlers'Range loop
+ Interrupt_Manager.Attach_Handler
+ (New_Handler => Object.Previous_Handlers (N).Handler,
+ Interrupt => Object.Previous_Handlers (N).Interrupt,
+ Static => Object.Previous_Handlers (N).Static,
+ Restoration => True);
+ end loop;
+ end if;
+
+ Tasking.Protected_Objects.Entries.Finalize
+ (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
+ end Finalize;
+
+ --------------------------------
+ -- Finalize_Interrupt_Servers --
+ --------------------------------
+
+ -- Restore default handlers for interrupt servers
+
+ -- This is called by the Interrupt_Manager task when it receives the abort
+ -- signal during program finalization.
+
+ procedure Finalize_Interrupt_Servers is
+ HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
+ begin
+ if HW_Interrupts then
+ for Int in HW_Interrupt loop
+ if Server_ID (Interrupt_ID (Int)) /= null
+ and then
+ not Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt_ID (Int))))
+ then
+ Interrupt_Manager.Attach_Handler
+ (New_Handler => null,
+ Interrupt => Interrupt_ID (Int),
+ Static => True,
+ Restoration => True);
+ end if;
+ end loop;
+ end if;
+ end Finalize_Interrupt_Servers;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Dynamic_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Unreferenced (Object);
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Static_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Unreferenced (Object);
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------------
+ -- Ignore_Interrupt --
+ ----------------------
+
+ procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Ignore_Interrupt");
+ end Ignore_Interrupt;
+
+ ----------------------
+ -- Install_Handlers --
+ ----------------------
+
+ procedure Install_Handlers
+ (Object : access Static_Interrupt_Protection;
+ New_Handlers : New_Handler_Array)
+ is
+ begin
+ for N in New_Handlers'Range loop
+
+ -- We need a lock around this ???
+
+ Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
+ Object.Previous_Handlers (N).Static := User_Handler
+ (New_Handlers (N).Interrupt).Static;
+
+ -- We call Exchange_Handler and not directly Interrupt_Manager.
+ -- Exchange_Handler so we get the Is_Reserved check.
+
+ Exchange_Handler
+ (Old_Handler => Object.Previous_Handlers (N).Handler,
+ New_Handler => New_Handlers (N).Handler,
+ Interrupt => New_Handlers (N).Interrupt,
+ Static => True);
+ end loop;
+ end Install_Handlers;
+
+ ---------------------------------
+ -- Install_Restricted_Handlers --
+ ---------------------------------
+
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array)
+ is
+ pragma Unreferenced (Prio);
+ begin
+ for N in Handlers'Range loop
+ Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
+ end loop;
+ end Install_Restricted_Handlers;
+
+ ------------------------------
+ -- Install_Umbrella_Handler --
+ ------------------------------
+
+ procedure Install_Umbrella_Handler
+ (Interrupt : HW_Interrupt;
+ Handler : System.OS_Interface.Interrupt_Handler)
+ is
+ Vec : constant Interrupt_Vector :=
+ Interrupt_Number_To_Vector (int (Interrupt));
+
+ Status : int;
+
+ begin
+ -- Only install umbrella handler when no Ada handler has already been
+ -- installed. Note that the interrupt number is passed as a parameter
+ -- when an interrupt occurs, so the umbrella handler has a different
+ -- wrapper generated by intConnect for each interrupt number.
+
+ if not Handler_Installed (Interrupt) then
+ Status :=
+ Interrupt_Connect (Vec, Handler, System.Address (Interrupt));
+ pragma Assert (Status = 0);
+
+ Handler_Installed (Interrupt) := True;
+ end if;
+ end Install_Umbrella_Handler;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented ("Is_Blocked");
+ return False;
+ end Is_Blocked;
+
+ -----------------------
+ -- Is_Entry_Attached --
+ -----------------------
+
+ function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return User_Entry (Interrupt).T /= Null_Task;
+ end Is_Entry_Attached;
+
+ -------------------------
+ -- Is_Handler_Attached --
+ -------------------------
+
+ function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return User_Handler (Interrupt).H /= null;
+ end Is_Handler_Attached;
+
+ ----------------
+ -- Is_Ignored --
+ ----------------
+
+ function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented ("Is_Ignored");
+ return False;
+ end Is_Ignored;
+
+ -------------------
+ -- Is_Registered --
+ -------------------
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean is
+ type Fat_Ptr is record
+ Object_Addr : System.Address;
+ Handler_Addr : System.Address;
+ end record;
+
+ function To_Fat_Ptr is new Ada.Unchecked_Conversion
+ (Parameterless_Handler, Fat_Ptr);
+
+ Ptr : R_Link;
+ Fat : Fat_Ptr;
+
+ begin
+ if Handler = null then
+ return True;
+ end if;
+
+ Fat := To_Fat_Ptr (Handler);
+
+ Ptr := Registered_Handler_Head;
+ while Ptr /= null loop
+ if Ptr.H = Fat.Handler_Addr then
+ return True;
+ end if;
+
+ Ptr := Ptr.Next;
+ end loop;
+
+ return False;
+ end Is_Registered;
+
+ -----------------
+ -- Is_Reserved --
+ -----------------
+
+ function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ use System.Interrupt_Management;
+ begin
+ return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt));
+ end Is_Reserved;
+
+ ----------------------
+ -- Notify_Interrupt --
+ ----------------------
+
+ -- Umbrella handler for vectored hardware interrupts (as opposed to signals
+ -- and exceptions). As opposed to the signal implementation, this handler
+ -- is installed in the vector table when the first Ada handler is attached
+ -- to the interrupt. However because VxWorks don't support disconnecting
+ -- handlers, this subprogram always test whether or not an Ada handler is
+ -- effectively attached.
+
+ -- Otherwise, the handler that existed prior to program startup is in the
+ -- vector table. This ensures that handlers installed by the BSP are active
+ -- unless explicitly replaced in the program text.
+
+ -- Each Interrupt_Server_Task has an associated binary semaphore on which
+ -- it pends once it's been started. This routine determines The appropriate
+ -- semaphore and issues a semGive call, waking the server task. When
+ -- a handler is unbound, System.Interrupts.Unbind_Handler issues a
+ -- Binary_Semaphore_Flush, and the server task deletes its semaphore
+ -- and terminates.
+
+ procedure Notify_Interrupt (Param : System.Address) is
+ Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
+ Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt);
+ Status : int;
+ begin
+ if Id /= 0 then
+ Status := Binary_Semaphore_Release (Id);
+ pragma Assert (Status = 0);
+ end if;
+ end Notify_Interrupt;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return Storage_Elements.To_Address
+ (Storage_Elements.Integer_Address (Interrupt));
+ end Reference;
+
+ --------------------------------
+ -- Register_Interrupt_Handler --
+ --------------------------------
+
+ procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
+ New_Node_Ptr : R_Link;
+
+ begin
+ -- This routine registers a handler as usable for dynamic interrupt
+ -- handler association. Routines attaching and detaching handlers
+ -- dynamically should determine whether the handler is registered.
+ -- Program_Error should be raised if it is not registered.
+
+ -- Pragma Interrupt_Handler can only appear in a library level PO
+ -- definition and instantiation. Therefore, we do not need to implement
+ -- an unregister operation. Nor do we need to protect the queue
+ -- structure with a lock.
+
+ pragma Assert (Handler_Addr /= System.Null_Address);
+
+ New_Node_Ptr := new Registered_Handler;
+ New_Node_Ptr.H := Handler_Addr;
+
+ if Registered_Handler_Head = null then
+ Registered_Handler_Head := New_Node_Ptr;
+ Registered_Handler_Tail := New_Node_Ptr;
+ else
+ Registered_Handler_Tail.Next := New_Node_Ptr;
+ Registered_Handler_Tail := New_Node_Ptr;
+ end if;
+ end Register_Interrupt_Handler;
+
+ -----------------------
+ -- Unblock_Interrupt --
+ -----------------------
+
+ procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Unblock_Interrupt");
+ end Unblock_Interrupt;
+
+ ------------------
+ -- Unblocked_By --
+ ------------------
+
+ function Unblocked_By
+ (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
+ is
+ begin
+ Unimplemented ("Unblocked_By");
+ return Null_Task;
+ end Unblocked_By;
+
+ ------------------------
+ -- Unignore_Interrupt --
+ ------------------------
+
+ procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Unignore_Interrupt");
+ end Unignore_Interrupt;
+
+ -------------------
+ -- Unimplemented --
+ -------------------
+
+ procedure Unimplemented (Feature : String) is
+ begin
+ raise Program_Error with Feature & " not implemented on VxWorks";
+ end Unimplemented;
+
+ -----------------------
+ -- Interrupt_Manager --
+ -----------------------
+
+ task body Interrupt_Manager is
+ -- By making this task independent of any master, when the process goes
+ -- away, the Interrupt_Manager will terminate gracefully.
+
+ Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
+ pragma Unreferenced (Ignore);
+
+ --------------------
+ -- Local Routines --
+ --------------------
+
+ procedure Bind_Handler (Interrupt : Interrupt_ID);
+ -- This procedure does not do anything if a signal is blocked.
+ -- Otherwise, we have to interrupt Server_Task for status change
+ -- through a wakeup signal.
+
+ procedure Unbind_Handler (Interrupt : Interrupt_ID);
+ -- This procedure does not do anything if a signal is blocked.
+ -- Otherwise, we have to interrupt Server_Task for status change
+ -- through an abort signal.
+
+ procedure Unprotected_Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
+
+ procedure Unprotected_Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ ------------------
+ -- Bind_Handler --
+ ------------------
+
+ procedure Bind_Handler (Interrupt : Interrupt_ID) is
+ begin
+ Install_Umbrella_Handler
+ (HW_Interrupt (Interrupt), Notify_Interrupt'Access);
+ end Bind_Handler;
+
+ --------------------
+ -- Unbind_Handler --
+ --------------------
+
+ procedure Unbind_Handler (Interrupt : Interrupt_ID) is
+ Status : int;
+
+ begin
+ -- Flush server task off semaphore, allowing it to terminate
+
+ Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt));
+ pragma Assert (Status = 0);
+ end Unbind_Handler;
+
+ --------------------------------
+ -- Unprotected_Detach_Handler --
+ --------------------------------
+
+ procedure Unprotected_Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
+ is
+ Old_Handler : Parameterless_Handler;
+ begin
+ if User_Entry (Interrupt).T /= Null_Task then
+
+ -- If an interrupt entry is installed raise Program_Error
+ -- (propagate it to the caller).
+
+ raise Program_Error with
+ "an interrupt entry is already installed";
+ end if;
+
+ -- Note : Static = True will pass the following check. This is the
+ -- case when we want to detach a handler regardless of the static
+ -- status of the Current_Handler.
+
+ if not Static and then User_Handler (Interrupt).Static then
+
+ -- Trying to detach a static Interrupt Handler, raise
+ -- Program_Error.
+
+ raise Program_Error with
+ "trying to detach a static Interrupt Handler";
+ end if;
+
+ Old_Handler := User_Handler (Interrupt).H;
+
+ -- The new handler
+
+ User_Handler (Interrupt).H := null;
+ User_Handler (Interrupt).Static := False;
+
+ if Old_Handler /= null then
+ Unbind_Handler (Interrupt);
+ end if;
+ end Unprotected_Detach_Handler;
+
+ ----------------------------------
+ -- Unprotected_Exchange_Handler --
+ ----------------------------------
+
+ procedure Unprotected_Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False)
+ is
+ begin
+ if User_Entry (Interrupt).T /= Null_Task then
+
+ -- If an interrupt entry is already installed, raise
+ -- Program_Error (propagate it to the caller).
+
+ raise Program_Error with "an interrupt is already installed";
+ end if;
+
+ -- Note : A null handler with Static = True will pass the following
+ -- check. This is the case when we want to detach a handler
+ -- regardless of the Static status of Current_Handler.
+
+ -- We don't check anything if Restoration is True, since we may be
+ -- detaching a static handler to restore a dynamic one.
+
+ if not Restoration and then not Static
+ and then (User_Handler (Interrupt).Static
+
+ -- Trying to overwrite a static Interrupt Handler with a dynamic
+ -- Handler
+
+ -- The new handler is not specified as an Interrupt Handler by a
+ -- pragma.
+
+ or else not Is_Registered (New_Handler))
+ then
+ raise Program_Error with
+ "trying to overwrite a static interrupt handler with a "
+ & "dynamic handler";
+ end if;
+
+ -- Save the old handler
+
+ Old_Handler := User_Handler (Interrupt).H;
+
+ -- The new handler
+
+ User_Handler (Interrupt).H := New_Handler;
+
+ if New_Handler = null then
+
+ -- The null handler means we are detaching the handler
+
+ User_Handler (Interrupt).Static := False;
+
+ else
+ User_Handler (Interrupt).Static := Static;
+ end if;
+
+ -- Invoke a corresponding Server_Task if not yet created. Place
+ -- Task_Id info in Server_ID array.
+
+ if New_Handler /= null
+ and then
+ (Server_ID (Interrupt) = Null_Task
+ or else
+ Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt))))
+ then
+ Interrupt_Access_Hold :=
+ new Interrupt_Server_Task (Interrupt, Binary_Semaphore_Create);
+ Server_ID (Interrupt) :=
+ To_System (Interrupt_Access_Hold.all'Identity);
+ end if;
+
+ if (New_Handler = null) and then Old_Handler /= null then
+
+ -- Restore default handler
+
+ Unbind_Handler (Interrupt);
+
+ elsif Old_Handler = null then
+
+ -- Save default handler
+
+ Bind_Handler (Interrupt);
+ end if;
+ end Unprotected_Exchange_Handler;
+
+ -- Start of processing for Interrupt_Manager
+
+ begin
+ loop
+ -- A block is needed to absorb Program_Error exception
+
+ declare
+ Old_Handler : Parameterless_Handler;
+
+ begin
+ select
+ accept Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False)
+ do
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static, Restoration);
+ end Attach_Handler;
+
+ or
+ accept Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean)
+ do
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static);
+ end Exchange_Handler;
+
+ or
+ accept Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
+ do
+ Unprotected_Detach_Handler (Interrupt, Static);
+ end Detach_Handler;
+
+ or
+ accept Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID)
+ do
+ -- If there is a binding already (either a procedure or an
+ -- entry), raise Program_Error (propagate it to the caller).
+
+ if User_Handler (Interrupt).H /= null
+ or else User_Entry (Interrupt).T /= Null_Task
+ then
+ raise Program_Error with
+ "a binding for this interrupt is already present";
+ end if;
+
+ User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
+
+ -- Indicate the attachment of interrupt entry in the ATCB.
+ -- This is needed so when an interrupt entry task terminates
+ -- the binding can be cleaned. The call to unbinding must be
+ -- make by the task before it terminates.
+
+ T.Interrupt_Entry := True;
+
+ -- Invoke a corresponding Server_Task if not yet created.
+ -- Place Task_Id info in Server_ID array.
+
+ if Server_ID (Interrupt) = Null_Task
+ or else
+ Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt)))
+ then
+ Interrupt_Access_Hold := new Interrupt_Server_Task
+ (Interrupt, Binary_Semaphore_Create);
+ Server_ID (Interrupt) :=
+ To_System (Interrupt_Access_Hold.all'Identity);
+ end if;
+
+ Bind_Handler (Interrupt);
+ end Bind_Interrupt_To_Entry;
+
+ or
+ accept Detach_Interrupt_Entries (T : Task_Id) do
+ for Int in Interrupt_ID'Range loop
+ if not Is_Reserved (Int) then
+ if User_Entry (Int).T = T then
+ User_Entry (Int) :=
+ Entry_Assoc'
+ (T => Null_Task, E => Null_Task_Entry);
+ Unbind_Handler (Int);
+ end if;
+ end if;
+ end loop;
+
+ -- Indicate in ATCB that no interrupt entries are attached
+
+ T.Interrupt_Entry := False;
+ end Detach_Interrupt_Entries;
+ end select;
+
+ exception
+ -- If there is a Program_Error we just want to propagate it to
+ -- the caller and do not want to stop this task.
+
+ when Program_Error =>
+ null;
+
+ when others =>
+ pragma Assert (False);
+ null;
+ end;
+ end loop;
+
+ exception
+ when Standard'Abort_Signal =>
+
+ -- Flush interrupt server semaphores, so they can terminate
+
+ Finalize_Interrupt_Servers;
+ raise;
+ end Interrupt_Manager;
+
+ ---------------------------
+ -- Interrupt_Server_Task --
+ ---------------------------
+
+ -- Server task for vectored hardware interrupt handling
+
+ task body Interrupt_Server_Task is
+ Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
+
+ Self_Id : constant Task_Id := Self;
+ Tmp_Handler : Parameterless_Handler;
+ Tmp_ID : Task_Id;
+ Tmp_Entry_Index : Task_Entry_Index;
+ Status : int;
+
+ begin
+ Semaphore_ID_Map (Interrupt) := Int_Sema;
+
+ loop
+ -- Pend on semaphore that will be triggered by the umbrella handler
+ -- when the associated interrupt comes in.
+
+ Status := Binary_Semaphore_Obtain (Int_Sema);
+ pragma Assert (Status = 0);
+
+ if User_Handler (Interrupt).H /= null then
+
+ -- Protected procedure handler
+
+ Tmp_Handler := User_Handler (Interrupt).H;
+ Tmp_Handler.all;
+
+ elsif User_Entry (Interrupt).T /= Null_Task then
+
+ -- Interrupt entry handler
+
+ Tmp_ID := User_Entry (Interrupt).T;
+ Tmp_Entry_Index := User_Entry (Interrupt).E;
+ System.Tasking.Rendezvous.Call_Simple
+ (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
+
+ else
+ -- Semaphore has been flushed by an unbind operation in the
+ -- Interrupt_Manager. Terminate the server task.
+
+ -- Wait for the Interrupt_Manager to complete its work
+
+ POP.Write_Lock (Self_Id);
+
+ -- Unassociate the interrupt handler
+
+ Semaphore_ID_Map (Interrupt) := 0;
+
+ -- Delete the associated semaphore
+
+ Status := Binary_Semaphore_Delete (Int_Sema);
+
+ pragma Assert (Status = 0);
+
+ -- Set status for the Interrupt_Manager
+
+ Server_ID (Interrupt) := Null_Task;
+ POP.Unlock (Self_Id);
+
+ exit;
+ end if;
+ end loop;
+ end Interrupt_Server_Task;
+
+begin
+ -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
+
+ Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
+end System.Interrupts;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the NT version of this package
+
+with Ada.Task_Identification;
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+with System.Storage_Elements;
+with System.Task_Primitives.Operations;
+with System.Tasking.Utilities;
+with System.Tasking.Rendezvous;
+with System.Tasking.Initialization;
+with System.Interrupt_Management;
+with System.Parameters;
+
+package body System.Interrupts is
+
+ use Parameters;
+ use Tasking;
+ use System.OS_Interface;
+ use Interfaces.C;
+
+ package STPO renames System.Task_Primitives.Operations;
+ package IMNG renames System.Interrupt_Management;
+
+ subtype int is Interfaces.C.int;
+
+ function To_System is new Ada.Unchecked_Conversion
+ (Ada.Task_Identification.Task_Id, Task_Id);
+
+ type Handler_Kind is (Unknown, Task_Entry, Protected_Procedure);
+
+ type Handler_Desc is record
+ Kind : Handler_Kind := Unknown;
+ T : Task_Id;
+ E : Task_Entry_Index;
+ H : Parameterless_Handler;
+ Static : Boolean := False;
+ end record;
+
+ task type Server_Task (Interrupt : Interrupt_ID) is
+ pragma Interrupt_Priority (System.Interrupt_Priority'Last);
+ end Server_Task;
+
+ type Server_Task_Access is access Server_Task;
+
+ Handlers : array (Interrupt_ID) of Task_Id;
+ Descriptors : array (Interrupt_ID) of Handler_Desc;
+ Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0);
+
+ pragma Volatile_Components (Interrupt_Count);
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean);
+ -- This internal procedure is needed to finalize protected objects that
+ -- contain interrupt handlers.
+
+ procedure Signal_Handler (Sig : Interrupt_ID);
+ pragma Convention (C, Signal_Handler);
+ -- This procedure is used to handle all the signals
+
+ -- Type and Head, Tail of the list containing Registered Interrupt
+ -- Handlers. These definitions are used to register the handlers
+ -- specified by the pragma Interrupt_Handler.
+
+ --------------------------
+ -- Handler Registration --
+ --------------------------
+
+ type Registered_Handler;
+ type R_Link is access all Registered_Handler;
+
+ type Registered_Handler is record
+ H : System.Address := System.Null_Address;
+ Next : R_Link := null;
+ end record;
+
+ Registered_Handlers : R_Link := null;
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean;
+ -- See if the Handler has been "pragma"ed using Interrupt_Handler.
+ -- Always consider a null handler as registered.
+
+ type Handler_Ptr is access procedure (Sig : Interrupt_ID);
+ pragma Convention (C, Handler_Ptr);
+
+ function TISR is new Ada.Unchecked_Conversion (Handler_Ptr, isr_address);
+
+ --------------------
+ -- Signal_Handler --
+ --------------------
+
+ procedure Signal_Handler (Sig : Interrupt_ID) is
+ Handler : Task_Id renames Handlers (Sig);
+
+ begin
+ if Intr_Attach_Reset and then
+ intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR
+ then
+ raise Program_Error;
+ end if;
+
+ if Handler /= null then
+ Interrupt_Count (Sig) := Interrupt_Count (Sig) + 1;
+ STPO.Wakeup (Handler, Interrupt_Server_Idle_Sleep);
+ end if;
+ end Signal_Handler;
+
+ -----------------
+ -- Is_Reserved --
+ -----------------
+
+ function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
+ end Is_Reserved;
+
+ -----------------------
+ -- Is_Entry_Attached --
+ -----------------------
+
+ function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error with
+ "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
+ end if;
+
+ return Descriptors (Interrupt).T /= Null_Task;
+ end Is_Entry_Attached;
+
+ -------------------------
+ -- Is_Handler_Attached --
+ -------------------------
+
+ function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error with
+ "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
+ else
+ return Descriptors (Interrupt).Kind /= Unknown;
+ end if;
+ end Is_Handler_Attached;
+
+ ----------------
+ -- Is_Ignored --
+ ----------------
+
+ function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ raise Program_Error;
+ return False;
+ end Is_Ignored;
+
+ ------------------
+ -- Unblocked_By --
+ ------------------
+
+ function Unblocked_By (Interrupt : Interrupt_ID) return Task_Id is
+ begin
+ raise Program_Error;
+ return Null_Task;
+ end Unblocked_By;
+
+ ----------------------
+ -- Ignore_Interrupt --
+ ----------------------
+
+ procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Ignore_Interrupt;
+
+ ------------------------
+ -- Unignore_Interrupt --
+ ------------------------
+
+ procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Unignore_Interrupt;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Dynamic_Interrupt_Protection) return Boolean
+ is
+ pragma Unreferenced (Object);
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Static_Interrupt_Protection) is
+ begin
+ -- ??? loop to be executed only when we're not doing library level
+ -- finalization, since in this case all interrupt tasks are gone.
+
+ for N in reverse Object.Previous_Handlers'Range loop
+ Attach_Handler
+ (New_Handler => Object.Previous_Handlers (N).Handler,
+ Interrupt => Object.Previous_Handlers (N).Interrupt,
+ Static => Object.Previous_Handlers (N).Static,
+ Restoration => True);
+ end loop;
+
+ Tasking.Protected_Objects.Entries.Finalize
+ (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
+ end Finalize;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Static_Interrupt_Protection) return Boolean
+ is
+ pragma Unreferenced (Object);
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------------
+ -- Install_Handlers --
+ ----------------------
+
+ procedure Install_Handlers
+ (Object : access Static_Interrupt_Protection;
+ New_Handlers : New_Handler_Array)
+ is
+ begin
+ for N in New_Handlers'Range loop
+
+ -- We need a lock around this ???
+
+ Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
+ Object.Previous_Handlers (N).Static := Descriptors
+ (New_Handlers (N).Interrupt).Static;
+
+ -- We call Exchange_Handler and not directly Interrupt_Manager.
+ -- Exchange_Handler so we get the Is_Reserved check.
+
+ Exchange_Handler
+ (Old_Handler => Object.Previous_Handlers (N).Handler,
+ New_Handler => New_Handlers (N).Handler,
+ Interrupt => New_Handlers (N).Interrupt,
+ Static => True);
+ end loop;
+ end Install_Handlers;
+
+ ---------------------------------
+ -- Install_Restricted_Handlers --
+ ---------------------------------
+
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array)
+ is
+ pragma Unreferenced (Prio);
+ begin
+ for N in Handlers'Range loop
+ Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
+ end loop;
+ end Install_Restricted_Handlers;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind = Protected_Procedure then
+ return Descriptors (Interrupt).H;
+ else
+ return null;
+ end if;
+ end Current_Handler;
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Attach_Handler (New_Handler, Interrupt, Static, False);
+ end Attach_Handler;
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean)
+ is
+ New_Task : Server_Task_Access;
+
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if not Restoration and then not Static
+
+ -- Tries to overwrite a static Interrupt Handler with dynamic handle
+
+ and then
+ (Descriptors (Interrupt).Static
+
+ -- New handler not specified as an Interrupt Handler by a pragma
+
+ or else not Is_Registered (New_Handler))
+ then
+ raise Program_Error with
+ "trying to overwrite a static interrupt handler with a " &
+ "dynamic handler";
+ end if;
+
+ if Handlers (Interrupt) = null then
+ New_Task := new Server_Task (Interrupt);
+ Handlers (Interrupt) := To_System (New_Task.all'Identity);
+ end if;
+
+ if intr_attach (int (Interrupt),
+ TISR (Signal_Handler'Access)) = FUNC_ERR
+ then
+ raise Program_Error;
+ end if;
+
+ if New_Handler = null then
+
+ -- The null handler means we are detaching the handler
+
+ Descriptors (Interrupt) :=
+ (Kind => Unknown, T => null, E => 0, H => null, Static => False);
+
+ else
+ Descriptors (Interrupt).Kind := Protected_Procedure;
+ Descriptors (Interrupt).H := New_Handler;
+ Descriptors (Interrupt).Static := Static;
+ end if;
+ end Attach_Handler;
+
+ ----------------------
+ -- Exchange_Handler --
+ ----------------------
+
+ procedure Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind = Task_Entry then
+
+ -- In case we have an Interrupt Entry already installed, raise a
+ -- program error (propagate it to the caller).
+
+ raise Program_Error with "an interrupt is already installed";
+
+ else
+ Old_Handler := Current_Handler (Interrupt);
+ Attach_Handler (New_Handler, Interrupt, Static);
+ end if;
+ end Exchange_Handler;
+
+ --------------------
+ -- Detach_Handler --
+ --------------------
+
+ procedure Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind = Task_Entry then
+ raise Program_Error with "trying to detach an interrupt entry";
+ end if;
+
+ if not Static and then Descriptors (Interrupt).Static then
+ raise Program_Error with
+ "trying to detach a static interrupt handler";
+ end if;
+
+ Descriptors (Interrupt) :=
+ (Kind => Unknown, T => null, E => 0, H => null, Static => False);
+
+ if intr_attach (int (Interrupt), null) = FUNC_ERR then
+ raise Program_Error;
+ end if;
+ end Detach_Handler;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ Signal : constant System.Address :=
+ System.Storage_Elements.To_Address
+ (System.Storage_Elements.Integer_Address (Interrupt));
+
+ begin
+ if Is_Reserved (Interrupt) then
+
+ -- Only usable Interrupts can be used for binding it to an Entry
+
+ raise Program_Error;
+ end if;
+
+ return Signal;
+ end Reference;
+
+ --------------------------------
+ -- Register_Interrupt_Handler --
+ --------------------------------
+
+ procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
+ begin
+ Registered_Handlers :=
+ new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers);
+ end Register_Interrupt_Handler;
+
+ -------------------
+ -- Is_Registered --
+ -------------------
+
+ -- See if the Handler has been "pragma"ed using Interrupt_Handler.
+ -- Always consider a null handler as registered.
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean is
+ Ptr : R_Link := Registered_Handlers;
+
+ type Fat_Ptr is record
+ Object_Addr : System.Address;
+ Handler_Addr : System.Address;
+ end record;
+
+ function To_Fat_Ptr is new Ada.Unchecked_Conversion
+ (Parameterless_Handler, Fat_Ptr);
+
+ Fat : Fat_Ptr;
+
+ begin
+ if Handler = null then
+ return True;
+ end if;
+
+ Fat := To_Fat_Ptr (Handler);
+
+ while Ptr /= null loop
+ if Ptr.H = Fat.Handler_Addr then
+ return True;
+ end if;
+
+ Ptr := Ptr.Next;
+ end loop;
+
+ return False;
+ end Is_Registered;
+
+ -----------------------------
+ -- Bind_Interrupt_To_Entry --
+ -----------------------------
+
+ procedure Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Int_Ref : System.Address)
+ is
+ Interrupt : constant Interrupt_ID :=
+ Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
+
+ New_Task : Server_Task_Access;
+
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error;
+ end if;
+
+ if Descriptors (Interrupt).Kind /= Unknown then
+ raise Program_Error with
+ "a binding for this interrupt is already present";
+ end if;
+
+ if Handlers (Interrupt) = null then
+ New_Task := new Server_Task (Interrupt);
+ Handlers (Interrupt) := To_System (New_Task.all'Identity);
+ end if;
+
+ if intr_attach (int (Interrupt),
+ TISR (Signal_Handler'Access)) = FUNC_ERR
+ then
+ raise Program_Error;
+ end if;
+
+ Descriptors (Interrupt).Kind := Task_Entry;
+ Descriptors (Interrupt).T := T;
+ Descriptors (Interrupt).E := E;
+
+ -- Indicate the attachment of Interrupt Entry in ATCB. This is needed so
+ -- that when an Interrupt Entry task terminates the binding can be
+ -- cleaned up. The call to unbinding must be make by the task before it
+ -- terminates.
+
+ T.Interrupt_Entry := True;
+ end Bind_Interrupt_To_Entry;
+
+ ------------------------------
+ -- Detach_Interrupt_Entries --
+ ------------------------------
+
+ procedure Detach_Interrupt_Entries (T : Task_Id) is
+ begin
+ for J in Interrupt_ID loop
+ if not Is_Reserved (J) then
+ if Descriptors (J).Kind = Task_Entry
+ and then Descriptors (J).T = T
+ then
+ Descriptors (J).Kind := Unknown;
+
+ if intr_attach (int (J), null) = FUNC_ERR then
+ raise Program_Error;
+ end if;
+ end if;
+ end if;
+ end loop;
+
+ -- Indicate in ATCB that no Interrupt Entries are attached
+
+ T.Interrupt_Entry := True;
+ end Detach_Interrupt_Entries;
+
+ ---------------------
+ -- Block_Interrupt --
+ ---------------------
+
+ procedure Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Block_Interrupt;
+
+ -----------------------
+ -- Unblock_Interrupt --
+ -----------------------
+
+ procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ raise Program_Error;
+ end Unblock_Interrupt;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ raise Program_Error;
+ return False;
+ end Is_Blocked;
+
+ task body Server_Task is
+ Ignore : constant Boolean := Utilities.Make_Independent;
+
+ Desc : Handler_Desc renames Descriptors (Interrupt);
+ Self_Id : constant Task_Id := STPO.Self;
+ Temp : Parameterless_Handler;
+
+ begin
+ loop
+ while Interrupt_Count (Interrupt) > 0 loop
+ Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1;
+ begin
+ case Desc.Kind is
+ when Unknown =>
+ null;
+ when Task_Entry =>
+ Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address);
+ when Protected_Procedure =>
+ Temp := Desc.H;
+ Temp.all;
+ end case;
+ exception
+ when others => null;
+ end;
+ end loop;
+
+ Initialization.Defer_Abort (Self_Id);
+
+ if Single_Lock then
+ STPO.Lock_RTS;
+ end if;
+
+ STPO.Write_Lock (Self_Id);
+ Self_Id.Common.State := Interrupt_Server_Idle_Sleep;
+ STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep);
+ Self_Id.Common.State := Runnable;
+ STPO.Unlock (Self_Id);
+
+ if Single_Lock then
+ STPO.Unlock_RTS;
+ end if;
+
+ Initialization.Undefer_Abort (Self_Id);
+
+ -- Undefer abort here to allow a window for this task to be aborted
+ -- at the time of system shutdown.
+
+ end loop;
+ end Server_Task;
+
+end System.Interrupts;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Invariants:
+
+-- All user-handlable signals are masked at all times in all tasks/threads
+-- except possibly for the Interrupt_Manager task.
+
+-- When a user task wants to have the effect of masking/unmasking an signal,
+-- it must call Block_Interrupt/Unblock_Interrupt, which will have the effect
+-- of unmasking/masking the signal in the Interrupt_Manager task. These
+-- comments do not apply to vectored hardware interrupts, which may be masked
+-- or unmasked using routined interfaced to the relevant embedded RTOS system
+-- calls.
+
+-- Once we associate a Signal_Server_Task with an signal, the task never goes
+-- away, and we never remove the association. On the other hand, it is more
+-- convenient to terminate an associated Interrupt_Server_Task for a vectored
+-- hardware interrupt (since we use a binary semaphore for synchronization
+-- with the umbrella handler).
+
+-- There is no more than one signal per Signal_Server_Task and no more than
+-- one Signal_Server_Task per signal. The same relation holds for hardware
+-- interrupts and Interrupt_Server_Task's at any given time. That is, only
+-- one non-terminated Interrupt_Server_Task exists for a give interrupt at
+-- any time.
+
+-- Within this package, the lock L is used to protect the various status
+-- tables. If there is a Server_Task associated with a signal or interrupt,
+-- we use the per-task lock of the Server_Task instead so that we protect the
+-- status between Interrupt_Manager and Server_Task. Protection among service
+-- requests are ensured via user calls to the Interrupt_Manager entries.
+
+-- This is reasonably generic version of this package, supporting vectored
+-- hardware interrupts using non-RTOS specific adapter routines which should
+-- easily implemented on any RTOS capable of supporting GNAT.
+
+with Ada.Unchecked_Conversion;
+with Ada.Task_Identification;
+
+with Interfaces.C; use Interfaces.C;
+with System.OS_Interface; use System.OS_Interface;
+with System.Interrupt_Management;
+with System.Task_Primitives.Operations;
+with System.Storage_Elements;
+with System.Tasking.Utilities;
+
+with System.Tasking.Rendezvous;
+pragma Elaborate_All (System.Tasking.Rendezvous);
+
+package body System.Interrupts is
+
+ use Tasking;
+
+ package POP renames System.Task_Primitives.Operations;
+
+ function To_Ada is new Ada.Unchecked_Conversion
+ (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id);
+
+ function To_System is new Ada.Unchecked_Conversion
+ (Ada.Task_Identification.Task_Id, Task_Id);
+
+ -----------------
+ -- Local Tasks --
+ -----------------
+
+ -- WARNING: System.Tasking.Stages performs calls to this task with low-
+ -- level constructs. Do not change this spec without synchronizing it.
+
+ task Interrupt_Manager is
+ entry Detach_Interrupt_Entries (T : Task_Id);
+
+ entry Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
+
+ entry Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ entry Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ entry Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID);
+
+ pragma Interrupt_Priority (System.Interrupt_Priority'First);
+ end Interrupt_Manager;
+
+ task type Interrupt_Server_Task
+ (Interrupt : Interrupt_ID;
+ Int_Sema : Binary_Semaphore_Id)
+ is
+ -- Server task for vectored hardware interrupt handling
+
+ pragma Interrupt_Priority (System.Interrupt_Priority'First + 2);
+ end Interrupt_Server_Task;
+
+ type Interrupt_Task_Access is access Interrupt_Server_Task;
+
+ -------------------------------
+ -- Local Types and Variables --
+ -------------------------------
+
+ type Entry_Assoc is record
+ T : Task_Id;
+ E : Task_Entry_Index;
+ end record;
+
+ type Handler_Assoc is record
+ H : Parameterless_Handler;
+ Static : Boolean; -- Indicates static binding;
+ end record;
+
+ User_Handler : array (Interrupt_ID) of Handler_Assoc :=
+ (others => (null, Static => False));
+ pragma Volatile_Components (User_Handler);
+ -- Holds the protected procedure handler (if any) and its Static
+ -- information for each interrupt or signal. A handler is static iff it
+ -- is specified through the pragma Attach_Handler.
+
+ User_Entry : array (Interrupt_ID) of Entry_Assoc :=
+ (others => (T => Null_Task, E => Null_Task_Entry));
+ pragma Volatile_Components (User_Entry);
+ -- Holds the task and entry index (if any) for each interrupt / signal
+
+ -- Type and Head, Tail of the list containing Registered Interrupt
+ -- Handlers. These definitions are used to register the handlers
+ -- specified by the pragma Interrupt_Handler.
+
+ type Registered_Handler;
+ type R_Link is access all Registered_Handler;
+
+ type Registered_Handler is record
+ H : System.Address := System.Null_Address;
+ Next : R_Link := null;
+ end record;
+
+ Registered_Handler_Head : R_Link := null;
+ Registered_Handler_Tail : R_Link := null;
+
+ Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id :=
+ (others => System.Tasking.Null_Task);
+ pragma Atomic_Components (Server_ID);
+ -- Holds the Task_Id of the Server_Task for each interrupt / signal.
+ -- Task_Id is needed to accomplish locking per interrupt base. Also
+ -- is needed to determine whether to create a new Server_Task.
+
+ Semaphore_ID_Map : array
+ (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) of
+ Binary_Semaphore_Id := (others => 0);
+ -- Array of binary semaphores associated with vectored interrupts. Note
+ -- that the last bound should be Max_HW_Interrupt, but this will raise
+ -- Storage_Error if Num_HW_Interrupts is null so use extra 4 bytes instead.
+
+ Interrupt_Access_Hold : Interrupt_Task_Access;
+ -- Variable for allocating an Interrupt_Server_Task
+
+ Handler_Installed : array (HW_Interrupt) of Boolean := (others => False);
+ -- True if Notify_Interrupt was connected to the interrupt. Handlers can
+ -- be connected but disconnection is not possible on VxWorks. Therefore
+ -- we ensure Notify_Installed is connected at most once.
+
+ type Interrupt_Connector is access function
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int;
+ -- Profile must match VxWorks intConnect()
+
+ Interrupt_Connect : Interrupt_Connector :=
+ System.OS_Interface.Interrupt_Connect'Access;
+ pragma Export (C, Interrupt_Connect, "__gnat_user_int_connect");
+ -- Allow user alternatives to the OS implementation of
+ -- System.OS_Interface.Interrupt_Connect. This allows the user to
+ -- associate a handler with an interrupt source when an alternate routine
+ -- is needed to do so. The association is performed in
+ -- Interfaces.VxWorks.Interrupt_Connections. Defaults to the standard OS
+ -- connection routine.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID);
+ -- Check if Id is a reserved interrupt, and if so raise Program_Error
+ -- with an appropriate message, otherwise return.
+
+ procedure Finalize_Interrupt_Servers;
+ -- Unbind the handlers for hardware interrupt server tasks at program
+ -- termination.
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean;
+ -- See if Handler has been "pragma"ed using Interrupt_Handler.
+ -- Always consider a null handler as registered.
+
+ procedure Notify_Interrupt (Param : System.Address);
+ pragma Convention (C, Notify_Interrupt);
+ -- Umbrella handler for vectored interrupts (not signals)
+
+ procedure Install_Umbrella_Handler
+ (Interrupt : HW_Interrupt;
+ Handler : System.OS_Interface.Interrupt_Handler);
+ -- Install the runtime umbrella handler for a vectored hardware
+ -- interrupt
+
+ procedure Unimplemented (Feature : String);
+ pragma No_Return (Unimplemented);
+ -- Used to mark a call to an unimplemented function. Raises Program_Error
+ -- with an appropriate message noting that Feature is unimplemented.
+
+ --------------------
+ -- Attach_Handler --
+ --------------------
+
+ -- Calling this procedure with New_Handler = null and Static = True
+ -- means we want to detach the current handler regardless of the previous
+ -- handler's binding status (i.e. do not care if it is a dynamic or static
+ -- handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False) is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
+ end Attach_Handler;
+
+ -----------------------------
+ -- Bind_Interrupt_To_Entry --
+ -----------------------------
+
+ -- This procedure raises a Program_Error if it tries to
+ -- bind an interrupt to which an Entry or a Procedure is
+ -- already bound.
+
+ procedure Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Int_Ref : System.Address)
+ is
+ Interrupt : constant Interrupt_ID :=
+ Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
+ end Bind_Interrupt_To_Entry;
+
+ ---------------------
+ -- Block_Interrupt --
+ ---------------------
+
+ procedure Block_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Block_Interrupt");
+ end Block_Interrupt;
+
+ ------------------------------
+ -- Check_Reserved_Interrupt --
+ ------------------------------
+
+ procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ if Is_Reserved (Interrupt) then
+ raise Program_Error with
+ "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
+ else
+ return;
+ end if;
+ end Check_Reserved_Interrupt;
+
+ ---------------------
+ -- Current_Handler --
+ ---------------------
+
+ function Current_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+
+ -- ??? Since Parameterless_Handler is not Atomic, the current
+ -- implementation is wrong. We need a new service in Interrupt_Manager
+ -- to ensure atomicity.
+
+ return User_Handler (Interrupt).H;
+ end Current_Handler;
+
+ --------------------
+ -- Detach_Handler --
+ --------------------
+
+ -- Calling this procedure with Static = True means we want to Detach the
+ -- current handler regardless of the previous handler's binding status
+ -- (i.e. do not care if it is a dynamic or static handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Detach_Handler (Interrupt, Static);
+ end Detach_Handler;
+
+ ------------------------------
+ -- Detach_Interrupt_Entries --
+ ------------------------------
+
+ procedure Detach_Interrupt_Entries (T : Task_Id) is
+ begin
+ Interrupt_Manager.Detach_Interrupt_Entries (T);
+ end Detach_Interrupt_Entries;
+
+ ----------------------
+ -- Exchange_Handler --
+ ----------------------
+
+ -- Calling this procedure with New_Handler = null and Static = True
+ -- means we want to detach the current handler regardless of the previous
+ -- handler's binding status (i.e. we do not care if it is a dynamic or
+ -- static handler).
+
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
+
+ procedure Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ Interrupt_Manager.Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static);
+ end Exchange_Handler;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Static_Interrupt_Protection) is
+ begin
+ -- ??? loop to be executed only when we're not doing library level
+ -- finalization, since in this case all interrupt / signal tasks are
+ -- gone.
+
+ if not Interrupt_Manager'Terminated then
+ for N in reverse Object.Previous_Handlers'Range loop
+ Interrupt_Manager.Attach_Handler
+ (New_Handler => Object.Previous_Handlers (N).Handler,
+ Interrupt => Object.Previous_Handlers (N).Interrupt,
+ Static => Object.Previous_Handlers (N).Static,
+ Restoration => True);
+ end loop;
+ end if;
+
+ Tasking.Protected_Objects.Entries.Finalize
+ (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
+ end Finalize;
+
+ --------------------------------
+ -- Finalize_Interrupt_Servers --
+ --------------------------------
+
+ -- Restore default handlers for interrupt servers
+
+ -- This is called by the Interrupt_Manager task when it receives the abort
+ -- signal during program finalization.
+
+ procedure Finalize_Interrupt_Servers is
+ HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
+ begin
+ if HW_Interrupts then
+ for Int in HW_Interrupt loop
+ if Server_ID (Interrupt_ID (Int)) /= null
+ and then
+ not Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt_ID (Int))))
+ then
+ Interrupt_Manager.Attach_Handler
+ (New_Handler => null,
+ Interrupt => Interrupt_ID (Int),
+ Static => True,
+ Restoration => True);
+ end if;
+ end loop;
+ end if;
+ end Finalize_Interrupt_Servers;
+
+ -------------------------------------
+ -- Has_Interrupt_Or_Attach_Handler --
+ -------------------------------------
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Dynamic_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Unreferenced (Object);
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ function Has_Interrupt_Or_Attach_Handler
+ (Object : access Static_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Unreferenced (Object);
+ begin
+ return True;
+ end Has_Interrupt_Or_Attach_Handler;
+
+ ----------------------
+ -- Ignore_Interrupt --
+ ----------------------
+
+ procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Ignore_Interrupt");
+ end Ignore_Interrupt;
+
+ ----------------------
+ -- Install_Handlers --
+ ----------------------
+
+ procedure Install_Handlers
+ (Object : access Static_Interrupt_Protection;
+ New_Handlers : New_Handler_Array)
+ is
+ begin
+ for N in New_Handlers'Range loop
+
+ -- We need a lock around this ???
+
+ Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
+ Object.Previous_Handlers (N).Static := User_Handler
+ (New_Handlers (N).Interrupt).Static;
+
+ -- We call Exchange_Handler and not directly Interrupt_Manager.
+ -- Exchange_Handler so we get the Is_Reserved check.
+
+ Exchange_Handler
+ (Old_Handler => Object.Previous_Handlers (N).Handler,
+ New_Handler => New_Handlers (N).Handler,
+ Interrupt => New_Handlers (N).Interrupt,
+ Static => True);
+ end loop;
+ end Install_Handlers;
+
+ ---------------------------------
+ -- Install_Restricted_Handlers --
+ ---------------------------------
+
+ procedure Install_Restricted_Handlers
+ (Prio : Any_Priority;
+ Handlers : New_Handler_Array)
+ is
+ pragma Unreferenced (Prio);
+ begin
+ for N in Handlers'Range loop
+ Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
+ end loop;
+ end Install_Restricted_Handlers;
+
+ ------------------------------
+ -- Install_Umbrella_Handler --
+ ------------------------------
+
+ procedure Install_Umbrella_Handler
+ (Interrupt : HW_Interrupt;
+ Handler : System.OS_Interface.Interrupt_Handler)
+ is
+ Vec : constant Interrupt_Vector :=
+ Interrupt_Number_To_Vector (int (Interrupt));
+
+ Status : int;
+
+ begin
+ -- Only install umbrella handler when no Ada handler has already been
+ -- installed. Note that the interrupt number is passed as a parameter
+ -- when an interrupt occurs, so the umbrella handler has a different
+ -- wrapper generated by the connector routine for each interrupt
+ -- number.
+
+ if not Handler_Installed (Interrupt) then
+ Status :=
+ Interrupt_Connect.all (Vec, Handler, System.Address (Interrupt));
+ pragma Assert (Status = 0);
+
+ Handler_Installed (Interrupt) := True;
+ end if;
+ end Install_Umbrella_Handler;
+
+ ----------------
+ -- Is_Blocked --
+ ----------------
+
+ function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented ("Is_Blocked");
+ return False;
+ end Is_Blocked;
+
+ -----------------------
+ -- Is_Entry_Attached --
+ -----------------------
+
+ function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return User_Entry (Interrupt).T /= Null_Task;
+ end Is_Entry_Attached;
+
+ -------------------------
+ -- Is_Handler_Attached --
+ -------------------------
+
+ function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return User_Handler (Interrupt).H /= null;
+ end Is_Handler_Attached;
+
+ ----------------
+ -- Is_Ignored --
+ ----------------
+
+ function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
+ begin
+ Unimplemented ("Is_Ignored");
+ return False;
+ end Is_Ignored;
+
+ -------------------
+ -- Is_Registered --
+ -------------------
+
+ function Is_Registered (Handler : Parameterless_Handler) return Boolean is
+ type Fat_Ptr is record
+ Object_Addr : System.Address;
+ Handler_Addr : System.Address;
+ end record;
+
+ function To_Fat_Ptr is new Ada.Unchecked_Conversion
+ (Parameterless_Handler, Fat_Ptr);
+
+ Ptr : R_Link;
+ Fat : Fat_Ptr;
+
+ begin
+ if Handler = null then
+ return True;
+ end if;
+
+ Fat := To_Fat_Ptr (Handler);
+
+ Ptr := Registered_Handler_Head;
+ while Ptr /= null loop
+ if Ptr.H = Fat.Handler_Addr then
+ return True;
+ end if;
+
+ Ptr := Ptr.Next;
+ end loop;
+
+ return False;
+ end Is_Registered;
+
+ -----------------
+ -- Is_Reserved --
+ -----------------
+
+ function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ use System.Interrupt_Management;
+ begin
+ return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt));
+ end Is_Reserved;
+
+ ----------------------
+ -- Notify_Interrupt --
+ ----------------------
+
+ -- Umbrella handler for vectored hardware interrupts (as opposed to signals
+ -- and exceptions). As opposed to the signal implementation, this handler
+ -- is installed in the vector table when the first Ada handler is attached
+ -- to the interrupt. However because VxWorks don't support disconnecting
+ -- handlers, this subprogram always test whether or not an Ada handler is
+ -- effectively attached.
+
+ -- Otherwise, the handler that existed prior to program startup is in the
+ -- vector table. This ensures that handlers installed by the BSP are active
+ -- unless explicitly replaced in the program text.
+
+ -- Each Interrupt_Server_Task has an associated binary semaphore on which
+ -- it pends once it's been started. This routine determines The appropriate
+ -- semaphore and issues a semGive call, waking the server task. When
+ -- a handler is unbound, System.Interrupts.Unbind_Handler issues a
+ -- Binary_Semaphore_Flush, and the server task deletes its semaphore
+ -- and terminates.
+
+ procedure Notify_Interrupt (Param : System.Address) is
+ Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
+ Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt);
+ Status : int;
+ begin
+ if Id /= 0 then
+ Status := Binary_Semaphore_Release (Id);
+ pragma Assert (Status = 0);
+ end if;
+ end Notify_Interrupt;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ function Reference (Interrupt : Interrupt_ID) return System.Address is
+ begin
+ Check_Reserved_Interrupt (Interrupt);
+ return Storage_Elements.To_Address
+ (Storage_Elements.Integer_Address (Interrupt));
+ end Reference;
+
+ --------------------------------
+ -- Register_Interrupt_Handler --
+ --------------------------------
+
+ procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
+ New_Node_Ptr : R_Link;
+
+ begin
+ -- This routine registers a handler as usable for dynamic interrupt
+ -- handler association. Routines attaching and detaching handlers
+ -- dynamically should determine whether the handler is registered.
+ -- Program_Error should be raised if it is not registered.
+
+ -- Pragma Interrupt_Handler can only appear in a library level PO
+ -- definition and instantiation. Therefore, we do not need to implement
+ -- an unregister operation. Nor do we need to protect the queue
+ -- structure with a lock.
+
+ pragma Assert (Handler_Addr /= System.Null_Address);
+
+ New_Node_Ptr := new Registered_Handler;
+ New_Node_Ptr.H := Handler_Addr;
+
+ if Registered_Handler_Head = null then
+ Registered_Handler_Head := New_Node_Ptr;
+ Registered_Handler_Tail := New_Node_Ptr;
+ else
+ Registered_Handler_Tail.Next := New_Node_Ptr;
+ Registered_Handler_Tail := New_Node_Ptr;
+ end if;
+ end Register_Interrupt_Handler;
+
+ -----------------------
+ -- Unblock_Interrupt --
+ -----------------------
+
+ procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Unblock_Interrupt");
+ end Unblock_Interrupt;
+
+ ------------------
+ -- Unblocked_By --
+ ------------------
+
+ function Unblocked_By
+ (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
+ is
+ begin
+ Unimplemented ("Unblocked_By");
+ return Null_Task;
+ end Unblocked_By;
+
+ ------------------------
+ -- Unignore_Interrupt --
+ ------------------------
+
+ procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
+ begin
+ Unimplemented ("Unignore_Interrupt");
+ end Unignore_Interrupt;
+
+ -------------------
+ -- Unimplemented --
+ -------------------
+
+ procedure Unimplemented (Feature : String) is
+ begin
+ raise Program_Error with Feature & " not implemented on VxWorks";
+ end Unimplemented;
+
+ -----------------------
+ -- Interrupt_Manager --
+ -----------------------
+
+ task body Interrupt_Manager is
+ -- By making this task independent of any master, when the process goes
+ -- away, the Interrupt_Manager will terminate gracefully.
+
+ Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
+ pragma Unreferenced (Ignore);
+
+ --------------------
+ -- Local Routines --
+ --------------------
+
+ procedure Bind_Handler (Interrupt : Interrupt_ID);
+ -- This procedure does not do anything if a signal is blocked.
+ -- Otherwise, we have to interrupt Server_Task for status change
+ -- through a wakeup signal.
+
+ procedure Unbind_Handler (Interrupt : Interrupt_ID);
+ -- This procedure does not do anything if a signal is blocked.
+ -- Otherwise, we have to interrupt Server_Task for status change
+ -- through an abort signal.
+
+ procedure Unprotected_Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
+
+ procedure Unprotected_Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
+
+ ------------------
+ -- Bind_Handler --
+ ------------------
+
+ procedure Bind_Handler (Interrupt : Interrupt_ID) is
+ begin
+ Install_Umbrella_Handler
+ (HW_Interrupt (Interrupt), Notify_Interrupt'Access);
+ end Bind_Handler;
+
+ --------------------
+ -- Unbind_Handler --
+ --------------------
+
+ procedure Unbind_Handler (Interrupt : Interrupt_ID) is
+ Status : int;
+
+ begin
+ -- Flush server task off semaphore, allowing it to terminate
+
+ Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt));
+ pragma Assert (Status = 0);
+ end Unbind_Handler;
+
+ --------------------------------
+ -- Unprotected_Detach_Handler --
+ --------------------------------
+
+ procedure Unprotected_Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
+ is
+ Old_Handler : Parameterless_Handler;
+ begin
+ if User_Entry (Interrupt).T /= Null_Task then
+
+ -- If an interrupt entry is installed raise Program_Error
+ -- (propagate it to the caller).
+
+ raise Program_Error with
+ "an interrupt entry is already installed";
+ end if;
+
+ -- Note : Static = True will pass the following check. This is the
+ -- case when we want to detach a handler regardless of the static
+ -- status of the Current_Handler.
+
+ if not Static and then User_Handler (Interrupt).Static then
+
+ -- Trying to detach a static Interrupt Handler, raise
+ -- Program_Error.
+
+ raise Program_Error with
+ "trying to detach a static Interrupt Handler";
+ end if;
+
+ Old_Handler := User_Handler (Interrupt).H;
+
+ -- The new handler
+
+ User_Handler (Interrupt).H := null;
+ User_Handler (Interrupt).Static := False;
+
+ if Old_Handler /= null then
+ Unbind_Handler (Interrupt);
+ end if;
+ end Unprotected_Detach_Handler;
+
+ ----------------------------------
+ -- Unprotected_Exchange_Handler --
+ ----------------------------------
+
+ procedure Unprotected_Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False)
+ is
+ begin
+ if User_Entry (Interrupt).T /= Null_Task then
+
+ -- If an interrupt entry is already installed, raise
+ -- Program_Error (propagate it to the caller).
+
+ raise Program_Error with "an interrupt is already installed";
+ end if;
+
+ -- Note : A null handler with Static = True will pass the following
+ -- check. This is the case when we want to detach a handler
+ -- regardless of the Static status of Current_Handler.
+
+ -- We don't check anything if Restoration is True, since we may be
+ -- detaching a static handler to restore a dynamic one.
+
+ if not Restoration and then not Static
+ and then (User_Handler (Interrupt).Static
+
+ -- Trying to overwrite a static Interrupt Handler with a dynamic
+ -- Handler
+
+ -- The new handler is not specified as an Interrupt Handler by a
+ -- pragma.
+
+ or else not Is_Registered (New_Handler))
+ then
+ raise Program_Error with
+ "trying to overwrite a static interrupt handler with a "
+ & "dynamic handler";
+ end if;
+
+ -- Save the old handler
+
+ Old_Handler := User_Handler (Interrupt).H;
+
+ -- The new handler
+
+ User_Handler (Interrupt).H := New_Handler;
+
+ if New_Handler = null then
+
+ -- The null handler means we are detaching the handler
+
+ User_Handler (Interrupt).Static := False;
+
+ else
+ User_Handler (Interrupt).Static := Static;
+ end if;
+
+ -- Invoke a corresponding Server_Task if not yet created. Place
+ -- Task_Id info in Server_ID array.
+
+ if New_Handler /= null
+ and then
+ (Server_ID (Interrupt) = Null_Task
+ or else
+ Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt))))
+ then
+ Interrupt_Access_Hold :=
+ new Interrupt_Server_Task (Interrupt, Binary_Semaphore_Create);
+ Server_ID (Interrupt) :=
+ To_System (Interrupt_Access_Hold.all'Identity);
+ end if;
+
+ if (New_Handler = null) and then Old_Handler /= null then
+
+ -- Restore default handler
+
+ Unbind_Handler (Interrupt);
+
+ elsif Old_Handler = null then
+
+ -- Save default handler
+
+ Bind_Handler (Interrupt);
+ end if;
+ end Unprotected_Exchange_Handler;
+
+ -- Start of processing for Interrupt_Manager
+
+ begin
+ loop
+ -- A block is needed to absorb Program_Error exception
+
+ declare
+ Old_Handler : Parameterless_Handler;
+
+ begin
+ select
+ accept Attach_Handler
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False)
+ do
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static, Restoration);
+ end Attach_Handler;
+
+ or
+ accept Exchange_Handler
+ (Old_Handler : out Parameterless_Handler;
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean)
+ do
+ Unprotected_Exchange_Handler
+ (Old_Handler, New_Handler, Interrupt, Static);
+ end Exchange_Handler;
+
+ or
+ accept Detach_Handler
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
+ do
+ Unprotected_Detach_Handler (Interrupt, Static);
+ end Detach_Handler;
+
+ or
+ accept Bind_Interrupt_To_Entry
+ (T : Task_Id;
+ E : Task_Entry_Index;
+ Interrupt : Interrupt_ID)
+ do
+ -- If there is a binding already (either a procedure or an
+ -- entry), raise Program_Error (propagate it to the caller).
+
+ if User_Handler (Interrupt).H /= null
+ or else User_Entry (Interrupt).T /= Null_Task
+ then
+ raise Program_Error with
+ "a binding for this interrupt is already present";
+ end if;
+
+ User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
+
+ -- Indicate the attachment of interrupt entry in the ATCB.
+ -- This is needed so when an interrupt entry task terminates
+ -- the binding can be cleaned. The call to unbinding must be
+ -- make by the task before it terminates.
+
+ T.Interrupt_Entry := True;
+
+ -- Invoke a corresponding Server_Task if not yet created.
+ -- Place Task_Id info in Server_ID array.
+
+ if Server_ID (Interrupt) = Null_Task
+ or else
+ Ada.Task_Identification.Is_Terminated
+ (To_Ada (Server_ID (Interrupt)))
+ then
+ Interrupt_Access_Hold := new Interrupt_Server_Task
+ (Interrupt, Binary_Semaphore_Create);
+ Server_ID (Interrupt) :=
+ To_System (Interrupt_Access_Hold.all'Identity);
+ end if;
+
+ Bind_Handler (Interrupt);
+ end Bind_Interrupt_To_Entry;
+
+ or
+ accept Detach_Interrupt_Entries (T : Task_Id) do
+ for Int in Interrupt_ID'Range loop
+ if not Is_Reserved (Int) then
+ if User_Entry (Int).T = T then
+ User_Entry (Int) :=
+ Entry_Assoc'
+ (T => Null_Task, E => Null_Task_Entry);
+ Unbind_Handler (Int);
+ end if;
+ end if;
+ end loop;
+
+ -- Indicate in ATCB that no interrupt entries are attached
+
+ T.Interrupt_Entry := False;
+ end Detach_Interrupt_Entries;
+ end select;
+
+ exception
+ -- If there is a Program_Error we just want to propagate it to
+ -- the caller and do not want to stop this task.
+
+ when Program_Error =>
+ null;
+
+ when others =>
+ pragma Assert (False);
+ null;
+ end;
+ end loop;
+
+ exception
+ when Standard'Abort_Signal =>
+
+ -- Flush interrupt server semaphores, so they can terminate
+
+ Finalize_Interrupt_Servers;
+ raise;
+ end Interrupt_Manager;
+
+ ---------------------------
+ -- Interrupt_Server_Task --
+ ---------------------------
+
+ -- Server task for vectored hardware interrupt handling
+
+ task body Interrupt_Server_Task is
+ Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
+
+ Self_Id : constant Task_Id := Self;
+ Tmp_Handler : Parameterless_Handler;
+ Tmp_ID : Task_Id;
+ Tmp_Entry_Index : Task_Entry_Index;
+ Status : int;
+
+ begin
+ Semaphore_ID_Map (Interrupt) := Int_Sema;
+
+ loop
+ -- Pend on semaphore that will be triggered by the umbrella handler
+ -- when the associated interrupt comes in.
+
+ Status := Binary_Semaphore_Obtain (Int_Sema);
+ pragma Assert (Status = 0);
+
+ if User_Handler (Interrupt).H /= null then
+
+ -- Protected procedure handler
+
+ Tmp_Handler := User_Handler (Interrupt).H;
+ Tmp_Handler.all;
+
+ elsif User_Entry (Interrupt).T /= Null_Task then
+
+ -- Interrupt entry handler
+
+ Tmp_ID := User_Entry (Interrupt).T;
+ Tmp_Entry_Index := User_Entry (Interrupt).E;
+ System.Tasking.Rendezvous.Call_Simple
+ (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
+
+ else
+ -- Semaphore has been flushed by an unbind operation in the
+ -- Interrupt_Manager. Terminate the server task.
+
+ -- Wait for the Interrupt_Manager to complete its work
+
+ POP.Write_Lock (Self_Id);
+
+ -- Unassociate the interrupt handler
+
+ Semaphore_ID_Map (Interrupt) := 0;
+
+ -- Delete the associated semaphore
+
+ Status := Binary_Semaphore_Delete (Int_Sema);
+
+ pragma Assert (Status = 0);
+
+ -- Set status for the Interrupt_Manager
+
+ Server_ID (Interrupt) := Null_Task;
+ POP.Unlock (Self_Id);
+
+ exit;
+ end if;
+ end loop;
+ end Interrupt_Server_Task;
+
+begin
+ -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
+
+ Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
+end System.Interrupts;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Invariants:
+
+-- All user-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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2014-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- In particular, you can freely distribute your programs built with the --
+-- GNAT Pro compiler, including any required library run-time units, using --
+-- any licensing terms of your choosing. See the AdaCore Software License --
+-- for full details. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Android version of this package
+
+-- Make a careful study of all signals available under the OS, to see which
+-- need to be reserved, kept always unmasked, or kept always unmasked. Be on
+-- the lookout for special signals that may be used by the thread library.
+
+-- Since this is a multi target file, the signal <-> exception mapping
+-- is simple minded. If you need a more precise and target specific
+-- signal handling, create a new s-intman.adb that will fit your needs.
+
+-- This file assumes that:
+
+-- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows:
+-- SIGPFE => Constraint_Error
+-- SIGILL => Program_Error
+-- SIGSEGV => Storage_Error
+-- SIGBUS => Storage_Error
+
+-- SIGINT exists and will be kept unmasked unless the pragma
+-- Unreserve_All_Interrupts is specified anywhere in the application.
+
+-- System.OS_Interface contains the following:
+-- SIGADAABORT: the signal that will be used to abort tasks.
+-- Unmasked: the OS specific set of signals that should be unmasked in
+-- all the threads. SIGADAABORT is unmasked by
+-- default
+-- Reserved: the OS specific set of signals that are reserved.
+
+with System.Task_Primitives;
+
+package body System.Interrupt_Management is
+
+ use Interfaces.C;
+ use System.OS_Interface;
+
+ type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
+ Exception_Interrupts : constant Interrupt_List :=
+ (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
+
+ Unreserve_All_Interrupts : Interfaces.C.int;
+ pragma Import
+ (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Signal_Trampoline
+ (signo : Signal;
+ siginfo : System.Address;
+ ucontext : System.Address;
+ handler : System.Address);
+ pragma Import (C, Signal_Trampoline, "__gnat_sigtramp");
+ -- Pass the real handler to a speical function that handles unwinding by
+ -- skipping over the kernel signal frame (which doesn't contain any unwind
+ -- information).
+
+ function State (Int : Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in init.c The input argument is the
+ -- interrupt number, and the result is one of the following:
+
+ procedure Map_Signal
+ (signo : Signal;
+ siginfo : System.Address;
+ ucontext : System.Address);
+ -- This function identifies the Ada exception to be raised using the
+ -- information when the system received a synchronous signal.
+
+----------------
+-- Map_Signal --
+----------------
+
+ procedure Map_Signal
+ (signo : Signal;
+ siginfo : System.Address;
+ ucontext : System.Address)
+ is
+ pragma Unreferenced (siginfo);
+ pragma Unreferenced (ucontext);
+
+ begin
+ -- Check that treatment of exception propagation here is consistent with
+ -- treatment of the abort signal in System.Task_Primitives.Operations.
+
+ case signo is
+ when SIGFPE => raise Constraint_Error;
+ when SIGILL => raise Program_Error;
+ when SIGSEGV => raise Storage_Error;
+ when SIGBUS => raise Storage_Error;
+ when others => null;
+ end case;
+ end Map_Signal;
+
+----------------------
+-- Notify_Exception --
+----------------------
+
+ User : constant Character := 'u';
+ Runtime : constant Character := 'r';
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
+ procedure Notify_Exception
+ (signo : Signal;
+ siginfo : System.Address;
+ ucontext : System.Address);
+ -- This function is the signal handler and calls a trampoline subprogram
+ -- that adjusts the unwind information so the ARM unwinder can find it's
+ -- way back to the context of the originating subprogram. Compare with
+ -- __gnat_error_handler for non-tasking programs.
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ Signal_Mask : aliased sigset_t;
+ -- The set of signals handled by Notify_Exception
+
+ procedure Notify_Exception
+ (signo : Signal;
+ siginfo : System.Address;
+ ucontext : System.Address)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ -- With the __builtin_longjmp, the signal mask is not restored, so we
+ -- need to restore it explicitly. ??? We don't use __builtin_longjmp
+ -- anymore, so do we still need this? */
+
+ Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
+ pragma Assert (Result = 0);
+
+ -- Perform the necessary context adjustments prior to calling the
+ -- trampoline subprogram with the "real" signal handler.
+
+ Adjust_Context_For_Raise (signo, ucontext);
+
+ Signal_Trampoline (signo, siginfo, ucontext, Map_Signal'Address);
+ end Notify_Exception;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ Initialized : Boolean := False;
+
+ procedure Initialize is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Result : System.OS_Interface.int;
+
+ Use_Alternate_Stack : constant Boolean :=
+ System.Task_Primitives.Alternate_Stack_Size /= 0;
+ -- Whether to use an alternate signal stack for stack overflows
+
+ begin
+ if Initialized then
+ return;
+ end if;
+
+ Initialized := True;
+
+ -- Need to call pthread_init very early because it is doing signal
+ -- initializations.
+
+ pthread_init;
+
+ Abort_Task_Interrupt := SIGADAABORT;
+
+ act.sa_handler := Notify_Exception'Address;
+
+ -- Setting SA_SIGINFO asks the kernel to pass more than just the signal
+ -- number argument to the handler when it is called. The set of extra
+ -- parameters includes a pointer to the interrupted context, which the
+ -- ZCX propagation scheme needs.
+
+ -- Most man pages for sigaction mention that sa_sigaction should be set
+ -- instead of sa_handler when SA_SIGINFO is on. In practice, the two
+ -- fields are actually union'ed and located at the same offset.
+
+ -- On some targets, we set sa_flags to SA_NODEFER so that during the
+ -- handler execution we do not change the Signal_Mask to be masked for
+ -- the Signal.
+
+ -- This is a temporary fix to the problem that the Signal_Mask is not
+ -- restored after the exception (longjmp) from the handler. The right
+ -- fix should be made in sigsetjmp so that we save the Signal_Set and
+ -- restore it after a longjmp.
+
+ -- We set SA_NODEFER to be compatible with what is done in
+ -- __gnat_error_handler.
+
+ Result := sigemptyset (Signal_Mask'Access);
+ pragma Assert (Result = 0);
+
+ -- Add signals that map to Ada exceptions to the mask
+
+ for J in Exception_Interrupts'Range loop
+ if State (Exception_Interrupts (J)) /= Default then
+ Result :=
+ sigaddset
+ (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ act.sa_mask := Signal_Mask;
+
+ pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
+
+ -- Process state of exception signals
+
+ for J in Exception_Interrupts'Range loop
+ if State (Exception_Interrupts (J)) /= User then
+ Keep_Unmasked (Exception_Interrupts (J)) := True;
+ Reserve (Exception_Interrupts (J)) := True;
+
+ if State (Exception_Interrupts (J)) /= Default then
+ act.sa_flags := SA_NODEFER + SA_RESTART + SA_SIGINFO;
+
+ if Use_Alternate_Stack
+ and then Exception_Interrupts (J) = SIGSEGV
+ then
+ act.sa_flags := act.sa_flags + SA_ONSTACK;
+ end if;
+
+ Result :=
+ sigaction
+ (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end loop;
+
+ if State (Abort_Task_Interrupt) /= User then
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+ Reserve (Abort_Task_Interrupt) := True;
+ end if;
+
+ -- Set SIGINT to unmasked state as long as it is not in "User" state.
+ -- Check for Unreserve_All_Interrupts last.
+
+ if State (SIGINT) /= User then
+ Keep_Unmasked (SIGINT) := True;
+ Reserve (SIGINT) := True;
+ end if;
+
+ -- Check all signals for state that requires keeping them unmasked and
+ -- reserved.
+
+ for J in Interrupt_ID'Range loop
+ if State (J) = Default or else State (J) = Runtime then
+ Keep_Unmasked (J) := True;
+ Reserve (J) := True;
+ end if;
+ end loop;
+
+ -- Add the set of signals that must always be unmasked for this target
+
+ for J in Unmasked'Range loop
+ Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
+ Reserve (Interrupt_ID (Unmasked (J))) := True;
+ end loop;
+
+ -- Add target-specific reserved signals
+
+ for J in Reserved'Range loop
+ Reserve (Interrupt_ID (Reserved (J))) := True;
+ end loop;
+
+ -- Process pragma Unreserve_All_Interrupts. This overrides any settings
+ -- due to pragma Interrupt_State:
+
+ if Unreserve_All_Interrupts /= 0 then
+ Keep_Unmasked (SIGINT) := False;
+ Reserve (SIGINT) := False;
+ end if;
+
+ -- We do not really have Signal 0. We just use this value to identify
+ -- non-existent signals (see s-intnam.ads). Therefore, Signal should not
+ -- be used in all signal related operations hence mark it as reserved.
+
+ Reserve (0) := True;
+ end Initialize;
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1997-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a NO tasking version of this package
+
+package body System.Interrupt_Management is
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the NT version of this package
+
+with System.OS_Interface; use System.OS_Interface;
+
+package body System.Interrupt_Management is
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ -- "Reserve" all the interrupts, except those that are explicitly
+ -- defined.
+
+ for J in Interrupt_ID'Range loop
+ Reserve (J) := True;
+ end loop;
+
+ Reserve (SIGINT) := False;
+ Reserve (SIGILL) := False;
+ Reserve (SIGABRT) := False;
+ Reserve (SIGFPE) := False;
+ Reserve (SIGSEGV) := False;
+ Reserve (SIGTERM) := False;
+ end Initialize;
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the POSIX threads version of this package
+
+-- Make a careful study of all signals available under the OS, to see which
+-- need to be reserved, kept always unmasked, or kept always unmasked. Be on
+-- the lookout for special signals that may be used by the thread library.
+
+-- Since this is a multi target file, the signal <-> exception mapping
+-- is simple minded. If you need a more precise and target specific
+-- signal handling, create a new s-intman.adb that will fit your needs.
+
+-- This file assumes that:
+
+-- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows:
+-- SIGPFE => Constraint_Error
+-- SIGILL => Program_Error
+-- SIGSEGV => Storage_Error
+-- SIGBUS => Storage_Error
+
+-- SIGINT exists and will be kept unmasked unless the pragma
+-- Unreserve_All_Interrupts is specified anywhere in the application.
+
+-- System.OS_Interface contains the following:
+-- SIGADAABORT: the signal that will be used to abort tasks.
+-- Unmasked: the OS specific set of signals that should be unmasked in
+-- all the threads. SIGADAABORT is unmasked by
+-- default
+-- Reserved: the OS specific set of signals that are reserved.
+
+with System.Task_Primitives;
+
+package body System.Interrupt_Management is
+
+ use Interfaces.C;
+ use System.OS_Interface;
+
+ type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
+ Exception_Interrupts : constant Interrupt_List :=
+ (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
+
+ Unreserve_All_Interrupts : Interfaces.C.int;
+ pragma Import
+ (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function State (Int : Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in init.c The input argument is the
+ -- interrupt number, and the result is one of the following:
+
+ User : constant Character := 'u';
+ Runtime : constant Character := 'r';
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
+ procedure Notify_Exception
+ (signo : Signal;
+ siginfo : System.Address;
+ ucontext : System.Address);
+ -- This function identifies the Ada exception to be raised using the
+ -- information when the system received a synchronous signal. Since this
+ -- function is machine and OS dependent, different code has to be provided
+ -- for different target.
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ Signal_Mask : aliased sigset_t;
+ -- The set of signals handled by Notify_Exception
+
+ procedure Notify_Exception
+ (signo : Signal;
+ siginfo : System.Address;
+ ucontext : System.Address)
+ is
+ pragma Unreferenced (siginfo);
+
+ Result : Interfaces.C.int;
+
+ begin
+ -- With the __builtin_longjmp, the signal mask is not restored, so we
+ -- need to restore it explicitly.
+
+ Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
+ pragma Assert (Result = 0);
+
+ -- Perform the necessary context adjustments prior to a raise
+ -- from a signal handler.
+
+ Adjust_Context_For_Raise (signo, ucontext);
+
+ -- Check that treatment of exception propagation here is consistent with
+ -- treatment of the abort signal in System.Task_Primitives.Operations.
+
+ case signo is
+ when SIGFPE => raise Constraint_Error;
+ when SIGILL => raise Program_Error;
+ when SIGSEGV => raise Storage_Error;
+ when SIGBUS => raise Storage_Error;
+ when others => null;
+ end case;
+ end Notify_Exception;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ Initialized : Boolean := False;
+
+ procedure Initialize is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Result : System.OS_Interface.int;
+
+ Use_Alternate_Stack : constant Boolean :=
+ System.Task_Primitives.Alternate_Stack_Size /= 0;
+ -- Whether to use an alternate signal stack for stack overflows
+
+ begin
+ if Initialized then
+ return;
+ end if;
+
+ Initialized := True;
+
+ -- Need to call pthread_init very early because it is doing signal
+ -- initializations.
+
+ pthread_init;
+
+ Abort_Task_Interrupt := SIGADAABORT;
+
+ act.sa_handler := Notify_Exception'Address;
+
+ -- Setting SA_SIGINFO asks the kernel to pass more than just the signal
+ -- number argument to the handler when it is called. The set of extra
+ -- parameters includes a pointer to the interrupted context, which the
+ -- ZCX propagation scheme needs.
+
+ -- Most man pages for sigaction mention that sa_sigaction should be set
+ -- instead of sa_handler when SA_SIGINFO is on. In practice, the two
+ -- fields are actually union'ed and located at the same offset.
+
+ -- On some targets, we set sa_flags to SA_NODEFER so that during the
+ -- handler execution we do not change the Signal_Mask to be masked for
+ -- the Signal.
+
+ -- This is a temporary fix to the problem that the Signal_Mask is not
+ -- restored after the exception (longjmp) from the handler. The right
+ -- fix should be made in sigsetjmp so that we save the Signal_Set and
+ -- restore it after a longjmp.
+
+ -- Since SA_NODEFER is obsolete, instead we reset explicitly the mask
+ -- in the exception handler.
+
+ Result := sigemptyset (Signal_Mask'Access);
+ pragma Assert (Result = 0);
+
+ -- Add signals that map to Ada exceptions to the mask
+
+ for J in Exception_Interrupts'Range loop
+ if State (Exception_Interrupts (J)) /= Default then
+ Result :=
+ sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ act.sa_mask := Signal_Mask;
+
+ pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
+
+ -- Process state of exception signals
+
+ for J in Exception_Interrupts'Range loop
+ if State (Exception_Interrupts (J)) /= User then
+ Keep_Unmasked (Exception_Interrupts (J)) := True;
+ Reserve (Exception_Interrupts (J)) := True;
+
+ if State (Exception_Interrupts (J)) /= Default then
+ act.sa_flags := SA_SIGINFO;
+
+ if Use_Alternate_Stack
+ and then Exception_Interrupts (J) = SIGSEGV
+ then
+ act.sa_flags := act.sa_flags + SA_ONSTACK;
+ end if;
+
+ Result :=
+ sigaction
+ (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end loop;
+
+ if State (Abort_Task_Interrupt) /= User then
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+ Reserve (Abort_Task_Interrupt) := True;
+ end if;
+
+ -- Set SIGINT to unmasked state as long as it is not in "User" state.
+ -- Check for Unreserve_All_Interrupts last.
+
+ if State (SIGINT) /= User then
+ Keep_Unmasked (SIGINT) := True;
+ Reserve (SIGINT) := True;
+ end if;
+
+ -- Check all signals for state that requires keeping them unmasked and
+ -- reserved.
+
+ for J in Interrupt_ID'Range loop
+ if State (J) = Default or else State (J) = Runtime then
+ Keep_Unmasked (J) := True;
+ Reserve (J) := True;
+ end if;
+ end loop;
+
+ -- Add the set of signals that must always be unmasked for this target
+
+ for J in Unmasked'Range loop
+ Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
+ Reserve (Interrupt_ID (Unmasked (J))) := True;
+ end loop;
+
+ -- Add target-specific reserved signals
+
+ for J in Reserved'Range loop
+ Reserve (Interrupt_ID (Reserved (J))) := True;
+ end loop;
+
+ -- Process pragma Unreserve_All_Interrupts. This overrides any settings
+ -- due to pragma Interrupt_State:
+
+ if Unreserve_All_Interrupts /= 0 then
+ Keep_Unmasked (SIGINT) := False;
+ Reserve (SIGINT) := False;
+ end if;
+
+ -- We do not really have Signal 0. We just use this value to identify
+ -- non-existent signals (see s-intnam.ads). Therefore, Signal should not
+ -- be used in all signal related operations hence mark it as reserved.
+
+ Reserve (0) := True;
+ end Initialize;
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris version of this package
+
+-- Make a careful study of all signals available under the OS, to see which
+-- need to be reserved, kept always unmasked, or kept always unmasked.
+
+-- Be on the lookout for special signals that may be used by the thread
+-- library.
+
+package body System.Interrupt_Management is
+
+ use Interfaces.C;
+ use System.OS_Interface;
+
+ type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
+
+ Exception_Interrupts : constant Interrupt_List :=
+ (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
+
+ Unreserve_All_Interrupts : Interfaces.C.int;
+ pragma Import
+ (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
+
+ function State (Int : Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ User : constant Character := 'u';
+ Runtime : constant Character := 'r';
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ -- This function identifies the Ada exception to be raised using the
+ -- information when the system received a synchronous signal. Since this
+ -- function is machine and OS dependent, different code has to be provided
+ -- for different target.
+
+ procedure Notify_Exception
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access ucontext_t);
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ procedure Notify_Exception
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access ucontext_t)
+ is
+ pragma Unreferenced (info);
+
+ begin
+ -- Perform the necessary context adjustments prior to a raise from a
+ -- signal handler.
+
+ Adjust_Context_For_Raise (signo, context.all'Address);
+
+ -- Check that treatment of exception propagation here is consistent with
+ -- treatment of the abort signal in System.Task_Primitives.Operations.
+
+ case signo is
+ when SIGFPE => raise Constraint_Error;
+ when SIGILL => raise Program_Error;
+ when SIGSEGV => raise Storage_Error;
+ when SIGBUS => raise Storage_Error;
+ when others => null;
+ end case;
+ end Notify_Exception;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ Initialized : Boolean := False;
+
+ procedure Initialize is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ mask : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ begin
+ if Initialized then
+ return;
+ end if;
+
+ Initialized := True;
+
+ -- Need to call pthread_init very early because it is doing signal
+ -- initializations.
+
+ pthread_init;
+
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ Abort_Task_Interrupt := SIGABRT;
+
+ act.sa_handler := Notify_Exception'Address;
+
+ -- Set sa_flags to SA_NODEFER so that during the handler execution
+ -- we do not change the Signal_Mask to be masked for the Signal.
+ -- This is a temporary fix to the problem that the Signal_Mask is
+ -- not restored after the exception (longjmp) from the handler.
+ -- The right fix should be made in sigsetjmp so that we save
+ -- the Signal_Set and restore it after a longjmp.
+
+ -- In that case, this field should be changed back to 0. ??? (Dong-Ik)
+
+ act.sa_flags := 16;
+
+ Result := sigemptyset (mask'Access);
+ pragma Assert (Result = 0);
+
+ -- ??? For the same reason explained above, we can't mask these signals
+ -- because otherwise we won't be able to catch more than one signal.
+
+ act.sa_mask := mask;
+
+ pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
+
+ for J in Exception_Interrupts'Range loop
+ if State (Exception_Interrupts (J)) /= User then
+ Keep_Unmasked (Exception_Interrupts (J)) := True;
+ Reserve (Exception_Interrupts (J)) := True;
+
+ if State (Exception_Interrupts (J)) /= Default then
+ Result :=
+ sigaction
+ (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end loop;
+
+ if State (Abort_Task_Interrupt) /= User then
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+ Reserve (Abort_Task_Interrupt) := True;
+ end if;
+
+ -- Set SIGINT to unmasked state as long as it's
+ -- not in "User" state. Check for Unreserve_All_Interrupts last
+
+ if State (SIGINT) /= User then
+ Keep_Unmasked (SIGINT) := True;
+ Reserve (SIGINT) := True;
+ end if;
+
+ -- Check all signals for state that requires keeping them
+ -- unmasked and reserved
+
+ for J in Interrupt_ID'Range loop
+ if State (J) = Default or else State (J) = Runtime then
+ Keep_Unmasked (J) := True;
+ Reserve (J) := True;
+ end if;
+ end loop;
+
+ -- Add the set of signals that must always be unmasked for this target
+
+ for J in Unmasked'Range loop
+ Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
+ Reserve (Interrupt_ID (Unmasked (J))) := True;
+ end loop;
+
+ -- Add target-specific reserved signals
+
+ for J in Reserved'Range loop
+ Reserve (Interrupt_ID (Reserved (J))) := True;
+ end loop;
+
+ -- Process pragma Unreserve_All_Interrupts. This overrides any
+ -- settings due to pragma Interrupt_State:
+
+ if Unreserve_All_Interrupts /= 0 then
+ Keep_Unmasked (SIGINT) := False;
+ Reserve (SIGINT) := False;
+ end if;
+
+ -- We do not have Signal 0 in reality. We just use this value to
+ -- identify not existing signals (see s-intnam.ads). Therefore, Signal 0
+ -- should not be used in all signal related operations hence mark it as
+ -- reserved.
+
+ Reserve (0) := True;
+ end Initialize;
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the SuSV3 threads version of this package
+
+-- Make a careful study of all signals available under the OS, to see which
+-- need to be reserved, kept always unmasked, or kept always unmasked. Be on
+-- the lookout for special signals that may be used by the thread library.
+
+-- Since this is a multi target file, the signal <-> exception mapping
+-- is simple minded. If you need a more precise and target specific
+-- signal handling, create a new s-intman.adb that will fit your needs.
+
+-- This file assumes that:
+
+-- SIGINT exists and will be kept unmasked unless the pragma
+-- Unreserve_All_Interrupts is specified anywhere in the application.
+
+-- System.OS_Interface contains the following:
+-- SIGADAABORT: the signal that will be used to abort tasks.
+-- Unmasked: the OS specific set of signals that should be unmasked in
+-- all the threads. SIGADAABORT is unmasked by
+-- default
+-- Reserved: the OS specific set of signals that are reserved.
+
+package body System.Interrupt_Management is
+
+ use Interfaces.C;
+ use System.OS_Interface;
+
+ Unreserve_All_Interrupts : Interfaces.C.int;
+ pragma Import
+ (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function State (Int : Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in init.c The input argument is the
+ -- interrupt number, and the result is one of the following:
+
+ User : constant Character := 'u';
+ Runtime : constant Character := 'r';
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ Initialized : Boolean := False;
+
+ procedure Initialize is
+ begin
+ if Initialized then
+ return;
+ end if;
+
+ Initialized := True;
+
+ -- Need to call pthread_init very early because it is doing signal
+ -- initializations.
+
+ pthread_init;
+
+ Abort_Task_Interrupt := SIGADAABORT;
+
+ pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
+
+ -- Process state of exception signals
+
+ for J in Exception_Signals'Range loop
+ declare
+ Sig : constant Signal := Exception_Signals (J);
+ Id : constant Interrupt_ID := Interrupt_ID (Sig);
+ begin
+ if State (Id) /= User then
+ Keep_Unmasked (Id) := True;
+ Reserve (Id) := True;
+ end if;
+ end;
+ end loop;
+
+ if State (Abort_Task_Interrupt) /= User then
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+ Reserve (Abort_Task_Interrupt) := True;
+ end if;
+
+ -- Set SIGINT to unmasked state as long as it is not in "User" state.
+ -- Check for Unreserve_All_Interrupts last.
+
+ if State (SIGINT) /= User then
+ Keep_Unmasked (SIGINT) := True;
+ Reserve (SIGINT) := True;
+ end if;
+
+ -- Check all signals for state that requires keeping them unmasked and
+ -- reserved.
+
+ for J in Interrupt_ID'Range loop
+ if State (J) = Default or else State (J) = Runtime then
+ Keep_Unmasked (J) := True;
+ Reserve (J) := True;
+ end if;
+ end loop;
+
+ -- Add the set of signals that must always be unmasked for this target
+
+ for J in Unmasked'Range loop
+ Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
+ Reserve (Interrupt_ID (Unmasked (J))) := True;
+ end loop;
+
+ -- Add target-specific reserved signals
+
+ for J in Reserved'Range loop
+ Reserve (Interrupt_ID (Reserved (J))) := True;
+ end loop;
+
+ -- Process pragma Unreserve_All_Interrupts. This overrides any settings
+ -- due to pragma Interrupt_State:
+
+ if Unreserve_All_Interrupts /= 0 then
+ Keep_Unmasked (SIGINT) := False;
+ Reserve (SIGINT) := False;
+ end if;
+
+ -- We do not really have Signal 0. We just use this value to identify
+ -- non-existent signals (see s-intnam.ads). Therefore, Signal should not
+ -- be used in all signal related operations hence mark it as reserved.
+
+ Reserve (0) := True;
+ end Initialize;
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks version of this package
+
+-- It is simpler than other versions because the Ada interrupt handling
+-- mechanisms are used for hardware interrupts rather than signals.
+
+package body System.Interrupt_Management is
+
+ use System.OS_Interface;
+ use type Interfaces.C.int;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function State (Int : Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in init.c The input argument is the
+ -- hardware interrupt number, and the result is one of the following:
+
+ Runtime : constant Character := 'r';
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ Initialized : Boolean := False;
+ -- Set to True once Initialize is called, further calls have no effect
+
+ procedure Initialize is
+
+ begin
+ if Initialized then
+ return;
+ end if;
+
+ Initialized := True;
+
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ Abort_Task_Interrupt := SIGABRT;
+
+ -- Initialize hardware interrupt handling
+
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
+
+ -- Check all interrupts for state that requires keeping them reserved
+
+ for J in Interrupt_ID'Range loop
+ if State (J) = Default or else State (J) = Runtime then
+ Reserve (J) := True;
+ end if;
+ end loop;
+
+ end Initialize;
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks version of this package
+
+-- This package encapsulates and centralizes information about all
+-- uses of interrupts (or signals), including the target-dependent
+-- mapping of interrupts (or signals) to exceptions.
+
+-- Unlike the original design, System.Interrupt_Management can only
+-- be used for tasking systems.
+
+-- PLEASE DO NOT put any subprogram declarations with arguments of
+-- type Interrupt_ID into the visible part of this package. The type
+-- Interrupt_ID is used to derive the type in Ada.Interrupts, and
+-- adding more operations to that type would be illegal according
+-- to the Ada Reference Manual. This is the reason why the signals
+-- sets are implemented using visible arrays rather than functions.
+
+with System.OS_Interface;
+
+with Interfaces.C;
+
+package System.Interrupt_Management is
+ pragma Preelaborate;
+
+ type Interrupt_Mask is limited private;
+
+ type Interrupt_ID is new Interfaces.C.int
+ range 0 .. System.OS_Interface.Max_Interrupt;
+
+ type Interrupt_Set is array (Interrupt_ID) of Boolean;
+
+ subtype Signal_ID is Interrupt_ID range 0 .. System.OS_Interface.NSIG - 1;
+
+ type Signal_Set is array (Signal_ID) of Boolean;
+
+ -- The following objects serve as constants, but are initialized in the
+ -- body to aid portability. This permits us to use more portable names for
+ -- interrupts, where distinct names may map to the same interrupt ID
+ -- value.
+
+ -- For example, suppose SIGRARE is a signal that is not defined on all
+ -- systems, but is always reserved when it is defined. If we have the
+ -- convention that ID zero is not used for any "real" signals, and SIGRARE
+ -- = 0 when SIGRARE is not one of the locally supported signals, we can
+ -- write:
+ -- Reserved (SIGRARE) := True;
+ -- and the initialization code will be portable.
+
+ Abort_Task_Interrupt : Signal_ID;
+ -- The signal that is used to implement task abort if an interrupt is used
+ -- for that purpose. This is one of the reserved signals.
+
+ Reserve : Interrupt_Set := (others => False);
+ -- Reserve (I) is true iff the interrupt I is one that cannot be permitted
+ -- to be attached to a user handler. The possible reasons are many. For
+ -- example, it may be mapped to an exception used to implement task abort,
+ -- or used to implement time delays.
+
+ procedure Initialize_Interrupts;
+ pragma Import (C, Initialize_Interrupts, "__gnat_install_handler");
+ -- Under VxWorks, there is no signal inheritance between tasks.
+ -- This procedure is used to initialize signal-to-exception mapping in
+ -- each task.
+
+ procedure Initialize;
+ -- Initialize the various variables defined in this package. This procedure
+ -- must be called before accessing any object from this package and can be
+ -- called multiple times (only the first call has any effect).
+
+private
+ type Interrupt_Mask is new System.OS_Interface.sigset_t;
+ -- In some implementation Interrupt_Mask can be represented as a linked
+ -- list.
+
+end System.Interrupt_Management;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2009-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the alpha version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+
+package System.Linux is
+ pragma Preelaborate;
+
+ ----------
+ -- Time --
+ ----------
+
+ subtype long is Interfaces.C.long;
+ subtype suseconds_t is Interfaces.C.long;
+ subtype time_t is Interfaces.C.long;
+ subtype clockid_t is Interfaces.C.int;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type timeval is record
+ tv_sec : time_t;
+ tv_usec : suseconds_t;
+ end record;
+ pragma Convention (C, timeval);
+
+ -----------
+ -- Errno --
+ -----------
+
+ EAGAIN : constant := 35;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 60;
+
+ -------------
+ -- Signals --
+ -------------
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O now possible (4.2 BSD)
+ SIGPOLL : constant := 23; -- pollable event occurred
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGPWR : constant := 29; -- power-fail restart
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ SIGUNUSED : constant := 0;
+ SIGSTKFLT : constant := 0;
+ SIGLOST : constant := 0;
+ -- These don't exist for Linux/Alpha. The constants are present
+ -- so that we can continue to use a-intnam-linux.ads.
+
+ -- struct_sigaction offsets
+
+ sa_handler_pos : constant := 0;
+ sa_mask_pos : constant := Standard'Address_Size / 8;
+ sa_flags_pos : constant := 128 + sa_mask_pos;
+
+ SA_SIGINFO : constant := 16#40#;
+ SA_ONSTACK : constant := 16#01#;
+
+end System.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2014-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- In particular, you can freely distribute your programs built with the --
+-- GNAT Pro compiler, including any required library run-time units, using --
+-- any licensing terms of your choosing. See the AdaCore Software License --
+-- for full details. --
+-- --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Android version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package
+
+with Interfaces.C;
+
+package System.Linux is
+ pragma Preelaborate;
+
+ ----------
+ -- Time --
+ ----------
+
+ subtype long is Interfaces.C.long;
+ subtype suseconds_t is Interfaces.C.long;
+ subtype time_t is Interfaces.C.long;
+ subtype clockid_t is Interfaces.C.int;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type timeval is record
+ tv_sec : time_t;
+ tv_usec : suseconds_t;
+ end record;
+ pragma Convention (C, timeval);
+
+ -----------
+ -- Errno --
+ -----------
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 110;
+
+ -------------
+ -- Signals --
+ -------------
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 7; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 10; -- user defined signal 1
+ SIGUSR2 : constant := 12; -- user defined signal 2
+ SIGCLD : constant := 17; -- alias for SIGCHLD
+ SIGCHLD : constant := 17; -- child status change
+ SIGPWR : constant := 30; -- power-fail restart
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 23; -- urgent condition on IO channel
+ SIGPOLL : constant := 29; -- pollable event occurred
+ SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
+ SIGLOST : constant := 29; -- File lock lost
+ SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 20; -- user stop requested from tty
+ SIGCONT : constant := 18; -- stopped process has been continued
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
+ SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ -- struct_sigaction offsets
+
+ sa_handler_pos : constant := 0;
+ sa_mask_pos : constant := Standard'Address_Size / 8;
+ sa_flags_pos : constant := 4 + sa_mask_pos;
+
+ SA_SIGINFO : constant := 16#00000004#;
+ SA_ONSTACK : constant := 16#08000000#;
+ SA_RESTART : constant := 16#10000000#;
+ SA_NODEFER : constant := 16#40000000#;
+
+end System.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the hppa version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+
+package System.Linux is
+ pragma Preelaborate;
+
+ ----------
+ -- Time --
+ ----------
+
+ subtype long is Interfaces.C.long;
+ subtype suseconds_t is Interfaces.C.long;
+ subtype time_t is Interfaces.C.long;
+ subtype clockid_t is Interfaces.C.int;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type timeval is record
+ tv_sec : time_t;
+ tv_usec : suseconds_t;
+ end record;
+ pragma Convention (C, timeval);
+
+ -----------
+ -- Errno --
+ -----------
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 238;
+
+ -------------
+ -- Signals --
+ -------------
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGVTALRM : constant := 20; -- virtual timer expired
+ SIGPROF : constant := 21; -- profiling timer expired
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGIO : constant := 22; -- I/O now possible (4.2 BSD)
+ SIGWINCH : constant := 23; -- window size change
+ SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 25; -- user stop requested from tty
+ SIGCONT : constant := 26; -- stopped process has been continued
+ SIGTTIN : constant := 27; -- background tty read attempted
+ SIGTTOU : constant := 28; -- background tty write attempted
+ SIGURG : constant := 29; -- urgent condition on IO channel
+ SIGLOST : constant := 30; -- File lock lost
+ SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
+ SIGXCPU : constant := 33; -- CPU time limit exceeded
+ SIGXFSZ : constant := 34; -- filesize limit exceeded
+ SIGSTKFLT : constant := 36; -- coprocessor stack fault (Linux)
+ SIGLTHRRES : constant := 37; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 38; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 39; -- GNU/LinuxThreads debugger signal
+
+ -- struct_sigaction offsets
+
+ sa_handler_pos : constant := 0;
+ sa_flags_pos : constant := Standard'Address_Size / 8;
+ sa_mask_pos : constant := sa_flags_pos * 2;
+
+ SA_SIGINFO : constant := 16#10#;
+ SA_ONSTACK : constant := 16#01#;
+
+end System.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2009-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the MIPS version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package
+
+with Interfaces.C;
+
+package System.Linux is
+ pragma Preelaborate;
+
+ ----------
+ -- Time --
+ ----------
+
+ subtype int is Interfaces.C.int;
+ subtype long is Interfaces.C.long;
+ subtype suseconds_t is Interfaces.C.long;
+ subtype time_t is Interfaces.C.long;
+ subtype clockid_t is Interfaces.C.int;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type timeval is record
+ tv_sec : time_t;
+ tv_usec : suseconds_t;
+ end record;
+ pragma Convention (C, timeval);
+
+ -----------
+ -- Errno --
+ -----------
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 145;
+
+ -------------
+ -- Signals --
+ -------------
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGWINCH : constant := 20; -- window size change
+ SIGURG : constant := 21; -- urgent condition on IO channel
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGIO : constant := 22; -- I/O now possible (4.2 BSD)
+ SIGSTOP : constant := 23; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 24; -- user stop requested from tty
+ SIGCONT : constant := 25; -- stopped process has been continued
+ SIGTTIN : constant := 26; -- background tty read attempted
+ SIGTTOU : constant := 27; -- background tty write attempted
+ SIGVTALRM : constant := 28; -- virtual timer expired
+ SIGPROF : constant := 29; -- profiling timer expired
+ SIGXCPU : constant := 30; -- CPU time limit exceeded
+ SIGXFSZ : constant := 31; -- filesize limit exceeded
+
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ -- These don't exist for Linux/MIPS. The constants are present
+ -- so that we can continue to use a-intnam-linux.ads.
+ SIGLOST : constant := 0; -- File lock lost
+ SIGSTKFLT : constant := 0; -- coprocessor stack fault (Linux)
+ SIGUNUSED : constant := 0; -- unused signal (GNU/Linux)
+
+ -- struct_sigaction offsets
+
+ sa_handler_pos : constant := int'Size / 8;
+ sa_mask_pos : constant := int'Size / 8 +
+ Standard'Address_Size / 8;
+ sa_flags_pos : constant := 0;
+
+ SA_SIGINFO : constant := 16#08#;
+ SA_ONSTACK : constant := 16#08000000#;
+
+end System.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2009-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the SPARC version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package
+
+with Interfaces.C;
+
+package System.Linux is
+ pragma Preelaborate;
+
+ ----------
+ -- Time --
+ ----------
+
+ subtype long is Interfaces.C.long;
+ subtype suseconds_t is Interfaces.C.long;
+ subtype time_t is Interfaces.C.long;
+ subtype clockid_t is Interfaces.C.int;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type timeval is record
+ tv_sec : time_t;
+ tv_usec : suseconds_t;
+ end record;
+ pragma Convention (C, timeval);
+
+ -----------
+ -- Errno --
+ -----------
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 110;
+
+ -------------
+ -- Signals --
+ -------------
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGEMT : constant := 7; -- EMT
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCHLD : constant := 20; -- child status change
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O now possible (4.2 BSD)
+ SIGPOLL : constant := 23; -- pollable event occurred
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGLOST : constant := 29; -- File lock lost
+ SIGPWR : constant := 29; -- power-fail restart
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ SIGUNUSED : constant := 0;
+ SIGSTKFLT : constant := 0;
+ -- These don't exist for Linux/SPARC. The constants are present
+ -- so that we can continue to use a-intnam-linux.ads.
+
+ -- struct_sigaction offsets
+
+ sa_handler_pos : constant := 0;
+ sa_mask_pos : constant := Standard'Address_Size / 8;
+ sa_flags_pos : constant := 128 + sa_mask_pos;
+
+ SA_SIGINFO : constant := 16#200#;
+ SA_ONSTACK : constant := 16#001#;
+
+end System.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2013-2017, Free Software Foundation, Inc. --
+--
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the x32 version of this package
+
+-- This package encapsulates cpu specific differences between implementations
+-- of GNU/Linux, in order to share s-osinte-linux.ads.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package
+
+with Interfaces.C;
+
+package System.Linux is
+ pragma Preelaborate;
+
+ ----------
+ -- Time --
+ ----------
+
+ type time_t is new Long_Long_Integer;
+ subtype clockid_t is Interfaces.C.int;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : Long_Long_Integer;
+ end record;
+ pragma Convention (C, timespec);
+
+ type timeval is record
+ tv_sec : time_t;
+ tv_usec : Long_Long_Integer;
+ end record;
+ pragma Convention (C, timeval);
+
+ -----------
+ -- Errno --
+ -----------
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 110;
+
+ -------------
+ -- Signals --
+ -------------
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 7; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 10; -- user defined signal 1
+ SIGUSR2 : constant := 12; -- user defined signal 2
+ SIGCLD : constant := 17; -- alias for SIGCHLD
+ SIGCHLD : constant := 17; -- child status change
+ SIGPWR : constant := 30; -- power-fail restart
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 23; -- urgent condition on IO channel
+ SIGPOLL : constant := 29; -- pollable event occurred
+ SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
+ SIGLOST : constant := 29; -- File lock lost
+ SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 20; -- user stop requested from tty
+ SIGCONT : constant := 18; -- stopped process has been continued
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
+ SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ -- struct_sigaction offsets
+
+ sa_handler_pos : constant := 0;
+ sa_mask_pos : constant := Standard'Address_Size / 8;
+ sa_flags_pos : constant := 128 + sa_mask_pos;
+
+ SA_SIGINFO : constant := 16#04#;
+ SA_ONSTACK : constant := 16#08000000#;
+
+end System.Linux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . L I N U X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2011-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Body used on targets where the operating system supports setting task
+-- affinities.
+
+with System.Tasking.Initialization;
+with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
+
+with Ada.Unchecked_Conversion;
+
+package body System.Multiprocessors.Dispatching_Domains is
+
+ package ST renames System.Tasking;
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ function Convert_Ids is new
+ Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, ST.Task_Id);
+
+ procedure Unchecked_Set_Affinity
+ (Domain : ST.Dispatching_Domain_Access;
+ CPU : CPU_Range;
+ T : ST.Task_Id);
+ -- Internal procedure to move a task to a target domain and CPU. No checks
+ -- are performed about the validity of the domain and the CPU because they
+ -- are done by the callers of this procedure (either Assign_Task or
+ -- Set_CPU).
+
+ procedure Freeze_Dispatching_Domains;
+ pragma Export
+ (Ada, Freeze_Dispatching_Domains, "__gnat_freeze_dispatching_domains");
+ -- Signal the time when no new dispatching domains can be created. It
+ -- should be called before the environment task calls the main procedure
+ -- (and after the elaboration code), so the binder-generated file needs to
+ -- import and call this procedure.
+
+ -----------------
+ -- Assign_Task --
+ -----------------
+
+ procedure Assign_Task
+ (Domain : in out Dispatching_Domain;
+ CPU : CPU_Range := Not_A_Specific_CPU;
+ T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task)
+ is
+ Target : constant ST.Task_Id := Convert_Ids (T);
+
+ begin
+ -- The exception Dispatching_Domain_Error is propagated if T is already
+ -- assigned to a Dispatching_Domain other than
+ -- System_Dispatching_Domain, or if CPU is not one of the processors of
+ -- Domain (and is not Not_A_Specific_CPU).
+
+ if Dispatching_Domain (Target.Common.Domain) /= System_Dispatching_Domain
+ then
+ raise Dispatching_Domain_Error with
+ "task already in user-defined dispatching domain";
+
+ elsif CPU /= Not_A_Specific_CPU and then CPU not in Domain'Range then
+ raise Dispatching_Domain_Error with
+ "processor does not belong to dispatching domain";
+ end if;
+
+ -- Assigning a task to System_Dispatching_Domain that is already
+ -- assigned to that domain has no effect.
+
+ if Domain = System_Dispatching_Domain then
+ return;
+
+ else
+ -- Set the task affinity once we know it is possible
+
+ Unchecked_Set_Affinity
+ (ST.Dispatching_Domain_Access (Domain), CPU, Target);
+ end if;
+ end Assign_Task;
+
+ ------------
+ -- Create --
+ ------------
+
+ function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain is
+ begin
+ return Create ((First .. Last => True));
+ end Create;
+
+ function Create (Set : CPU_Set) return Dispatching_Domain is
+ ST_DD : aliased constant ST.Dispatching_Domain :=
+ ST.Dispatching_Domain (Set);
+ First : constant CPU := Get_First_CPU (ST_DD'Unrestricted_Access);
+ Last : constant CPU_Range := Get_Last_CPU (ST_DD'Unrestricted_Access);
+ subtype Rng is CPU_Range range First .. Last;
+
+ use type ST.Dispatching_Domain;
+ use type ST.Dispatching_Domain_Access;
+ use type ST.Task_Id;
+
+ T : ST.Task_Id;
+
+ New_System_Domain : ST.Dispatching_Domain := ST.System_Domain.all;
+
+ ST_DD_Slice : constant ST.Dispatching_Domain := ST_DD (Rng);
+
+ begin
+ -- The set of processors for creating a dispatching domain must
+ -- comply with the following restrictions:
+ -- - Not exceeding the range of available processors.
+ -- - CPUs from the System_Dispatching_Domain.
+ -- - The calling task must be the environment task.
+ -- - The call to Create must take place before the call to the main
+ -- subprogram.
+ -- - Set does not contain a processor with a task assigned to it.
+ -- - The allocation cannot leave System_Dispatching_Domain empty.
+
+ -- Note that a previous version of the language forbade empty domains.
+
+ if Rng'Last > Number_Of_CPUs then
+ raise Dispatching_Domain_Error with
+ "CPU not supported by the target";
+ end if;
+
+ declare
+ System_Domain_Slice : constant ST.Dispatching_Domain :=
+ ST.System_Domain (Rng);
+ Actual : constant ST.Dispatching_Domain :=
+ ST_DD_Slice and not System_Domain_Slice;
+ Expected : constant ST.Dispatching_Domain := (Rng => False);
+ begin
+ if Actual /= Expected then
+ raise Dispatching_Domain_Error with
+ "CPU not currently in System_Dispatching_Domain";
+ end if;
+ end;
+
+ if Self /= Environment_Task then
+ raise Dispatching_Domain_Error with
+ "only the environment task can create dispatching domains";
+ end if;
+
+ if ST.Dispatching_Domains_Frozen then
+ raise Dispatching_Domain_Error with
+ "cannot create dispatching domain after call to main procedure";
+ end if;
+
+ for Proc in Rng loop
+ if ST_DD (Proc) and then
+ ST.Dispatching_Domain_Tasks (Proc) /= 0
+ then
+ raise Dispatching_Domain_Error with "CPU has tasks assigned";
+ end if;
+ end loop;
+
+ New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD_Slice;
+
+ if New_System_Domain = (New_System_Domain'Range => False) then
+ raise Dispatching_Domain_Error with
+ "would leave System_Dispatching_Domain empty";
+ end if;
+
+ return Result : constant Dispatching_Domain :=
+ new ST.Dispatching_Domain'(ST_DD_Slice)
+ do
+ -- At this point we need to fix the processors belonging to the
+ -- system domain, and change the affinity of every task that has
+ -- been created and assigned to the system domain.
+
+ ST.Initialization.Defer_Abort (Self);
+
+ Lock_RTS;
+
+ ST.System_Domain (Rng) := New_System_Domain (Rng);
+ pragma Assert (ST.System_Domain.all = New_System_Domain);
+
+ -- Iterate the list of tasks belonging to the default system
+ -- dispatching domain and set the appropriate affinity.
+
+ T := ST.All_Tasks_List;
+
+ while T /= null loop
+ if T.Common.Domain = ST.System_Domain then
+ Set_Task_Affinity (T);
+ end if;
+
+ T := T.Common.All_Tasks_Link;
+ end loop;
+
+ Unlock_RTS;
+
+ ST.Initialization.Undefer_Abort (Self);
+ end return;
+ end Create;
+
+ -----------------------------
+ -- Delay_Until_And_Set_CPU --
+ -----------------------------
+
+ procedure Delay_Until_And_Set_CPU
+ (Delay_Until_Time : Ada.Real_Time.Time;
+ CPU : CPU_Range)
+ is
+ begin
+ -- Not supported atomically by the underlying operating systems.
+ -- Operating systems use to migrate the task immediately after the call
+ -- to set the affinity.
+
+ delay until Delay_Until_Time;
+ Set_CPU (CPU);
+ end Delay_Until_And_Set_CPU;
+
+ --------------------------------
+ -- Freeze_Dispatching_Domains --
+ --------------------------------
+
+ procedure Freeze_Dispatching_Domains is
+ begin
+ -- Signal the end of the elaboration code
+
+ ST.Dispatching_Domains_Frozen := True;
+ end Freeze_Dispatching_Domains;
+
+ -------------
+ -- Get_CPU --
+ -------------
+
+ function Get_CPU
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task) return CPU_Range
+ is
+ begin
+ return Convert_Ids (T).Common.Base_CPU;
+ end Get_CPU;
+
+ -----------------
+ -- Get_CPU_Set --
+ -----------------
+
+ function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is
+ begin
+ return CPU_Set (Domain.all);
+ end Get_CPU_Set;
+
+ ----------------------------
+ -- Get_Dispatching_Domain --
+ ----------------------------
+
+ function Get_Dispatching_Domain
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task) return Dispatching_Domain
+ is
+ begin
+ return Result : constant Dispatching_Domain :=
+ Dispatching_Domain (Convert_Ids (T).Common.Domain)
+ do
+ pragma Assert (Result /= null);
+ end return;
+ end Get_Dispatching_Domain;
+
+ -------------------
+ -- Get_First_CPU --
+ -------------------
+
+ function Get_First_CPU (Domain : Dispatching_Domain) return CPU is
+ begin
+ for Proc in Domain'Range loop
+ if Domain (Proc) then
+ return Proc;
+ end if;
+ end loop;
+
+ return CPU'First;
+ end Get_First_CPU;
+
+ ------------------
+ -- Get_Last_CPU --
+ ------------------
+
+ function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is
+ begin
+ for Proc in reverse Domain'Range loop
+ if Domain (Proc) then
+ return Proc;
+ end if;
+ end loop;
+
+ return CPU_Range'First;
+ end Get_Last_CPU;
+
+ -------------
+ -- Set_CPU --
+ -------------
+
+ procedure Set_CPU
+ (CPU : CPU_Range;
+ T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task)
+ is
+ Target : constant ST.Task_Id := Convert_Ids (T);
+
+ begin
+ -- The exception Dispatching_Domain_Error is propagated if CPU is not
+ -- one of the processors of the Dispatching_Domain on which T is
+ -- assigned (and is not Not_A_Specific_CPU).
+
+ if CPU /= Not_A_Specific_CPU and then
+ (CPU not in Target.Common.Domain'Range or else
+ not Target.Common.Domain (CPU))
+ then
+ raise Dispatching_Domain_Error with
+ "processor does not belong to the task's dispatching domain";
+ end if;
+
+ Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target);
+ end Set_CPU;
+
+ ----------------------------
+ -- Unchecked_Set_Affinity --
+ ----------------------------
+
+ procedure Unchecked_Set_Affinity
+ (Domain : ST.Dispatching_Domain_Access;
+ CPU : CPU_Range;
+ T : ST.Task_Id)
+ is
+ Source_CPU : constant CPU_Range := T.Common.Base_CPU;
+
+ use type ST.Dispatching_Domain_Access;
+
+ begin
+ Write_Lock (T);
+
+ -- Move to the new domain
+
+ T.Common.Domain := Domain;
+
+ -- Attach the CPU to the task
+
+ T.Common.Base_CPU := CPU;
+
+ -- Change the number of tasks attached to a given task in the system
+ -- domain if needed.
+
+ if not ST.Dispatching_Domains_Frozen
+ and then (Domain = null or else Domain = ST.System_Domain)
+ then
+ -- Reduce the number of tasks attached to the CPU from which this
+ -- task is being moved, if needed.
+
+ if Source_CPU /= Not_A_Specific_CPU then
+ ST.Dispatching_Domain_Tasks (Source_CPU) :=
+ ST.Dispatching_Domain_Tasks (Source_CPU) - 1;
+ end if;
+
+ -- Increase the number of tasks attached to the CPU to which this
+ -- task is being moved, if needed.
+
+ if CPU /= Not_A_Specific_CPU then
+ ST.Dispatching_Domain_Tasks (CPU) :=
+ ST.Dispatching_Domain_Tasks (CPU) + 1;
+ end if;
+ end if;
+
+ -- Change the actual affinity calling the operating system level
+
+ Set_Task_Affinity (T);
+
+ Unlock (T);
+ end Unchecked_Set_Affinity;
+
+end System.Multiprocessors.Dispatching_Domains;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2011-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Body used on 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1997-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a AIX (Native) version of this package
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+package body System.OS_Interface is
+
+ use Interfaces.C;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ begin
+ -- For the case SCHED_OTHER the only valid priority across all supported
+ -- versions of AIX is 1 (note that the scheduling policy can be set
+ -- with the pragma Task_Dispatching_Policy or setting the time slice
+ -- value). Otherwise, for SCHED_RR and SCHED_FIFO, the system defines
+ -- priorities in the range 1 .. 127. This means that we must map
+ -- System.Any_Priority in the range 0 .. 126 to 1 .. 127.
+
+ if Dispatching_Policy = ' ' and then Time_Slice_Val < 0 then
+ return 1;
+ else
+ return Interfaces.C.int (Prio) + 1;
+ end if;
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F is negative due to a round-up, adjust for positive F value
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ -----------------
+ -- sched_yield --
+ -----------------
+
+ -- AIX Thread does not have sched_yield;
+
+ function sched_yield return int is
+ procedure pthread_yield;
+ pragma Import (C, pthread_yield, "sched_yield");
+ begin
+ pthread_yield;
+ return 0;
+ end sched_yield;
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ --------------------------
+ -- PTHREAD_PRIO_INHERIT --
+ --------------------------
+
+ AIX_Version : Integer := 0;
+ -- AIX version in the form xy for AIX version x.y (0 means not set)
+
+ SYS_NMLN : constant := 32;
+ -- AIX system constant used to define utsname, see sys/utsname.h
+
+ subtype String_NMLN is String (1 .. SYS_NMLN);
+
+ type utsname is record
+ sysname : String_NMLN;
+ nodename : String_NMLN;
+ release : String_NMLN;
+ version : String_NMLN;
+ machine : String_NMLN;
+ procserial : String_NMLN;
+ end record;
+ pragma Convention (C, utsname);
+
+ procedure uname (name : out utsname);
+ pragma Import (C, uname);
+
+ function PTHREAD_PRIO_INHERIT return int is
+ name : utsname;
+
+ function Val (C : Character) return Integer;
+ -- Transform a numeric character ('0' .. '9') to an integer
+
+ ---------
+ -- Val --
+ ---------
+
+ function Val (C : Character) return Integer is
+ begin
+ return Character'Pos (C) - Character'Pos ('0');
+ end Val;
+
+ -- Start of processing for PTHREAD_PRIO_INHERIT
+
+ begin
+ if AIX_Version = 0 then
+
+ -- Set AIX_Version
+
+ uname (name);
+ AIX_Version := Val (name.version (1)) * 10 + Val (name.release (1));
+ end if;
+
+ if AIX_Version < 53 then
+
+ -- Under AIX < 5.3, PTHREAD_PRIO_INHERIT is defined as 0 in pthread.h
+
+ return 0;
+
+ else
+ -- Under AIX >= 5.3, PTHREAD_PRIO_INHERIT is defined as 3
+
+ return 3;
+ end if;
+ end PTHREAD_PRIO_INHERIT;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a AIX (Native THREADS) version of this package
+
+-- This package encapsulates all direct interfaces to OS services that are
+-- needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+with Interfaces.C.Extensions;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-pthread");
+ -- This implies -lpthreads + other things depending on the GCC
+ -- configuration, such as the selection of a proper libgcc variant
+ -- for table-based exception handling when it is available.
+
+ pragma Linker_Options ("-lc_r");
+
+ subtype int is Interfaces.C.int;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype long_long is Interfaces.C.Extensions.long_long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIMEDOUT : constant := 78;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 63;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGPWR : constant := 29; -- power-fail restart
+ SIGWINCH : constant := 28; -- window size change
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGPOLL : constant := 23; -- pollable event occurred
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGVTALRM : constant := 34; -- virtual timer expired
+ SIGPROF : constant := 32; -- profiling timer expired
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGWAITING : constant := 39; -- m:n scheduling
+
+ -- The following signals are AIX specific
+
+ SIGMSG : constant := 27; -- input data is in the ring buffer
+ SIGDANGER : constant := 33; -- system crash imminent
+ SIGMIGRATE : constant := 35; -- migrate process
+ SIGPRE : constant := 36; -- programming exception
+ SIGVIRT : constant := 37; -- AIX virtual time alarm
+ SIGALRM1 : constant := 38; -- m:n condition variables
+ SIGCPUFAIL : constant := 59; -- Predictive De-configuration of Processors
+ SIGKAP : constant := 60; -- keep alive poll from native keyboard
+ SIGGRANT : constant := SIGKAP; -- monitor mode granted
+ SIGRETRACT : constant := 61; -- monitor mode should be relinquished
+ SIGSOUND : constant := 62; -- sound control has completed
+ SIGSAK : constant := 63; -- secure attention key
+
+ SIGADAABORT : constant := SIGEMT;
+ -- Note: on other targets, we usually use SIGABRT, but on AIX, it appears
+ -- that SIGABRT can't be used in sigwait(), so we use SIGEMT.
+ -- SIGEMT is "Emulator Trap Instruction" from the PDP-11, and does not
+ -- have a standardized usage.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF);
+ Reserved : constant Signal_Set :=
+ (SIGABRT, SIGKILL, SIGSTOP, SIGALRM1, SIGWAITING, SIGCPUFAIL);
+
+ type sigset_t is private;
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_SIGINFO : constant := 16#0100#;
+ SA_ONSTACK : constant := 16#0001#;
+
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ Time_Slice_Supported : constant Boolean := True;
+ -- Indicates whether time slicing is supported
+
+ type timespec is private;
+
+ type clockid_t is new long_long;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ type struct_timezone is record
+ tz_minuteswest : int;
+ tz_dsttime : int;
+ end record;
+ pragma Convention (C, struct_timezone);
+ type struct_timezone_ptr is access all struct_timezone;
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+ SCHED_OTHER : constant := 0;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ pragma Import (C, lwp_self, "thread_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ type pthread_t is private;
+ subtype Thread_Id is pthread_t;
+
+ type pthread_mutex_t is limited private;
+ type pthread_cond_t is limited private;
+ type pthread_attr_t is limited private;
+ type pthread_mutexattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ PTHREAD_CREATE_DETACHED : constant := 1;
+
+ PTHREAD_SCOPE_PROCESS : constant := 1;
+ PTHREAD_SCOPE_SYSTEM : constant := 0;
+
+ -- Read/Write lock not supported on AIX. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ subtype pthread_rwlock_t is pthread_mutex_t;
+ subtype pthread_rwlockattr_t is pthread_mutexattr_t;
+
+ -----------
+ -- Stack --
+ -----------
+
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- Returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ function Get_Page_Size return int;
+ pragma Import (C, Get_Page_Size, "getpagesize");
+ -- Returns the size of a page
+
+ PROT_NONE : constant := 0;
+ PROT_READ : constant := 1;
+ PROT_WRITE : constant := 2;
+ PROT_EXEC : constant := 4;
+ PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+ PROT_ON : constant := PROT_READ;
+ PROT_OFF : constant := PROT_ALL;
+
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ pragma Import (C, mprotect);
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ -- Though not documented, pthread_init *must* be called before any other
+ -- pthread call.
+
+ procedure pthread_init;
+ pragma Import (C, pthread_init, "pthread_init");
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "sigthreadmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_PROTECT : constant := 2;
+
+ function PTHREAD_PRIO_INHERIT return int;
+ -- Return value of C macro PTHREAD_PRIO_INHERIT. This function is needed
+ -- since the value is different between AIX versions.
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import (C, pthread_mutexattr_setprotocol);
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import (C, pthread_mutexattr_setprioceiling);
+
+ type Array_5_Int is array (0 .. 5) of int;
+ type struct_sched_param is record
+ sched_priority : int;
+ sched_policy : int;
+ sched_reserved : Array_5_Int;
+ end record;
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
+
+ function pthread_attr_setscope
+ (attr : access pthread_attr_t;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import (C, pthread_attr_setinheritsched);
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy);
+
+ function pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : int) return int;
+ pragma Import (C, pthread_attr_setschedparam);
+
+ function sched_yield return int;
+ -- AIX have a nonstandard sched_yield
+
+ --------------------------
+ -- P1003.1c Section 16 --
+ --------------------------
+
+ function pthread_attr_init (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "pthread_attr_init");
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Import (C, pthread_attr_setdetachstate);
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize);
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address)
+ return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+ type sigset_t is record
+ losigs : unsigned_long;
+ hisigs : unsigned_long;
+ end record;
+ pragma Convention (C_Pass_By_Copy, sigset_t);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type pthread_attr_t is new System.Address;
+ pragma Convention (C, pthread_attr_t);
+ -- typedef struct __pt_attr *pthread_attr_t;
+
+ type pthread_condattr_t is new System.Address;
+ pragma Convention (C, pthread_condattr_t);
+ -- typedef struct __pt_attr *pthread_condattr_t;
+
+ type pthread_mutexattr_t is new System.Address;
+ pragma Convention (C, pthread_mutexattr_t);
+ -- typedef struct __pt_attr *pthread_mutexattr_t;
+
+ type pthread_t is new System.Address;
+ pragma Convention (C, pthread_t);
+ -- typedef void *pthread_t;
+
+ type ptq_queue;
+ type ptq_queue_ptr is access all ptq_queue;
+
+ type ptq_queue is record
+ ptq_next : ptq_queue_ptr;
+ ptq_prev : ptq_queue_ptr;
+ end record;
+
+ type Array_3_Int is array (0 .. 3) of int;
+ type pthread_mutex_t is record
+ link : ptq_queue;
+ ptmtx_lock : int;
+ ptmtx_flags : long;
+ protocol : int;
+ prioceiling : int;
+ ptmtx_owner : pthread_t;
+ mtx_id : int;
+ attr : pthread_attr_t;
+ mtx_kind : int;
+ lock_cpt : int;
+ reserved : Array_3_Int;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+ type pthread_mutex_t_ptr is access pthread_mutex_t;
+
+ type pthread_cond_t is record
+ link : ptq_queue;
+ ptcv_lock : int;
+ ptcv_flags : long;
+ ptcv_waiters : ptq_queue;
+ cv_id : int;
+ attr : pthread_attr_t;
+ mutex : pthread_mutex_t_ptr;
+ cptwait : int;
+ reserved : int;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1995-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is an Android version of this package.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+with Interfaces.C; use Interfaces.C;
+
+package body System.OS_Interface is
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1995-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is an Android version of this package which is based on the
+-- GNU/Linux version
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+with Interfaces.C;
+with System.Linux;
+with System.OS_Constants;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ subtype int is Interfaces.C.int;
+ subtype char is Interfaces.C.char;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := System.Linux.EAGAIN;
+ EINTR : constant := System.Linux.EINTR;
+ EINVAL : constant := System.Linux.EINVAL;
+ ENOMEM : constant := System.Linux.ENOMEM;
+ EPERM : constant := System.Linux.EPERM;
+ ETIMEDOUT : constant := System.Linux.ETIMEDOUT;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := System.Linux.SIGHUP;
+ SIGINT : constant := System.Linux.SIGINT;
+ SIGQUIT : constant := System.Linux.SIGQUIT;
+ SIGILL : constant := System.Linux.SIGILL;
+ SIGTRAP : constant := System.Linux.SIGTRAP;
+ SIGIOT : constant := System.Linux.SIGIOT;
+ SIGABRT : constant := System.Linux.SIGABRT;
+ SIGFPE : constant := System.Linux.SIGFPE;
+ SIGKILL : constant := System.Linux.SIGKILL;
+ SIGBUS : constant := System.Linux.SIGBUS;
+ SIGSEGV : constant := System.Linux.SIGSEGV;
+ SIGPIPE : constant := System.Linux.SIGPIPE;
+ SIGALRM : constant := System.Linux.SIGALRM;
+ SIGTERM : constant := System.Linux.SIGTERM;
+ SIGUSR1 : constant := System.Linux.SIGUSR1;
+ SIGUSR2 : constant := System.Linux.SIGUSR2;
+ SIGCLD : constant := System.Linux.SIGCLD;
+ SIGCHLD : constant := System.Linux.SIGCHLD;
+ SIGPWR : constant := System.Linux.SIGPWR;
+ SIGWINCH : constant := System.Linux.SIGWINCH;
+ SIGURG : constant := System.Linux.SIGURG;
+ SIGPOLL : constant := System.Linux.SIGPOLL;
+ SIGIO : constant := System.Linux.SIGIO;
+ SIGLOST : constant := System.Linux.SIGLOST;
+ SIGSTOP : constant := System.Linux.SIGSTOP;
+ SIGTSTP : constant := System.Linux.SIGTSTP;
+ SIGCONT : constant := System.Linux.SIGCONT;
+ SIGTTIN : constant := System.Linux.SIGTTIN;
+ SIGTTOU : constant := System.Linux.SIGTTOU;
+ SIGVTALRM : constant := System.Linux.SIGVTALRM;
+ SIGPROF : constant := System.Linux.SIGPROF;
+ SIGXCPU : constant := System.Linux.SIGXCPU;
+ SIGXFSZ : constant := System.Linux.SIGXFSZ;
+ SIGUNUSED : constant := System.Linux.SIGUNUSED;
+ SIGSTKFLT : constant := System.Linux.SIGSTKFLT;
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this to use another signal for task abort. SIGTERM might be a
+ -- good one.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (
+ SIGTRAP,
+ -- To enable debugging on multithreaded applications, mark SIGTRAP to
+ -- be kept unmasked.
+
+ SIGBUS,
+
+ SIGTTIN, SIGTTOU, SIGTSTP,
+ -- Keep these three signals unmasked so that background processes and IO
+ -- behaves as normal "C" applications
+
+ SIGPROF,
+ -- To avoid confusing the profiler
+
+ SIGKILL, SIGSTOP);
+ -- These two signals actually can't be masked (POSIX won't allow it)
+
+ Reserved : constant Signal_Set := (SIGVTALRM, SIGUNUSED);
+ -- Not clear why these two signals are reserved. Perhaps they are not
+ -- supported by this version of GNU/Linux ???
+
+ type sigset_t is private;
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "_sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "_sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "_sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "_sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "_sigemptyset");
+
+ type union_type_3 is new String (1 .. 116);
+ type siginfo_t is record
+ si_signo : int;
+ si_code : int;
+ si_errno : int;
+ X_data : union_type_3;
+ end record;
+ pragma Convention (C, siginfo_t);
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : Interfaces.C.unsigned_long;
+ sa_restorer : System.Address;
+ end record;
+ pragma Convention (C, struct_sigaction);
+
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_SIGINFO : constant := System.Linux.SA_SIGINFO;
+ SA_ONSTACK : constant := System.Linux.SA_ONSTACK;
+ SA_NODEFER : constant := System.Linux.SA_NODEFER;
+ SA_RESTART : constant := System.Linux.SA_RESTART;
+
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ Time_Slice_Supported : constant Boolean := True;
+ -- Indicates whether time slicing is supported
+
+ type timespec is private;
+
+ type clockid_t is new int;
+
+ function clock_gettime
+ (clock_id : clockid_t; tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ function sysconf (name : int) return long;
+ pragma Import (C, sysconf);
+
+ SC_CLK_TCK : constant := 2;
+ SC_NPROCESSORS_ONLN : constant := 84;
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_OTHER : constant := 0;
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority)
+ return Interfaces.C.int is (Interfaces.C.int (Prio));
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ type pthread_t is new unsigned_long;
+ subtype Thread_Id is pthread_t;
+
+ function To_pthread_t is
+ new Ada.Unchecked_Conversion (unsigned_long, pthread_t);
+
+ type pthread_mutex_t is limited private;
+ type pthread_cond_t is limited private;
+ type pthread_attr_t is limited private;
+ type pthread_mutexattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ PTHREAD_CREATE_DETACHED : constant := 1;
+
+ PTHREAD_SCOPE_PROCESS : constant := 1;
+ PTHREAD_SCOPE_SYSTEM : constant := 0;
+
+ -- Read/Write lock not supported on Android.
+
+ subtype pthread_rwlock_t is pthread_mutex_t;
+ subtype pthread_rwlockattr_t is pthread_mutexattr_t;
+
+ -----------
+ -- Stack --
+ -----------
+
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_flags : int;
+ ss_size : size_t;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
+ -- The alternate signal stack for stack overflows
+
+ Alternate_Stack_Size : constant := 16 * 1024;
+ -- This must be in keeping with init.c:__gnat_alternate_stack
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target
+
+ function Get_Stack_Base (thread : pthread_t)
+ return Address is (Null_Address);
+ -- This is a dummy procedure to share some GNULLI files
+
+ function Get_Page_Size return int;
+ pragma Import (C, Get_Page_Size, "_getpagesize");
+ -- Returns the size of a page
+
+ PROT_NONE : constant := 0;
+ PROT_READ : constant := 1;
+ PROT_WRITE : constant := 2;
+ PROT_EXEC : constant := 4;
+ PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+ PROT_ON : constant := PROT_READ;
+ PROT_OFF : constant := PROT_ALL;
+
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ pragma Import (C, mprotect);
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init is null;
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+ -- pthread_sigmask maybe be broken due to mismatch between sigset_t and
+ -- kernel_sigset_t, substitute sigprocmask temporarily. ???
+ -- pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_PROTECT : constant := 0;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int is (0);
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int is (0);
+
+ type struct_sched_param is record
+ sched_priority : int; -- scheduling priority
+ end record;
+ pragma Convention (C, struct_sched_param);
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
+
+ function pthread_attr_setscope
+ (attr : access pthread_attr_t;
+ scope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import
+ (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy");
+
+ function sched_yield return int;
+ pragma Import (C, sched_yield, "sched_yield");
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "pthread_attr_init");
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Import
+ (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ function lwp_self return System.Address;
+ pragma Import (C, lwp_self, "__gnat_lwp_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ CPU_SETSIZE : constant := 1_024;
+ -- Size of the cpu_set_t mask on most linux systems (SUSE 11 uses 4_096).
+ -- This is kept for backward compatibility (System.Task_Info uses it), but
+ -- the run-time library does no longer rely on static masks, using
+ -- dynamically allocated masks instead.
+
+ type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
+ for bit_field'Size use CPU_SETSIZE;
+ pragma Pack (bit_field);
+ pragma Convention (C, bit_field);
+
+ type cpu_set_t is record
+ bits : bit_field;
+ end record;
+ pragma Convention (C, cpu_set_t);
+
+ type cpu_set_t_ptr is access all cpu_set_t;
+ -- In the run-time library we use this pointer because the size of type
+ -- cpu_set_t varies depending on the glibc version. Hence, objects of type
+ -- cpu_set_t are allocated dynamically using the number of processors
+ -- available in the target machine (value obtained at execution time).
+
+ function CPU_ALLOC (count : size_t) return cpu_set_t_ptr;
+ pragma Import (C, CPU_ALLOC, "__gnat_cpu_alloc");
+ -- Wrapper around the CPU_ALLOC C macro
+
+ function CPU_ALLOC_SIZE (count : size_t) return size_t;
+ pragma Import (C, CPU_ALLOC_SIZE, "__gnat_cpu_alloc_size");
+ -- Wrapper around the CPU_ALLOC_SIZE C macro
+
+ procedure CPU_FREE (cpuset : cpu_set_t_ptr);
+ pragma Import (C, CPU_FREE, "__gnat_cpu_free");
+ -- Wrapper around the CPU_FREE C macro
+
+ procedure CPU_ZERO (count : size_t; cpuset : cpu_set_t_ptr);
+ pragma Import (C, CPU_ZERO, "__gnat_cpu_zero");
+ -- Wrapper around the CPU_ZERO_S C macro
+
+ procedure CPU_SET (cpu : int; count : size_t; cpuset : cpu_set_t_ptr);
+ pragma Import (C, CPU_SET, "__gnat_cpu_set");
+ -- Wrapper around the CPU_SET_S C macro
+
+ function pthread_setaffinity_np
+ (thread : pthread_t;
+ cpusetsize : size_t;
+ cpuset : cpu_set_t_ptr) return int;
+ pragma Import (C, pthread_setaffinity_np, "pthread_setaffinity_np");
+ pragma Weak_External (pthread_setaffinity_np);
+ -- Use a weak symbol because this function may be available or not,
+ -- depending on the version of the system.
+
+ function pthread_attr_setaffinity_np
+ (attr : access pthread_attr_t;
+ cpusetsize : size_t;
+ cpuset : cpu_set_t_ptr) return int;
+ pragma Import (C, pthread_attr_setaffinity_np,
+ "pthread_attr_setaffinity_np");
+ pragma Weak_External (pthread_attr_setaffinity_np);
+ -- Use a weak symbol because this function may be available or not,
+ -- depending on the version of the system.
+
+private
+
+ type sigset_t is new Interfaces.C.unsigned_long;
+ pragma Convention (C, sigset_t);
+ for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+ pragma Warnings (Off);
+ for struct_sigaction use record
+ sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1;
+ sa_mask at Linux.sa_mask_pos range 0 .. sigset_t'Size - 1;
+ sa_flags at Linux.sa_flags_pos
+ range 0 .. Interfaces.C.unsigned_long'Size - 1;
+ end record;
+ -- We intentionally leave sa_restorer unspecified and let the compiler
+ -- append it after the last field, so disable corresponding warning.
+ pragma Warnings (On);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type unsigned_long_long_t is mod 2 ** 64;
+ -- Local type only used to get the alignment of this type below
+
+ subtype char_array is Interfaces.C.char_array;
+
+ type pthread_attr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_ATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_attr_t);
+ for pthread_attr_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+ type pthread_condattr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_CONDATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+ for pthread_condattr_t'Alignment use Interfaces.C.int'Alignment;
+
+ type pthread_mutexattr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_MUTEXATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+ for pthread_mutexattr_t'Alignment use Interfaces.C.int'Alignment;
+
+ type pthread_mutex_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE);
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+ for pthread_mutex_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+ type pthread_cond_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_COND_SIZE);
+ end record;
+ pragma Convention (C, pthread_cond_t);
+ for pthread_cond_t'Alignment use unsigned_long_long_t'Alignment;
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1999-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Darwin Threads version of this package
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+with Interfaces.C.Extensions;
+
+package body System.OS_Interface is
+ use Interfaces.C;
+ use Interfaces.C.Extensions;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ -------------------
+ -- clock_gettime --
+ -------------------
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int
+ is
+ pragma Unreferenced (clock_id);
+
+ -- Darwin Threads don't have clock_gettime, so use gettimeofday
+
+ use Interfaces;
+
+ type timeval is array (1 .. 3) of C.long;
+ -- The timeval array is sized to contain long_long sec and long usec.
+ -- If long_long'Size = long'Size then it will be overly large but that
+ -- won't effect the implementation since it's not accessed directly.
+
+ procedure timeval_to_duration
+ (T : not null access timeval;
+ sec : not null access C.Extensions.long_long;
+ usec : not null access C.long);
+ pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
+
+ Micro : constant := 10**6;
+ sec : aliased C.Extensions.long_long;
+ usec : aliased C.long;
+ TV : aliased timeval;
+ Result : int;
+
+ function gettimeofday
+ (Tv : access timeval;
+ Tz : System.Address := System.Null_Address) return int;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ begin
+ Result := gettimeofday (TV'Access, System.Null_Address);
+ pragma Assert (Result = 0);
+ timeval_to_duration (TV'Access, sec'Access, usec'Access);
+ tp.all := To_Timespec (Duration (sec) + Duration (usec) / Micro);
+ return Result;
+ end clock_gettime;
+
+ ------------------
+ -- clock_getres --
+ ------------------
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int
+ is
+ pragma Unreferenced (clock_id);
+
+ -- Darwin Threads don't have clock_getres.
+
+ Nano : constant := 10**9;
+ nsec : int := 0;
+ Result : int := -1;
+
+ function clock_get_res return int;
+ pragma Import (C, clock_get_res, "__gnat_clock_get_res");
+
+ begin
+ nsec := clock_get_res;
+ res.all := To_Timespec (Duration (0.0) + Duration (nsec) / Nano);
+
+ if nsec > 0 then
+ Result := 0;
+ end if;
+
+ return Result;
+ end clock_getres;
+
+ -----------------
+ -- sched_yield --
+ -----------------
+
+ function sched_yield return int is
+ procedure sched_yield_base (arg : System.Address);
+ pragma Import (C, sched_yield_base, "pthread_yield_np");
+
+ begin
+ sched_yield_base (System.Null_Address);
+ return 0;
+ end sched_yield;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ ----------------
+ -- Stack_Base --
+ ----------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Unreferenced (thread);
+ begin
+ return System.Null_Address;
+ end Get_Stack_Base;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is Darwin pthreads version of this package
+
+-- This package includes all direct interfaces to OS services that are needed
+-- by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Elaborate_Body. It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+with System.OS_Constants;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ subtype int is Interfaces.C.int;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EINTR : constant := 4;
+ ENOMEM : constant := 12;
+ EINVAL : constant := 22;
+ EAGAIN : constant := 35;
+ ETIMEDOUT : constant := 60;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGINFO : constant := 29; -- information request
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGTTIN, SIGTTOU, SIGSTOP, SIGTSTP);
+
+ Reserved : constant Signal_Set :=
+ (SIGKILL, SIGSTOP);
+
+ Exception_Signals : constant Signal_Set :=
+ (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
+ -- These signals (when runtime or system) will be caught and converted
+ -- into an Ada exception.
+
+ type sigset_t is private;
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ type siginfo_t is private;
+ type ucontext_t is private;
+
+ type Signal_Handler is access procedure
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access ucontext_t);
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ SA_SIGINFO : constant := 16#0040#;
+ SA_ONSTACK : constant := 16#0001#;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ Time_Slice_Supported : constant Boolean := True;
+ -- Indicates whether time slicing is supported
+
+ type timespec is private;
+
+ type clockid_t is new int;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_OTHER : constant := 1;
+ SCHED_RR : constant := 2;
+ SCHED_FIFO : constant := 4;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ pragma Import (C, lwp_self, "__gnat_lwp_self");
+ -- Return the mach thread bound to the current thread. The value is not
+ -- used by the run-time library but made available to debuggers.
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ type pthread_t is private;
+ subtype Thread_Id is pthread_t;
+
+ type pthread_mutex_t is limited private;
+ type pthread_cond_t is limited private;
+ type pthread_attr_t is limited private;
+ type pthread_mutexattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ type pthread_mutex_ptr is access all pthread_mutex_t;
+ type pthread_cond_ptr is access all pthread_cond_t;
+
+ PTHREAD_CREATE_DETACHED : constant := 2;
+
+ PTHREAD_SCOPE_PROCESS : constant := 2;
+ PTHREAD_SCOPE_SYSTEM : constant := 1;
+
+ -- Read/Write lock not supported on Darwin. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ subtype pthread_rwlock_t is pthread_mutex_t;
+ subtype pthread_rwlockattr_t is pthread_mutexattr_t;
+
+ -----------
+ -- Stack --
+ -----------
+
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
+ -- The alternate signal stack for stack overflows
+
+ Alternate_Stack_Size : constant := 32 * 1024;
+ -- This must be in keeping with init.c:__gnat_alternate_stack
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target. This
+ -- allows us to share s-osinte.adb between all the FSU run time. Note that
+ -- this value can only be true if pthread_t has a complete definition that
+ -- corresponds exactly to the C header files.
+
+ function Get_Stack_Base (thread : pthread_t) return System.Address;
+ pragma Inline (Get_Stack_Base);
+ -- returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ function Get_Page_Size return int;
+ pragma Import (C, Get_Page_Size, "getpagesize");
+ -- Returns the size of a page
+
+ PROT_NONE : constant := 0;
+ PROT_READ : constant := 1;
+ PROT_WRITE : constant := 2;
+ PROT_EXEC : constant := 4;
+ PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+
+ PROT_ON : constant := PROT_NONE;
+ PROT_OFF : constant := PROT_ALL;
+
+ function mprotect
+ (addr : System.Address;
+ len : size_t;
+ prot : int) return int;
+ pragma Import (C, mprotect);
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprioceiling,
+ "pthread_mutexattr_setprioceiling");
+
+ type padding is array (int range <>) of Interfaces.C.char;
+
+ type struct_sched_param is record
+ sched_priority : int; -- scheduling priority
+ opaque : padding (1 .. 4);
+ end record;
+ pragma Convention (C, struct_sched_param);
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
+
+ function pthread_attr_setscope
+ (attr : access pthread_attr_t;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import
+ (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched");
+
+ function sched_yield return int;
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "pthread_attr_init");
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Import
+ (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import
+ (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type sigset_t is new unsigned;
+
+ type int32_t is new int;
+
+ type pid_t is new int32_t;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ --
+ -- Darwin specific signal implementation
+ --
+ type Pad_Type is array (1 .. 7) of unsigned_long;
+ type siginfo_t is record
+ si_signo : int; -- signal number
+ si_errno : int; -- errno association
+ si_code : int; -- signal code
+ si_pid : int; -- sending process
+ si_uid : unsigned; -- sender's ruid
+ si_status : int; -- exit value
+ si_addr : System.Address; -- faulting instruction
+ si_value : System.Address; -- signal value
+ si_band : long; -- band event for SIGPOLL
+ pad : Pad_Type; -- RFU
+ end record;
+ pragma Convention (C, siginfo_t);
+
+ type mcontext_t is new System.Address;
+
+ type ucontext_t is record
+ uc_onstack : int;
+ uc_sigmask : sigset_t; -- Signal Mask Used By This Context
+ uc_stack : stack_t; -- Stack Used By This Context
+ uc_link : System.Address; -- Pointer To Resuming Context
+ uc_mcsize : size_t; -- Size of The Machine Context
+ uc_mcontext : mcontext_t; -- Machine Specific Context
+ end record;
+ pragma Convention (C, ucontext_t);
+
+ --
+ -- Darwin specific pthread implementation
+ --
+ type pthread_t is new System.Address;
+
+ type pthread_attr_t is record
+ sig : long;
+ opaque : padding (1 .. System.OS_Constants.PTHREAD_ATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_mutexattr_t is record
+ sig : long;
+ opaque : padding (1 .. System.OS_Constants.PTHREAD_MUTEXATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type pthread_mutex_t is record
+ sig : long;
+ opaque : padding (1 .. System.OS_Constants.PTHREAD_MUTEX_SIZE);
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_condattr_t is record
+ sig : long;
+ opaque : padding (1 .. System.OS_Constants.PTHREAD_CONDATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_cond_t is record
+ sig : long;
+ opaque : padding (1 .. System.OS_Constants.PTHREAD_COND_SIZE);
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_once_t is record
+ sig : long;
+ opaque : padding (1 .. System.OS_Constants.PTHREAD_ONCE_SIZE);
+ end record;
+ pragma Convention (C, pthread_once_t);
+
+ type pthread_key_t is new unsigned_long;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2015, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the DragonFly THREADS version of this package
+
+with Interfaces.C; use Interfaces.C;
+
+package body System.OS_Interface is
+
+ -----------
+ -- Errno --
+ -----------
+
+ function Errno return int is
+ type int_ptr is access all int;
+
+ function internal_errno return int_ptr;
+ pragma Import (C, internal_errno, "__get_errno");
+
+ begin
+ return (internal_errno.all);
+ end Errno;
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Unreferenced (thread);
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(ts_sec => S,
+ ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2015, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the DragonFly BSD PTHREADS version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-pthread");
+
+ subtype int is Interfaces.C.int;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function Errno return int;
+ pragma Inline (Errno);
+
+ EAGAIN : constant := 35;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIMEDOUT : constant := 60;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGINFO : constant := 29; -- information request (BSD)
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ -- Interrupts that must be unmasked at all times. DragonFlyBSD
+ -- pthreads will not allow an application to mask out any
+ -- interrupt needed by the threads library.
+ Unmasked : constant Signal_Set :=
+ (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP);
+
+ -- DragonFlyBSD will uses SIGPROF for timing. Do not allow a
+ -- handler to attach to this signal.
+ Reserved : constant Signal_Set := (0 .. 0 => SIGPROF);
+
+ type sigset_t is private;
+
+ function sigaddset
+ (set : access sigset_t;
+ sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset
+ (set : access sigset_t;
+ sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember
+ (set : access sigset_t;
+ sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ -- sigcontext is architecture dependent, so define it private
+ type struct_sigcontext is private;
+
+ type old_struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, old_struct_sigaction);
+
+ type new_struct_sigaction is record
+ sa_handler : System.Address;
+ sa_flags : int;
+ sa_mask : sigset_t;
+ end record;
+ pragma Convention (C, new_struct_sigaction);
+
+ subtype struct_sigaction is new_struct_sigaction;
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ SA_SIGINFO : constant := 16#0040#;
+ SA_ONSTACK : constant := 16#0001#;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ Time_Slice_Supported : constant Boolean := True;
+ -- Indicates whether time slicing is supported (i.e SCHED_RR is supported)
+
+ type timespec is private;
+
+ function nanosleep (rqtp, rmtp : access timespec) return int;
+ pragma Import (C, nanosleep, "nanosleep");
+
+ type clockid_t is new unsigned_long;
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec)
+ return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ type struct_timezone is record
+ tz_minuteswest : int;
+ tz_dsttime : int;
+ end record;
+ pragma Convention (C, struct_timezone);
+
+ procedure usleep (useconds : unsigned_long);
+ pragma Import (C, usleep, "usleep");
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_OTHER : constant := 2;
+ SCHED_RR : constant := 3;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ -- lwp_self does not exist on this thread library, revert to pthread_self
+ -- which is the closest approximation (with getpid). This function is
+ -- needed to share 7staprop.adb across POSIX-like targets.
+ pragma Import (C, lwp_self, "pthread_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ type pthread_t is private;
+ subtype Thread_Id is pthread_t;
+
+ type pthread_mutex_t is limited private;
+ type pthread_cond_t is limited private;
+ type pthread_attr_t is limited private;
+ type pthread_mutexattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ PTHREAD_CREATE_DETACHED : constant := 1;
+ PTHREAD_CREATE_JOINABLE : constant := 0;
+
+ PTHREAD_SCOPE_PROCESS : constant := 0;
+ PTHREAD_SCOPE_SYSTEM : constant := 2;
+
+ -- Read/Write lock not supported on DragonFly. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ subtype pthread_rwlock_t is pthread_mutex_t;
+ subtype pthread_rwlockattr_t is pthread_mutexattr_t;
+
+ -----------
+ -- Stack --
+ -----------
+
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target. This
+ -- allows us to share s-osinte.adb between all the FSU run time. Note that
+ -- this value can only be true if pthread_t has a complete definition that
+ -- corresponds exactly to the C header files.
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ function Get_Page_Size return int;
+ pragma Import (C, Get_Page_Size, "getpagesize");
+ -- Returns the size of a page
+
+ PROT_NONE : constant := 0;
+ PROT_READ : constant := 1;
+ PROT_WRITE : constant := 2;
+ PROT_EXEC : constant := 4;
+ PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+ PROT_ON : constant := PROT_NONE;
+ PROT_OFF : constant := PROT_ALL;
+
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ pragma Import (C, mprotect);
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ -- FSU_THREADS requires pthread_init, which is nonstandard and this should
+ -- be invoked during the elaboration of s-taprop.adb.
+
+ -- DragonFlyBSD does not require this so we provide an empty Ada body
+
+ procedure pthread_init;
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
+
+ function pthread_mutexattr_getprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : access int) return int;
+ pragma Import
+ (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol");
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprioceiling,
+ "pthread_mutexattr_setprioceiling");
+
+ function pthread_mutexattr_getprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : access int) return int;
+ pragma Import
+ (C, pthread_mutexattr_getprioceiling,
+ "pthread_mutexattr_getprioceiling");
+
+ type struct_sched_param is record
+ sched_priority : int;
+ end record;
+ pragma Convention (C, struct_sched_param);
+
+ function pthread_getschedparam
+ (thread : pthread_t;
+ policy : access int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_getschedparam, "pthread_getschedparam");
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
+
+ function pthread_attr_setscope
+ (attr : access pthread_attr_t;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_getscope
+ (attr : access pthread_attr_t;
+ contentionscope : access int) return int;
+ pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import
+ (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
+
+ function pthread_attr_getinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : access int) return int;
+ pragma Import
+ (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy,
+ "pthread_attr_setschedpolicy");
+
+ function pthread_attr_getschedpolicy
+ (attr : access pthread_attr_t;
+ policy : access int) return int;
+ pragma Import (C, pthread_attr_getschedpolicy,
+ "pthread_attr_getschedpolicy");
+
+ function pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : int) return int;
+ pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
+
+ function pthread_attr_getschedparam
+ (attr : access pthread_attr_t;
+ sched_param : access int) return int;
+ pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam");
+
+ function sched_yield return int;
+ pragma Import (C, sched_yield, "pthread_yield");
+
+ --------------------------
+ -- P1003.1c Section 16 --
+ --------------------------
+
+ function pthread_attr_init (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "pthread_attr_init");
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Import
+ (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
+
+ function pthread_attr_getdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : access int) return int;
+ pragma Import
+ (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate");
+
+ function pthread_attr_getstacksize
+ (attr : access pthread_attr_t;
+ stacksize : access size_t) return int;
+ pragma Import
+ (C, pthread_attr_getstacksize, "pthread_attr_getstacksize");
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import
+ (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ function pthread_detach (thread : pthread_t) return int;
+ pragma Import (C, pthread_detach, "pthread_detach");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ ------------------------------------
+ -- Non-portable Pthread Functions --
+ ------------------------------------
+
+ function pthread_set_name_np
+ (thread : pthread_t;
+ name : System.Address) return int;
+ pragma Import (C, pthread_set_name_np, "pthread_set_name_np");
+
+private
+
+ type sigset_t is array (1 .. 4) of unsigned;
+
+ -- In DragonFlyBSD the component sa_handler turns out to
+ -- be one a union type, and the selector is a macro:
+ -- #define sa_handler __sigaction_u._handler
+ -- #define sa_sigaction __sigaction_u._sigaction
+
+ -- Should we add a signal_context type here ???
+ -- How could it be done independent of the CPU architecture ???
+ -- sigcontext type is opaque, so it is architecturally neutral.
+ -- It is always passed as an access type, so define it as an empty record
+ -- since the contents are not used anywhere.
+
+ type struct_sigcontext is null record;
+ pragma Convention (C, struct_sigcontext);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ ts_sec : time_t;
+ ts_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type pthread_t is new System.Address;
+ type pthread_attr_t is new System.Address;
+ type pthread_mutex_t is new System.Address;
+ type pthread_mutexattr_t is new System.Address;
+ type pthread_cond_t is new System.Address;
+ type pthread_condattr_t is new System.Address;
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the no tasking version
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 2;
+ type Signal is new Integer range 0 .. Max_Interrupt;
+
+ type sigset_t is new Integer;
+ type Thread_Id is new Integer;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the FreeBSD THREADS version of this package
+
+with Interfaces.C; use Interfaces.C;
+
+package body System.OS_Interface is
+
+ -----------
+ -- Errno --
+ -----------
+
+ function Errno return int is
+ type int_ptr is access all int;
+
+ function internal_errno return int_ptr;
+ pragma Import (C, internal_errno, "__get_errno");
+
+ begin
+ return (internal_errno.all);
+ end Errno;
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Unreferenced (thread);
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(ts_sec => S,
+ ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the FreeBSD (POSIX Threads) version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-pthread");
+
+ subtype int is Interfaces.C.int;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function Errno return int;
+ pragma Inline (Errno);
+
+ EAGAIN : constant := 35;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIMEDOUT : constant := 60;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD)
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ -- Interrupts that must be unmasked at all times. FreeBSD
+ -- pthreads will not allow an application to mask out any
+ -- interrupt needed by the threads library.
+ Unmasked : constant Signal_Set :=
+ (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP);
+
+ -- FreeBSD will uses SIGPROF for timing. Do not allow a
+ -- handler to attach to this signal.
+ Reserved : constant Signal_Set := (0 .. 0 => SIGPROF);
+
+ type sigset_t is private;
+
+ function sigaddset
+ (set : access sigset_t;
+ sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset
+ (set : access sigset_t;
+ sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember
+ (set : access sigset_t;
+ sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ -- sigcontext is architecture dependent, so define it private
+ type struct_sigcontext is private;
+
+ type old_struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, old_struct_sigaction);
+
+ type new_struct_sigaction is record
+ sa_handler : System.Address;
+ sa_flags : int;
+ sa_mask : sigset_t;
+ end record;
+ pragma Convention (C, new_struct_sigaction);
+
+ subtype struct_sigaction is new_struct_sigaction;
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ SA_SIGINFO : constant := 16#0040#;
+ SA_ONSTACK : constant := 16#0001#;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ Time_Slice_Supported : constant Boolean := True;
+ -- Indicates whether time slicing is supported (i.e SCHED_RR is supported)
+
+ type timespec is private;
+
+ function nanosleep (rqtp, rmtp : access timespec) return int;
+ pragma Import (C, nanosleep, "nanosleep");
+
+ type clockid_t is new int;
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec)
+ return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ type struct_timezone is record
+ tz_minuteswest : int;
+ tz_dsttime : int;
+ end record;
+ pragma Convention (C, struct_timezone);
+
+ procedure usleep (useconds : unsigned_long);
+ pragma Import (C, usleep, "usleep");
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_OTHER : constant := 2;
+ SCHED_RR : constant := 3;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ Self_PID : constant pid_t;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ -- lwp_self does not exist on this thread library, revert to pthread_self
+ -- which is the closest approximation (with getpid). This function is
+ -- needed to share 7staprop.adb across POSIX-like targets.
+ pragma Import (C, lwp_self, "pthread_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ type pthread_t is private;
+ subtype Thread_Id is pthread_t;
+
+ type pthread_mutex_t is limited private;
+ type pthread_cond_t is limited private;
+ type pthread_attr_t is limited private;
+ type pthread_mutexattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ PTHREAD_CREATE_DETACHED : constant := 1;
+ PTHREAD_CREATE_JOINABLE : constant := 0;
+
+ PTHREAD_SCOPE_PROCESS : constant := 0;
+ PTHREAD_SCOPE_SYSTEM : constant := 2;
+
+ -- Read/Write lock not supported on freebsd. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ subtype pthread_rwlock_t is pthread_mutex_t;
+ subtype pthread_rwlockattr_t is pthread_mutexattr_t;
+
+ -----------
+ -- Stack --
+ -----------
+
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ function Get_Page_Size return int;
+ pragma Import (C, Get_Page_Size, "getpagesize");
+ -- Returns the size of a page
+
+ PROT_NONE : constant := 0;
+ PROT_READ : constant := 1;
+ PROT_WRITE : constant := 2;
+ PROT_EXEC : constant := 4;
+ PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+ PROT_ON : constant := PROT_NONE;
+ PROT_OFF : constant := PROT_ALL;
+
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ pragma Import (C, mprotect);
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ -- FSU_THREADS requires pthread_init, which is nonstandard and this should
+ -- be invoked during the elaboration of s-taprop.adb.
+
+ -- FreeBSD does not require this so we provide an empty Ada body
+
+ procedure pthread_init;
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
+
+ function pthread_mutexattr_getprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : access int) return int;
+ pragma Import
+ (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol");
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprioceiling,
+ "pthread_mutexattr_setprioceiling");
+
+ function pthread_mutexattr_getprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : access int) return int;
+ pragma Import
+ (C, pthread_mutexattr_getprioceiling,
+ "pthread_mutexattr_getprioceiling");
+
+ type struct_sched_param is record
+ sched_priority : int;
+ end record;
+ pragma Convention (C, struct_sched_param);
+
+ function pthread_getschedparam
+ (thread : pthread_t;
+ policy : access int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_getschedparam, "pthread_getschedparam");
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
+
+ function pthread_attr_setscope
+ (attr : access pthread_attr_t;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_getscope
+ (attr : access pthread_attr_t;
+ contentionscope : access int) return int;
+ pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import
+ (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
+
+ function pthread_attr_getinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : access int) return int;
+ pragma Import
+ (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy,
+ "pthread_attr_setschedpolicy");
+
+ function pthread_attr_getschedpolicy
+ (attr : access pthread_attr_t;
+ policy : access int) return int;
+ pragma Import (C, pthread_attr_getschedpolicy,
+ "pthread_attr_getschedpolicy");
+
+ function pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : int) return int;
+ pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
+
+ function pthread_attr_getschedparam
+ (attr : access pthread_attr_t;
+ sched_param : access int) return int;
+ pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam");
+
+ function sched_yield return int;
+ pragma Import (C, sched_yield, "pthread_yield");
+
+ --------------------------
+ -- P1003.1c Section 16 --
+ --------------------------
+
+ function pthread_attr_init (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "pthread_attr_init");
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Import
+ (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
+
+ function pthread_attr_getdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : access int) return int;
+ pragma Import
+ (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate");
+
+ function pthread_attr_getstacksize
+ (attr : access pthread_attr_t;
+ stacksize : access size_t) return int;
+ pragma Import
+ (C, pthread_attr_getstacksize, "pthread_attr_getstacksize");
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import
+ (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ function pthread_detach (thread : pthread_t) return int;
+ pragma Import (C, pthread_detach, "pthread_detach");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ ------------------------------------
+ -- Non-portable Pthread Functions --
+ ------------------------------------
+
+ function pthread_set_name_np
+ (thread : pthread_t;
+ name : System.Address) return int;
+ pragma Import (C, pthread_set_name_np, "pthread_set_name_np");
+
+private
+
+ type sigset_t is array (1 .. 4) of unsigned;
+
+ -- In FreeBSD the component sa_handler turns out to
+ -- be one a union type, and the selector is a macro:
+ -- #define sa_handler __sigaction_u._handler
+ -- #define sa_sigaction __sigaction_u._sigaction
+
+ -- Should we add a signal_context type here ???
+ -- How could it be done independent of the CPU architecture ???
+ -- sigcontext type is opaque, so it is architecturally neutral.
+ -- It is always passed as an access type, so define it as an empty record
+ -- since the contents are not used anywhere.
+
+ type struct_sigcontext is null record;
+ pragma Convention (C, struct_sigcontext);
+
+ type pid_t is new int;
+ Self_PID : constant pid_t := 0;
+
+ type time_t is new long;
+
+ type timespec is record
+ ts_sec : time_t;
+ ts_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type pthread_t is new System.Address;
+ type pthread_attr_t is new System.Address;
+ type pthread_mutex_t is new System.Address;
+ type pthread_mutexattr_t is new System.Address;
+ type pthread_cond_t is new System.Address;
+ type pthread_condattr_t is new System.Address;
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2015-2016, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the GNU/Hurd version of this package.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+package body System.OS_Interface is
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ --------------------------------------
+ -- pthread_mutexattr_setprioceiling --
+ --------------------------------------
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int is
+ pragma Unreferenced (attr, prioceiling);
+ begin
+ return 0;
+ end pthread_mutexattr_setprioceiling;
+
+ --------------------------------------
+ -- pthread_mutexattr_getprioceiling --
+ --------------------------------------
+
+ function pthread_mutexattr_getprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : access int) return int is
+ pragma Unreferenced (attr, prioceiling);
+ begin
+ return 0;
+ end pthread_mutexattr_getprioceiling;
+
+ ---------------------------
+ -- pthread_setschedparam --
+ ---------------------------
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int is
+ pragma Unreferenced (thread, policy, param);
+ begin
+ return 0;
+ end pthread_setschedparam;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2016, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the GNU/Hurd (POSIX Threads) version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package
+
+with Interfaces.C;
+with Unchecked_Conversion;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthread");
+ pragma Linker_Options ("-lrt");
+
+ subtype int is Interfaces.C.int;
+ subtype char is Interfaces.C.char;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+ -- From /usr/include/i386-gnu/bits/errno.h
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 1073741859;
+ EINTR : constant := 1073741828;
+ EINVAL : constant := 1073741846;
+ ENOMEM : constant := 1073741836;
+ EPERM : constant := 1073741825;
+ ETIMEDOUT : constant := 1073741884;
+
+ -------------
+ -- Signals --
+ -------------
+ -- From /usr/include/i386-gnu/bits/signum.h
+
+ Max_Interrupt : constant := 32;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGPOLL : constant := 23; -- I/O possible (same as SIGIO?)
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD)
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+ SIGLOST : constant := 32; -- Resource lost (Sun); server died (GNU)
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (
+ SIGTRAP,
+ -- To enable debugging on multithreaded applications, mark SIGTRAP to
+ -- be kept unmasked.
+
+ SIGBUS,
+
+ SIGTTIN, SIGTTOU, SIGTSTP,
+ -- Keep these three signals unmasked so that background processes
+ -- and IO behaves as normal "C" applications
+
+ SIGPROF,
+ -- To avoid confusing the profiler
+
+ SIGKILL, SIGSTOP);
+ -- These two signals actually cannot be masked;
+ -- POSIX simply won't allow it.
+
+ Reserved : constant Signal_Set :=
+ -- I am not sure why the following signal is reserved.
+ -- I guess they are not supported by this version of GNU/Hurd.
+ (0 .. 0 => SIGVTALRM);
+
+ type sigset_t is private;
+
+ -- From /usr/include/signal.h /usr/include/i386-gnu/bits/sigset.h
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ -- sigcontext is architecture dependent, so define it private
+ type struct_sigcontext is private;
+
+ -- From /usr/include/i386-gnu/bits/sigaction.h: Note: arg. order differs
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ -- From /usr/include/i386-gnu/bits/sigaction.h
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ -- From /usr/include/i386-gnu/bits/signum.h
+ SIG_ERR : constant := 1;
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+ SIG_HOLD : constant := 2;
+
+ -- From /usr/include/i386-gnu/bits/sigaction.h
+ SA_SIGINFO : constant := 16#0040#;
+ SA_ONSTACK : constant := 16#0001#;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ Time_Slice_Supported : constant Boolean := True;
+ -- Indicates whether time slicing is supported (i.e SCHED_RR is supported)
+
+ type timespec is private;
+
+ function nanosleep (rqtp, rmtp : access timespec) return int;
+ pragma Import (C, nanosleep, "nanosleep");
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ -- From: /usr/include/time.h
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec)
+ return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ -- From: /usr/include/unistd.h
+ function sysconf (name : int) return long;
+ pragma Import (C, sysconf);
+
+ -- From /usr/include/i386-gnu/bits/confname.h
+ SC_CLK_TCK : constant := 2;
+ SC_NPROCESSORS_ONLN : constant := 84;
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+ -- From /usr/include/i386-gnu/bits/sched.h
+
+ SCHED_OTHER : constant := 0;
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority.
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ -- From: /usr/include/signal.h
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ -- From: /usr/include/unistd.h
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ -- From: /usr/include/pthread/pthread.h
+ function lwp_self return System.Address;
+ -- lwp_self does not exist on this thread library, revert to pthread_self
+ -- which is the closest approximation (with getpid). This function is
+ -- needed to share 7staprop.adb across POSIX-like targets.
+ pragma Import (C, lwp_self, "pthread_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, Thread_Body);
+
+ -- From: /usr/include/bits/pthread.h:typedef int __pthread_t;
+ -- /usr/include/pthread/pthreadtypes.h:typedef __pthread_t pthread_t;
+ type pthread_t is new unsigned_long;
+ subtype Thread_Id is pthread_t;
+
+ function To_pthread_t is new Unchecked_Conversion
+ (unsigned_long, pthread_t);
+
+ type pthread_mutex_t is limited private;
+ type pthread_rwlock_t is limited private;
+ type pthread_cond_t is limited private;
+ type pthread_attr_t is limited private;
+ type pthread_mutexattr_t is limited private;
+ type pthread_rwlockattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ -- From /usr/include/pthread/pthreadtypes.h
+ PTHREAD_CREATE_DETACHED : constant := 1;
+ PTHREAD_CREATE_JOINABLE : constant := 0;
+
+ PTHREAD_SCOPE_PROCESS : constant := 1;
+ PTHREAD_SCOPE_SYSTEM : constant := 0;
+
+ -----------
+ -- Stack --
+ -----------
+
+ -- From: /usr/include/i386-gnu/bits/sigstack.h
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ -- From: /usr/include/i386-gnu/bits/shm.h
+ function Get_Page_Size return int;
+ pragma Import (C, Get_Page_Size, "getpagesize");
+ -- Returns the size of a page
+
+ -- From /usr/include/i386-gnu/bits/mman.h
+ PROT_NONE : constant := 0;
+ PROT_READ : constant := 4;
+ PROT_WRITE : constant := 2;
+ PROT_EXEC : constant := 1;
+ PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+ PROT_ON : constant := PROT_NONE;
+ PROT_OFF : constant := PROT_ALL;
+
+ -- From /usr/include/i386-gnu/bits/mman.h
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ pragma Import (C, mprotect);
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ -- From: /usr/include/signal.h:
+ -- sigwait (__const sigset_t *__restrict __set, int *__restrict __sig)
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ -- From: /usr/include/pthread/pthread.h:
+ -- extern int pthread_kill (pthread_t thread, int signo);
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ -- From: /usr/include/i386-gnu/bits/sigthread.h
+ -- extern int pthread_sigmask (int __how, __const __sigset_t *__newmask,
+ -- __sigset_t *__oldmask) __THROW;
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ -- From: /usr/include/pthread/pthread.h and
+ -- /usr/include/pthread/pthreadtypes.h
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_rwlockattr_init
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init");
+
+ function pthread_rwlockattr_destroy
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy");
+ PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0;
+ PTHREAD_RWLOCK_PREFER_WRITER_NP : constant := 1;
+ PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 2;
+
+ function pthread_rwlockattr_setkind_np
+ (attr : access pthread_rwlockattr_t;
+ pref : int) return int;
+ pragma Import
+ (C, pthread_rwlockattr_setkind_np, "pthread_rwlockattr_setkind_np");
+
+ function pthread_rwlock_init
+ (mutex : access pthread_rwlock_t;
+ attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init");
+
+ function pthread_rwlock_destroy
+ (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy");
+
+ function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock");
+
+ function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock");
+
+ function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+ -- From /usr/include/pthread/pthreadtypes.h
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ -- GNU/Hurd does not support Thread Priority Protection or Thread
+ -- Priority Inheritance and lacks some pthread_mutexattr_* functions.
+ -- Replace them with dummy versions.
+ -- From: /usr/include/pthread/pthread.h
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import (C, pthread_mutexattr_setprotocol,
+ "pthread_mutexattr_setprotocol");
+
+ function pthread_mutexattr_getprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : access int) return int;
+ pragma Import (C, pthread_mutexattr_getprotocol,
+ "pthread_mutexattr_getprotocol");
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+
+ function pthread_mutexattr_getprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : access int) return int;
+
+ type struct_sched_param is record
+ sched_priority : int; -- scheduling priority
+ end record;
+ pragma Convention (C, struct_sched_param);
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+
+ function pthread_attr_setscope
+ (attr : access pthread_attr_t;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_getscope
+ (attr : access pthread_attr_t;
+ contentionscope : access int) return int;
+ pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import (C, pthread_attr_setinheritsched,
+ "pthread_attr_setinheritsched");
+
+ function pthread_attr_getinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : access int) return int;
+ pragma Import (C, pthread_attr_getinheritsched,
+ "pthread_attr_getinheritsched");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy, "pthread_setschedpolicy");
+
+ function sched_yield return int;
+ pragma Import (C, sched_yield, "sched_yield");
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "pthread_attr_init");
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Import
+ (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
+
+ -- From: /usr/include/pthread/pthread.h
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ -- From /usr/include/i386-gnu/bits/sched.h
+ CPU_SETSIZE : constant := 1_024;
+
+ type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
+ for bit_field'Size use CPU_SETSIZE;
+ pragma Pack (bit_field);
+ pragma Convention (C, bit_field);
+
+ type cpu_set_t is record
+ bits : bit_field;
+ end record;
+ pragma Convention (C, cpu_set_t);
+
+private
+
+ type sigset_t is array (1 .. 4) of unsigned;
+
+ -- In GNU/Hurd the component sa_handler turns out to
+ -- be one a union type, and the selector is a macro:
+ -- #define sa_handler __sigaction_handler.sa_handler
+ -- #define sa_sigaction __sigaction_handler.sa_sigaction
+
+ -- Should we add a signal_context type here ?
+ -- How could it be done independent of the CPU architecture ?
+ -- sigcontext type is opaque, so it is architecturally neutral.
+ -- It is always passed as an access type, so define it as an empty record
+ -- since the contents are not used anywhere.
+ type struct_sigcontext is null record;
+ pragma Convention (C, struct_sigcontext);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ -- From: /usr/include/pthread/pthreadtypes.h:
+ -- typedef struct __pthread_attr pthread_attr_t;
+ -- /usr/include/i386-gnu/bits/thread-attr.h: struct __pthread_attr...
+ -- /usr/include/pthread/pthreadtypes.h: enum __pthread_contentionscope
+ -- enum __pthread_detachstate detachstate;
+ -- enum __pthread_inheritsched inheritsched;
+ -- enum __pthread_contentionscope contentionscope;
+ -- Not used: schedpolicy : int;
+ type pthread_attr_t is record
+ schedparam : struct_sched_param;
+ stackaddr : System.Address;
+ stacksize : size_t;
+ guardsize : size_t;
+ detachstate : int;
+ inheritsched : int;
+ contentionscope : int;
+ schedpolicy : int;
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ -- From: /usr/include/pthread/pthreadtypes.h:
+ -- typedef struct __pthread_condattr pthread_condattr_t;
+ -- From: /usr/include/i386-gnu/bits/condition-attr.h:
+ -- struct __pthread_condattr {
+ -- enum __pthread_process_shared pshared;
+ -- __Clockid_T Clock;}
+ -- From: /usr/include/pthread/pthreadtypes.h:
+ -- enum __pthread_process_shared
+ type pthread_condattr_t is record
+ pshared : int;
+ clock : clockid_t;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ -- From: /usr/include/pthread/pthreadtypes.h:
+ -- typedef struct __pthread_mutexattr pthread_mutexattr_t; and
+ -- /usr/include/i386-gnu/bits/mutex-attr.h
+ -- struct __pthread_mutexattr {
+ -- int prioceiling;
+ -- enum __pthread_mutex_protocol protocol;
+ -- enum __pthread_process_shared pshared;
+ -- enum __pthread_mutex_type mutex_type;};
+ type pthread_mutexattr_t is record
+ prioceiling : int;
+ protocol : int;
+ pshared : int;
+ mutex_type : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ -- From: /usr/include/pthread/pthreadtypes.h
+ -- typedef struct __pthread_mutex pthread_mutex_t; and
+ -- /usr/include/i386-gnu/bits/mutex.h:
+ -- struct __pthread_mutex {
+ -- __pthread_spinlock_t __held;
+ -- __pthread_spinlock_t __lock;
+ -- /* in cthreads, mutex_init does not initialized the third
+ -- pointer, as such, we cannot rely on its value for anything. */
+ -- char *cthreadscompat1;
+ -- struct __pthread *__queue;
+ -- struct __pthread_mutexattr *attr;
+ -- void *data;
+ -- /* up to this point, we are completely compatible with cthreads
+ -- and what libc expects. */
+ -- void *owner;
+ -- unsigned locks;
+ -- /* if null then the default attributes apply. */
+ -- };
+
+ type pthread_mutex_t is record
+ held : int;
+ lock : int;
+ cthreadcompat : System.Address;
+ queue : System.Address;
+ attr : System.Address;
+ data : System.Address;
+ owner : System.Address;
+ locks : unsigned;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+ -- pointer needed?
+ -- type pthread_mutex_t_ptr is access pthread_mutex_t;
+
+ -- From: /usr/include/pthread/pthreadtypes.h:
+ -- typedef struct __pthread_cond pthread_cond_t;
+ -- typedef struct __pthread_condattr pthread_condattr_t;
+ -- /usr/include/i386-gnu/bits/condition.h:struct __pthread_cond{}
+ -- pthread_condattr_t: see above!
+ -- /usr/include/i386-gnu/bits/condition.h:
+ -- struct __pthread_condimpl *__impl;
+
+ type pthread_cond_t is record
+ lock : int;
+ queue : System.Address;
+ condattr : System.Address;
+ impl : System.Address;
+ data : System.Address;
+ end record;
+ pragma Convention (C, pthread_cond_t);
+
+ -- From: /usr/include/pthread/pthreadtypes.h:
+ -- typedef __pthread_key pthread_key_t; and
+ -- /usr/include/i386-gnu/bits/thread-specific.h:
+ -- typedef int __pthread_key;
+
+ type pthread_key_t is new int;
+
+ -- From: /usr/include/i386-gnu/bits/rwlock-attr.h:
+ -- struct __pthread_rwlockattr {
+ -- enum __pthread_process_shared pshared; };
+
+ type pthread_rwlockattr_t is record
+ pshared : int;
+ end record;
+ pragma Convention (C, pthread_rwlockattr_t);
+
+ -- From: /usr/include/i386-gnu/bits/rwlock.h:
+ -- struct __pthread_rwlock {
+ -- __pthread_spinlock_t __held;
+ -- __pthread_spinlock_t __lock;
+ -- int readers;
+ -- struct __pthread *readerqueue;
+ -- struct __pthread *writerqueue;
+ -- struct __pthread_rwlockattr *__attr;
+ -- void *__data; };
+
+ type pthread_rwlock_t is record
+ held : int;
+ lock : int;
+ readers : int;
+ readerqueue : System.Address;
+ writerqueue : System.Address;
+ attr : pthread_rwlockattr_t;
+ data : int;
+ end record;
+ pragma Convention (C, pthread_rwlock_t);
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2010, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a DCE version of this package.
+-- Currently HP-UX and SNI use this file
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+with Interfaces.C; use Interfaces.C;
+
+package body System.OS_Interface is
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int
+ is
+ Result : int;
+
+ begin
+ Result := sigwait (set);
+
+ if Result = -1 then
+ sig.all := 0;
+ return errno;
+ end if;
+
+ sig.all := Signal (Result);
+ return 0;
+ end sigwait;
+
+ -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int is
+ pragma Unreferenced (thread, sig);
+ begin
+ return 0;
+ end pthread_kill;
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ -- For all following functions, DCE Threads has a non standard behavior.
+ -- It sets errno but the standard Posix requires it to be returned.
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int
+ is
+ function pthread_mutexattr_create
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create");
+
+ begin
+ if pthread_mutexattr_create (attr) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutexattr_init;
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int
+ is
+ function pthread_mutexattr_delete
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete");
+
+ begin
+ if pthread_mutexattr_delete (attr) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutexattr_destroy;
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int
+ is
+ function pthread_mutex_init_base
+ (mutex : access pthread_mutex_t;
+ attr : pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init");
+
+ begin
+ if pthread_mutex_init_base (mutex, attr.all) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutex_init;
+
+ function pthread_mutex_destroy
+ (mutex : access pthread_mutex_t) return int
+ is
+ function pthread_mutex_destroy_base
+ (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy");
+
+ begin
+ if pthread_mutex_destroy_base (mutex) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutex_destroy;
+
+ function pthread_mutex_lock
+ (mutex : access pthread_mutex_t) return int
+ is
+ function pthread_mutex_lock_base
+ (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock");
+
+ begin
+ if pthread_mutex_lock_base (mutex) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutex_lock;
+
+ function pthread_mutex_unlock
+ (mutex : access pthread_mutex_t) return int
+ is
+ function pthread_mutex_unlock_base
+ (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock");
+
+ begin
+ if pthread_mutex_unlock_base (mutex) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_mutex_unlock;
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int
+ is
+ function pthread_condattr_create
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_create, "pthread_condattr_create");
+
+ begin
+ if pthread_condattr_create (attr) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_condattr_init;
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int
+ is
+ function pthread_condattr_delete
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete");
+
+ begin
+ if pthread_condattr_delete (attr) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_condattr_destroy;
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int
+ is
+ function pthread_cond_init_base
+ (cond : access pthread_cond_t;
+ attr : pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init_base, "pthread_cond_init");
+
+ begin
+ if pthread_cond_init_base (cond, attr.all) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_cond_init;
+
+ function pthread_cond_destroy
+ (cond : access pthread_cond_t) return int
+ is
+ function pthread_cond_destroy_base
+ (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy");
+
+ begin
+ if pthread_cond_destroy_base (cond) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_cond_destroy;
+
+ function pthread_cond_signal
+ (cond : access pthread_cond_t) return int
+ is
+ function pthread_cond_signal_base
+ (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal");
+
+ begin
+ if pthread_cond_signal_base (cond) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_cond_signal;
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int
+ is
+ function pthread_cond_wait_base
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait");
+
+ begin
+ if pthread_cond_wait_base (cond, mutex) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_cond_wait;
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int
+ is
+ function pthread_cond_timedwait_base
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
+
+ begin
+ if pthread_cond_timedwait_base (cond, mutex, abstime) /= 0 then
+ return (if errno = EAGAIN then ETIMEDOUT else errno);
+ else
+ return 0;
+ end if;
+ end pthread_cond_timedwait;
+
+ ----------------------------
+ -- POSIX.1c Section 13 --
+ ----------------------------
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int
+ is
+ function pthread_setscheduler
+ (thread : pthread_t;
+ policy : int;
+ priority : int) return int;
+ pragma Import (C, pthread_setscheduler, "pthread_setscheduler");
+
+ begin
+ if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_setschedparam;
+
+ function sched_yield return int is
+ procedure pthread_yield;
+ pragma Import (C, pthread_yield, "pthread_yield");
+ begin
+ pthread_yield;
+ return 0;
+ end sched_yield;
+
+ -----------------------------
+ -- P1003.1c - Section 16 --
+ -----------------------------
+
+ function pthread_attr_init
+ (attributes : access pthread_attr_t) return int
+ is
+ function pthread_attr_create
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_create, "pthread_attr_create");
+
+ begin
+ if pthread_attr_create (attributes) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_attr_init;
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int
+ is
+ function pthread_attr_delete
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_delete, "pthread_attr_delete");
+
+ begin
+ if pthread_attr_delete (attributes) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_attr_destroy;
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int
+ is
+ function pthread_attr_setstacksize_base
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize_base,
+ "pthread_attr_setstacksize");
+
+ begin
+ if pthread_attr_setstacksize_base (attr, stacksize) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_attr_setstacksize;
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int
+ is
+ function pthread_create_base
+ (thread : access pthread_t;
+ attributes : pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create_base, "pthread_create");
+
+ begin
+ if pthread_create_base
+ (thread, attributes.all, start_routine, arg) /= 0
+ then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_create;
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int
+ is
+ function pthread_setspecific_base
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific_base, "pthread_setspecific");
+
+ begin
+ if pthread_setspecific_base (key, value) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_setspecific;
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address is
+ function pthread_getspecific_base
+ (key : pthread_key_t;
+ value : access System.Address) return int;
+ pragma Import (C, pthread_getspecific_base, "pthread_getspecific");
+ Addr : aliased System.Address;
+
+ begin
+ if pthread_getspecific_base (key, Addr'Access) /= 0 then
+ return System.Null_Address;
+ else
+ return Addr;
+ end if;
+ end pthread_getspecific;
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int
+ is
+ function pthread_keycreate
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_keycreate, "pthread_keycreate");
+
+ begin
+ if pthread_keycreate (key, destructor) /= 0 then
+ return errno;
+ else
+ return 0;
+ end if;
+ end pthread_key_create;
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ function intr_attach (sig : int; handler : isr_address) return long is
+ function c_signal (sig : int; handler : isr_address) return long;
+ pragma Import (C, c_signal, "signal");
+ begin
+ return c_signal (sig, handler);
+ end intr_attach;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2012, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the HP-UX version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lcma");
+
+ subtype int is Interfaces.C.int;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIME : constant := 52;
+ ETIMEDOUT : constant := 238;
+
+ FUNC_ERR : constant := -1;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 44;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGVTALRM : constant := 20; -- virtual timer alarm
+ SIGPROF : constant := 21; -- profiling timer alarm
+ SIGIO : constant := 22; -- asynchronous I/O
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGWINCH : constant := 23; -- window size change
+ SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 25; -- user stop requested from tty
+ SIGCONT : constant := 26; -- stopped process has been continued
+ SIGTTIN : constant := 27; -- background tty read attempted
+ SIGTTOU : constant := 28; -- background tty write attempted
+ SIGURG : constant := 29; -- urgent condition on IO channel
+ SIGLOST : constant := 30; -- remote lock lost (NFS)
+ SIGDIL : constant := 32; -- DIL signal
+ SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit)
+ SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit)
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Note: on other targets, we usually use SIGABRT, but on HP/UX, it
+ -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP);
+
+ Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
+
+ type sigset_t is private;
+
+ type isr_address is access procedure (sig : int);
+ pragma Convention (C, isr_address);
+
+ function intr_attach (sig : int; handler : isr_address) return long;
+
+ Intr_Attach_Reset : constant Boolean := True;
+ -- True if intr_attach is reset after an interrupt handler is called
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ type Signal_Handler is access procedure (signo : Signal);
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_RESTART : constant := 16#40#;
+ SA_SIGINFO : constant := 16#10#;
+ SA_ONSTACK : constant := 16#01#;
+
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+ SIG_ERR : constant := -1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ type timespec is private;
+
+ function nanosleep (rqtp, rmtp : access timespec) return int;
+ pragma Import (C, nanosleep);
+
+ type clockid_t is new int;
+
+ function Clock_Gettime
+ (Clock_Id : clockid_t; Tp : access timespec) return int;
+ pragma Import (C, Clock_Gettime);
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 1;
+ SCHED_OTHER : constant := 2;
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ type pthread_t is private;
+ subtype Thread_Id is pthread_t;
+
+ type pthread_mutex_t is limited private;
+ type pthread_cond_t is limited private;
+ type pthread_attr_t is limited private;
+ type pthread_mutexattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ -- Read/Write lock not supported on HPUX. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ subtype pthread_rwlock_t is pthread_mutex_t;
+ subtype pthread_rwlockattr_t is pthread_mutexattr_t;
+
+ -----------
+ -- Stack --
+ -----------
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- This is a dummy procedure to share some GNULLI files
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t) return int;
+ pragma Import (C, sigwait, "cma_sigwait");
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Inline (sigwait);
+ -- DCE_THREADS has a nonstandard sigwait
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Inline (pthread_kill);
+ -- DCE_THREADS doesn't have pthread_kill
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ -- DCE THREADS does not have pthread_sigmask. Instead, it uses sigprocmask
+ -- to do the signal handling when the thread library is sucked in.
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ -- DCE_THREADS has a nonstandard pthread_mutexattr_init
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ -- DCE_THREADS has a nonstandard pthread_mutexattr_destroy
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ -- DCE_THREADS has a nonstandard pthread_mutex_init
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ -- DCE_THREADS has a nonstandard pthread_mutex_destroy
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_mutex_lock);
+ -- DCE_THREADS has nonstandard pthread_mutex_lock
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_mutex_unlock);
+ -- DCE_THREADS has nonstandard pthread_mutex_lock
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ -- DCE_THREADS has nonstandard pthread_condattr_init
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ -- DCE_THREADS has nonstandard pthread_condattr_destroy
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ -- DCE_THREADS has nonstandard pthread_cond_init
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ -- DCE_THREADS has nonstandard pthread_cond_destroy
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Inline (pthread_cond_signal);
+ -- DCE_THREADS has nonstandard pthread_cond_signal
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Inline (pthread_cond_wait);
+ -- DCE_THREADS has a nonstandard pthread_cond_wait
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Inline (pthread_cond_timedwait);
+ -- DCE_THREADS has a nonstandard pthread_cond_timedwait
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ type struct_sched_param is record
+ sched_priority : int; -- scheduling priority
+ end record;
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ pragma Inline (pthread_setschedparam);
+ -- DCE_THREADS has a nonstandard pthread_setschedparam
+
+ function sched_yield return int;
+ pragma Inline (sched_yield);
+ -- DCE_THREADS has a nonstandard sched_yield
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init (attributes : access pthread_attr_t) return int;
+ pragma Inline (pthread_attr_init);
+ -- DCE_THREADS has a nonstandard pthread_attr_init
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Inline (pthread_attr_destroy);
+ -- DCE_THREADS has a nonstandard pthread_attr_destroy
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Inline (pthread_attr_setstacksize);
+ -- DCE_THREADS has a nonstandard pthread_attr_setstacksize
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Inline (pthread_create);
+ -- DCE_THREADS has a nonstandard pthread_create
+
+ procedure pthread_detach (thread : access pthread_t);
+ pragma Import (C, pthread_detach);
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Inline (pthread_setspecific);
+ -- DCE_THREADS has a nonstandard pthread_setspecific
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Inline (pthread_getspecific);
+ -- DCE_THREADS has a nonstandard pthread_getspecific
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Inline (pthread_key_create);
+ -- DCE_THREADS has a nonstandard pthread_key_create
+
+private
+
+ type array_type_1 is array (Integer range 0 .. 7) of unsigned_long;
+ type sigset_t is record
+ X_X_sigbits : array_type_1;
+ end record;
+ pragma Convention (C, sigset_t);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ CLOCK_REALTIME : constant clockid_t := 1;
+
+ type cma_t_address is new System.Address;
+
+ type cma_t_handle is record
+ field1 : cma_t_address;
+ field2 : Short_Integer;
+ field3 : Short_Integer;
+ end record;
+ for cma_t_handle'Size use 64;
+
+ type pthread_attr_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_attr_t);
+
+ type pthread_condattr_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_condattr_t);
+
+ type pthread_mutexattr_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_mutexattr_t);
+
+ type pthread_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_t);
+
+ type pthread_mutex_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_mutex_t);
+
+ type pthread_cond_t is new cma_t_handle;
+ pragma Convention (C_Pass_By_Copy, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a HPUX 11.0 (Native THREADS) version of this package
+
+-- This package encapsulates all direct interfaces to OS services that are
+-- needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthread");
+
+ subtype int is Interfaces.C.int;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIMEDOUT : constant := 238;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 44;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGVTALRM : constant := 20; -- virtual timer alarm
+ SIGPROF : constant := 21; -- profiling timer alarm
+ SIGIO : constant := 22; -- asynchronous I/O
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGWINCH : constant := 23; -- window size change
+ SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 25; -- user stop requested from tty
+ SIGCONT : constant := 26; -- stopped process has been continued
+ SIGTTIN : constant := 27; -- background tty read attempted
+ SIGTTOU : constant := 28; -- background tty write attempted
+ SIGURG : constant := 29; -- urgent condition on IO channel
+ SIGLOST : constant := 30; -- remote lock lost (NFS)
+ SIGDIL : constant := 32; -- DIL signal
+ SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit)
+ SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit)
+ SIGCANCEL : constant := 35; -- used for pthread cancellation.
+ SIGGFAULT : constant := 36; -- Graphics framebuffer fault
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Note: on other targets, we usually use SIGABRT, but on HPUX, it
+ -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM.
+ -- Do we use SIGTERM or SIGABRT???
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set :=
+ (SIGABRT, SIGPIPE, SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF,
+ SIGALRM, SIGVTALRM, SIGIO, SIGCHLD);
+
+ Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
+
+ type sigset_t is private;
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_SIGINFO : constant := 16#10#;
+ SA_ONSTACK : constant := 16#01#;
+
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ Time_Slice_Supported : constant Boolean := True;
+ -- Indicates whether time slicing is supported
+
+ type timespec is private;
+
+ type clockid_t is new int;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ type struct_timezone is record
+ tz_minuteswest : int;
+ tz_dsttime : int;
+ end record;
+ pragma Convention (C, struct_timezone);
+ type struct_timezone_ptr is access all struct_timezone;
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 0;
+ SCHED_RR : constant := 1;
+ SCHED_OTHER : constant := 2;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ pragma Import (C, lwp_self, "_lwp_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ type pthread_t is private;
+ subtype Thread_Id is pthread_t;
+
+ type pthread_mutex_t is limited private;
+ type pthread_cond_t is limited private;
+ type pthread_attr_t is limited private;
+ type pthread_mutexattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ PTHREAD_CREATE_DETACHED : constant := 16#de#;
+
+ PTHREAD_SCOPE_PROCESS : constant := 2;
+ PTHREAD_SCOPE_SYSTEM : constant := 1;
+
+ -- Read/Write lock not supported on HPUX. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ subtype pthread_rwlock_t is pthread_mutex_t;
+ subtype pthread_rwlockattr_t is pthread_mutexattr_t;
+
+ -----------
+ -- Stack --
+ -----------
+
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_flags : int;
+ ss_size : size_t;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
+ -- The alternate signal stack for stack overflows
+
+ Alternate_Stack_Size : constant := 128 * 1024;
+ -- This must be in keeping with init.c:__gnat_alternate_stack
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- Returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ function Get_Page_Size return int;
+ pragma Import (C, Get_Page_Size, "getpagesize");
+ -- Returns the size of a page
+
+ PROT_NONE : constant := 0;
+ PROT_READ : constant := 1;
+ PROT_WRITE : constant := 2;
+ PROT_EXEC : constant := 4;
+ PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+ PROT_ON : constant := PROT_READ;
+ PROT_OFF : constant := PROT_ALL;
+
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ pragma Import (C, mprotect);
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 16#100#;
+ PTHREAD_PRIO_PROTECT : constant := 16#200#;
+ PTHREAD_PRIO_INHERIT : constant := 16#400#;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import (C, pthread_mutexattr_setprotocol);
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import (C, pthread_mutexattr_setprioceiling);
+
+ type Array_7_Int is array (0 .. 6) of int;
+ type struct_sched_param is record
+ sched_priority : int;
+ sched_reserved : Array_7_Int;
+ end record;
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param)
+ return int;
+ pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
+
+ function pthread_attr_setscope
+ (attr : access pthread_attr_t;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import (C, pthread_attr_setinheritsched);
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy);
+
+ function sched_yield return int;
+ pragma Import (C, sched_yield, "sched_yield");
+
+ --------------------------
+ -- P1003.1c Section 16 --
+ --------------------------
+
+ function pthread_attr_init
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "__pthread_attr_init_system");
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Import (C, pthread_attr_setdetachstate);
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "__pthread_create_system");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+private
+
+ type unsigned_int_array_8 is array (0 .. 7) of unsigned;
+ type sigset_t is record
+ sigset : unsigned_int_array_8;
+ end record;
+ pragma Convention (C_Pass_By_Copy, sigset_t);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type pthread_attr_t is new int;
+ type pthread_condattr_t is new int;
+ type pthread_mutexattr_t is new int;
+ type pthread_t is new int;
+
+ type short_array is array (Natural range <>) of short;
+ type int_array is array (Natural range <>) of int;
+
+ type pthread_mutex_t is record
+ m_short : short_array (0 .. 1);
+ m_int : int;
+ m_int1 : int_array (0 .. 3);
+ m_pad : int;
+
+ m_ptr : int;
+ -- actually m_ptr is a void*, and on 32 bit ABI, m_pad is added so that
+ -- this field takes 64 bits. On 64 bit ABI, m_pad is gone, and m_ptr is
+ -- a 64 bit void*. Assume int'Size = 32.
+
+ m_int2 : int_array (0 .. 1);
+ m_int3 : int_array (0 .. 3);
+ m_short2 : short_array (0 .. 1);
+ m_int4 : int_array (0 .. 4);
+ m_int5 : int_array (0 .. 1);
+ end record;
+ for pthread_mutex_t'Alignment use System.Address'Alignment;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is record
+ c_short : short_array (0 .. 1);
+ c_int : int;
+ c_int1 : int_array (0 .. 3);
+ m_pad : int;
+ m_ptr : int; -- see comment in pthread_mutex_t
+ c_int2 : int_array (0 .. 1);
+ c_int3 : int_array (0 .. 1);
+ c_int4 : int_array (0 .. 1);
+ end record;
+ for pthread_cond_t'Alignment use System.Address'Alignment;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new int;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2016, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the GNU/kFreeBSD (POSIX Threads) version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package
+
+with Interfaces.C;
+with Unchecked_Conversion;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthread");
+
+ subtype int is Interfaces.C.int;
+ subtype char is Interfaces.C.char;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 35;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ EPERM : constant := 1;
+ ETIMEDOUT : constant := 60;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 128;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD)
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+ SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
+ SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
+ SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (
+ SIGTRAP,
+ -- To enable debugging on multithreaded applications, mark SIGTRAP to
+ -- be kept unmasked.
+
+ SIGBUS,
+
+ SIGTTIN, SIGTTOU, SIGTSTP,
+ -- Keep these three signals unmasked so that background processes
+ -- and IO behaves as normal "C" applications
+
+ SIGPROF,
+ -- To avoid confusing the profiler
+
+ SIGKILL, SIGSTOP,
+ -- These two signals actually cannot be masked;
+ -- POSIX simply won't allow it.
+
+ SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG);
+ -- These three signals are used by GNU/LinuxThreads starting from
+ -- glibc 2.1 (future 2.2).
+
+ Reserved : constant Signal_Set :=
+ -- I am not sure why the following signal is reserved.
+ -- I guess they are not supported by this version of GNU/kFreeBSD.
+ (0 .. 0 => SIGVTALRM);
+
+ type sigset_t is private;
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ -- sigcontext is architecture dependent, so define it private
+ type struct_sigcontext is private;
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_flags : int;
+ sa_mask : sigset_t;
+ end record;
+ pragma Convention (C, struct_sigaction);
+
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ SA_SIGINFO : constant := 16#0040#;
+ SA_ONSTACK : constant := 16#0001#;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ Time_Slice_Supported : constant Boolean := True;
+ -- Indicates whether time slicing is supported (i.e SCHED_RR is supported)
+
+ type timespec is private;
+
+ function nanosleep (rqtp, rmtp : access timespec) return int;
+ pragma Import (C, nanosleep, "nanosleep");
+
+ type clockid_t is private;
+
+ CLOCK_REALTIME : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec)
+ return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ function sysconf (name : int) return long;
+ pragma Import (C, sysconf);
+
+ SC_CLK_TCK : constant := 2;
+ SC_NPROCESSORS_ONLN : constant := 84;
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_OTHER : constant := 2;
+ SCHED_RR : constant := 3;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority.
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ -- lwp_self does not exist on this thread library, revert to pthread_self
+ -- which is the closest approximation (with getpid). This function is
+ -- needed to share 7staprop.adb across POSIX-like targets.
+ pragma Import (C, lwp_self, "pthread_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, Thread_Body);
+
+ type pthread_t is new unsigned_long;
+ subtype Thread_Id is pthread_t;
+
+ function To_pthread_t is new Unchecked_Conversion
+ (unsigned_long, pthread_t);
+
+ type pthread_mutex_t is limited private;
+ type pthread_cond_t is limited private;
+ type pthread_attr_t is limited private;
+ type pthread_mutexattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ PTHREAD_CREATE_DETACHED : constant := 1;
+ PTHREAD_CREATE_JOINABLE : constant := 0;
+
+ PTHREAD_SCOPE_PROCESS : constant := 0;
+ PTHREAD_SCOPE_SYSTEM : constant := 2;
+
+ -- Read/Write lock not supported on kfreebsd. To add support both types
+ -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
+ -- with the associated routines pthread_rwlock_[init/destroy] and
+ -- pthread_rwlock_[rdlock/wrlock/unlock].
+
+ subtype pthread_rwlock_t is pthread_mutex_t;
+ subtype pthread_rwlockattr_t is pthread_mutexattr_t;
+
+ -----------
+ -- Stack --
+ -----------
+
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_size : size_t;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- returns the stack base of the specified thread. Only call this function
+ -- when Stack_Base_Available is True.
+
+ function Get_Page_Size return int;
+ pragma Import (C, Get_Page_Size, "getpagesize");
+ -- Returns the size of a page
+
+ PROT_NONE : constant := 0;
+ PROT_READ : constant := 1;
+ PROT_WRITE : constant := 2;
+ PROT_EXEC : constant := 4;
+ PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
+ PROT_ON : constant := PROT_NONE;
+ PROT_OFF : constant := PROT_ALL;
+
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ pragma Import (C, mprotect);
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
+
+ function pthread_mutexattr_getprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : access int) return int;
+ pragma Import
+ (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol");
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprioceiling,
+ "pthread_mutexattr_setprioceiling");
+
+ function pthread_mutexattr_getprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : access int) return int;
+ pragma Import
+ (C, pthread_mutexattr_getprioceiling,
+ "pthread_mutexattr_getprioceiling");
+
+ type struct_sched_param is record
+ sched_priority : int; -- scheduling priority
+ end record;
+ pragma Convention (C, struct_sched_param);
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
+
+ function pthread_attr_setscope
+ (attr : access pthread_attr_t;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_getscope
+ (attr : access pthread_attr_t;
+ contentionscope : access int) return int;
+ pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import
+ (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
+
+ function pthread_attr_getinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : access int) return int;
+ pragma Import
+ (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import
+ (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy");
+
+ function sched_yield return int;
+ pragma Import (C, sched_yield, "sched_yield");
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "pthread_attr_init");
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Import
+ (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ CPU_SETSIZE : constant := 1_024;
+
+ type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
+ for bit_field'Size use CPU_SETSIZE;
+ pragma Pack (bit_field);
+ pragma Convention (C, bit_field);
+
+ type cpu_set_t is record
+ bits : bit_field;
+ end record;
+ pragma Convention (C, cpu_set_t);
+
+ function pthread_setaffinity_np
+ (thread : pthread_t;
+ cpusetsize : size_t;
+ cpuset : access cpu_set_t) return int;
+ pragma Import (C, pthread_setaffinity_np, "__gnat_pthread_setaffinity_np");
+
+private
+
+ type sigset_t is array (1 .. 4) of unsigned;
+
+ -- In FreeBSD the component sa_handler turns out to
+ -- be one a union type, and the selector is a macro:
+ -- #define sa_handler __sigaction_u._handler
+ -- #define sa_sigaction __sigaction_u._sigaction
+
+ -- Should we add a signal_context type here ?
+ -- How could it be done independent of the CPU architecture ?
+ -- sigcontext type is opaque, so it is architecturally neutral.
+ -- It is always passed as an access type, so define it as an empty record
+ -- since the contents are not used anywhere.
+ type struct_sigcontext is null record;
+ pragma Convention (C, struct_sigcontext);
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+ CLOCK_REALTIME : constant clockid_t := 0;
+
+ type pthread_attr_t is record
+ detachstate : int;
+ schedpolicy : int;
+ schedparam : struct_sched_param;
+ inheritsched : int;
+ scope : int;
+ guardsize : size_t;
+ stackaddr_set : int;
+ stackaddr : System.Address;
+ stacksize : size_t;
+ end record;
+ pragma Convention (C, pthread_attr_t);
+
+ type pthread_condattr_t is record
+ dummy : int;
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+
+ type pthread_mutexattr_t is record
+ mutexkind : int;
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+
+ type struct_pthread_fast_lock is record
+ status : long;
+ spinlock : int;
+ end record;
+ pragma Convention (C, struct_pthread_fast_lock);
+
+ type pthread_mutex_t is record
+ m_reserved : int;
+ m_count : int;
+ m_owner : System.Address;
+ m_kind : int;
+ m_lock : struct_pthread_fast_lock;
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+
+ type pthread_cond_t is array (0 .. 47) of unsigned_char;
+ pragma Convention (C, pthread_cond_t);
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a GNU/Linux (GNU/LinuxThreads) version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+with Interfaces.C;
+with System.Linux;
+with System.OS_Constants;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lpthread");
+ pragma Linker_Options ("-lrt");
+ -- Needed for clock_getres with glibc versions prior to 2.17
+
+ subtype int is Interfaces.C.int;
+ subtype char is Interfaces.C.char;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := System.Linux.EAGAIN;
+ EINTR : constant := System.Linux.EINTR;
+ EINVAL : constant := System.Linux.EINVAL;
+ ENOMEM : constant := System.Linux.ENOMEM;
+ EPERM : constant := System.Linux.EPERM;
+ ETIMEDOUT : constant := System.Linux.ETIMEDOUT;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 63;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := System.Linux.SIGHUP;
+ SIGINT : constant := System.Linux.SIGINT;
+ SIGQUIT : constant := System.Linux.SIGQUIT;
+ SIGILL : constant := System.Linux.SIGILL;
+ SIGTRAP : constant := System.Linux.SIGTRAP;
+ SIGIOT : constant := System.Linux.SIGIOT;
+ SIGABRT : constant := System.Linux.SIGABRT;
+ SIGFPE : constant := System.Linux.SIGFPE;
+ SIGKILL : constant := System.Linux.SIGKILL;
+ SIGBUS : constant := System.Linux.SIGBUS;
+ SIGSEGV : constant := System.Linux.SIGSEGV;
+ SIGPIPE : constant := System.Linux.SIGPIPE;
+ SIGALRM : constant := System.Linux.SIGALRM;
+ SIGTERM : constant := System.Linux.SIGTERM;
+ SIGUSR1 : constant := System.Linux.SIGUSR1;
+ SIGUSR2 : constant := System.Linux.SIGUSR2;
+ SIGCLD : constant := System.Linux.SIGCLD;
+ SIGCHLD : constant := System.Linux.SIGCHLD;
+ SIGPWR : constant := System.Linux.SIGPWR;
+ SIGWINCH : constant := System.Linux.SIGWINCH;
+ SIGURG : constant := System.Linux.SIGURG;
+ SIGPOLL : constant := System.Linux.SIGPOLL;
+ SIGIO : constant := System.Linux.SIGIO;
+ SIGLOST : constant := System.Linux.SIGLOST;
+ SIGSTOP : constant := System.Linux.SIGSTOP;
+ SIGTSTP : constant := System.Linux.SIGTSTP;
+ SIGCONT : constant := System.Linux.SIGCONT;
+ SIGTTIN : constant := System.Linux.SIGTTIN;
+ SIGTTOU : constant := System.Linux.SIGTTOU;
+ SIGVTALRM : constant := System.Linux.SIGVTALRM;
+ SIGPROF : constant := System.Linux.SIGPROF;
+ SIGXCPU : constant := System.Linux.SIGXCPU;
+ SIGXFSZ : constant := System.Linux.SIGXFSZ;
+ SIGUNUSED : constant := System.Linux.SIGUNUSED;
+ SIGSTKFLT : constant := System.Linux.SIGSTKFLT;
+ SIGLTHRRES : constant := System.Linux.SIGLTHRRES;
+ SIGLTHRCAN : constant := System.Linux.SIGLTHRCAN;
+ SIGLTHRDBG : constant := System.Linux.SIGLTHRDBG;
+
+ SIGADAABORT : constant := SIGABRT;
+ -- Change this to use another signal for task abort. SIGTERM might be a
+ -- good one.
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (
+ SIGTRAP,
+ -- To enable debugging on multithreaded applications, mark SIGTRAP to
+ -- be kept unmasked.
+
+ SIGBUS,
+
+ SIGTTIN, SIGTTOU, SIGTSTP,
+ -- Keep these three signals unmasked so that background processes and IO
+ -- behaves as normal "C" applications
+
+ SIGPROF,
+ -- To avoid confusing the profiler
+
+ SIGKILL, SIGSTOP,
+ -- These two signals actually can't be masked (POSIX won't allow it)
+
+ SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG);
+ -- These three signals are used by GNU/LinuxThreads starting from glibc
+ -- 2.1 (future 2.2).
+
+ Reserved : constant Signal_Set := (SIGVTALRM, SIGUNUSED);
+ -- Not clear why these two signals are reserved. Perhaps they are not
+ -- supported by this version of GNU/Linux ???
+
+ type sigset_t is private;
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ type union_type_3 is new String (1 .. 116);
+ type siginfo_t is record
+ si_signo : int;
+ si_code : int;
+ si_errno : int;
+ X_data : union_type_3;
+ end record;
+ pragma Convention (C, siginfo_t);
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ sa_restorer : System.Address;
+ end record;
+ pragma Convention (C, struct_sigaction);
+
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ type Machine_State is record
+ eip : unsigned_long;
+ ebx : unsigned_long;
+ esp : unsigned_long;
+ ebp : unsigned_long;
+ esi : unsigned_long;
+ edi : unsigned_long;
+ end record;
+ type Machine_State_Ptr is access all Machine_State;
+
+ SA_SIGINFO : constant := System.Linux.SA_SIGINFO;
+ SA_ONSTACK : constant := System.Linux.SA_ONSTACK;
+
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ subtype time_t is System.Linux.time_t;
+ subtype timespec is System.Linux.timespec;
+ subtype timeval is System.Linux.timeval;
+ subtype clockid_t is System.Linux.clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t; tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ function sysconf (name : int) return long;
+ pragma Import (C, sysconf);
+
+ SC_CLK_TCK : constant := 2;
+ SC_NPROCESSORS_ONLN : constant := 84;
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_OTHER : constant := 0;
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ PR_SET_NAME : constant := 15;
+ PR_GET_NAME : constant := 16;
+
+ function prctl
+ (option : int;
+ arg2, arg3, arg4, arg5 : unsigned_long := 0) return int;
+ pragma Import (C, prctl);
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ type pthread_t is new unsigned_long;
+ subtype Thread_Id is pthread_t;
+
+ function To_pthread_t is
+ new Ada.Unchecked_Conversion (unsigned_long, pthread_t);
+
+ type pthread_mutex_t is limited private;
+ type pthread_rwlock_t is limited private;
+ type pthread_cond_t is limited private;
+ type pthread_attr_t is limited private;
+ type pthread_mutexattr_t is limited private;
+ type pthread_rwlockattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ PTHREAD_CREATE_DETACHED : constant := 1;
+
+ -----------
+ -- Stack --
+ -----------
+
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_flags : int;
+ ss_size : size_t;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+ pragma Import (C, sigaltstack, "sigaltstack");
+
+ Alternate_Stack : aliased System.Address;
+ pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
+ -- The alternate signal stack for stack overflows
+
+ Alternate_Stack_Size : constant := 16 * 1024;
+ -- This must be in keeping with init.c:__gnat_alternate_stack
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- This is a dummy procedure to share some GNULLI files
+
+ ---------------------------------------
+ -- Nonstandard Thread Initialization --
+ ---------------------------------------
+
+ procedure pthread_init;
+ pragma Inline (pthread_init);
+ -- This is a dummy procedure to share some GNULLI files
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill (thread : pthread_t; sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ --------------------------
+ -- POSIX.1c Section 11 --
+ --------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_rwlockattr_init
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init");
+
+ function pthread_rwlockattr_destroy
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy");
+
+ PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0;
+ PTHREAD_RWLOCK_PREFER_WRITER_NP : constant := 1;
+ PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 2;
+
+ function pthread_rwlockattr_setkind_np
+ (attr : access pthread_rwlockattr_t;
+ pref : int) return int;
+ pragma Import
+ (C, pthread_rwlockattr_setkind_np, "pthread_rwlockattr_setkind_np");
+
+ function pthread_rwlock_init
+ (mutex : access pthread_rwlock_t;
+ attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init");
+
+ function pthread_rwlock_destroy
+ (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy");
+
+ function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock");
+
+ function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock");
+
+ function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import (C, pthread_mutexattr_setprotocol);
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import (C, pthread_mutexattr_setprioceiling);
+
+ type struct_sched_param is record
+ sched_priority : int; -- scheduling priority
+ end record;
+ pragma Convention (C, struct_sched_param);
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import
+ (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy");
+
+ function sched_yield return int;
+ pragma Import (C, sched_yield, "sched_yield");
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "pthread_attr_init");
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Import
+ (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ function lwp_self return System.Address;
+ pragma Import (C, lwp_self, "__gnat_lwp_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ ----------------
+ -- Extensions --
+ ----------------
+
+ CPU_SETSIZE : constant := 1_024;
+ -- Size of the cpu_set_t mask on most linux systems (SUSE 11 uses 4_096).
+ -- This is kept for backward compatibility (System.Task_Info uses it), but
+ -- the run-time library does no longer rely on static masks, using
+ -- dynamically allocated masks instead.
+
+ type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
+ for bit_field'Size use CPU_SETSIZE;
+ pragma Pack (bit_field);
+ pragma Convention (C, bit_field);
+
+ type cpu_set_t is record
+ bits : bit_field;
+ end record;
+ pragma Convention (C, cpu_set_t);
+
+ type cpu_set_t_ptr is access all cpu_set_t;
+ -- In the run-time library we use this pointer because the size of type
+ -- cpu_set_t varies depending on the glibc version. Hence, objects of type
+ -- cpu_set_t are allocated dynamically using the number of processors
+ -- available in the target machine (value obtained at execution time).
+
+ function CPU_ALLOC (count : size_t) return cpu_set_t_ptr;
+ pragma Import (C, CPU_ALLOC, "__gnat_cpu_alloc");
+ -- Wrapper around the CPU_ALLOC C macro
+
+ function CPU_ALLOC_SIZE (count : size_t) return size_t;
+ pragma Import (C, CPU_ALLOC_SIZE, "__gnat_cpu_alloc_size");
+ -- Wrapper around the CPU_ALLOC_SIZE C macro
+
+ procedure CPU_FREE (cpuset : cpu_set_t_ptr);
+ pragma Import (C, CPU_FREE, "__gnat_cpu_free");
+ -- Wrapper around the CPU_FREE C macro
+
+ procedure CPU_ZERO (count : size_t; cpuset : cpu_set_t_ptr);
+ pragma Import (C, CPU_ZERO, "__gnat_cpu_zero");
+ -- Wrapper around the CPU_ZERO_S C macro
+
+ procedure CPU_SET (cpu : int; count : size_t; cpuset : cpu_set_t_ptr);
+ pragma Import (C, CPU_SET, "__gnat_cpu_set");
+ -- Wrapper around the CPU_SET_S C macro
+
+ function pthread_setaffinity_np
+ (thread : pthread_t;
+ cpusetsize : size_t;
+ cpuset : cpu_set_t_ptr) return int;
+ pragma Import (C, pthread_setaffinity_np, "pthread_setaffinity_np");
+ pragma Weak_External (pthread_setaffinity_np);
+ -- Use a weak symbol because this function may be available or not,
+ -- depending on the version of the system.
+
+ function pthread_attr_setaffinity_np
+ (attr : access pthread_attr_t;
+ cpusetsize : size_t;
+ cpuset : cpu_set_t_ptr) return int;
+ pragma Import (C, pthread_attr_setaffinity_np,
+ "pthread_attr_setaffinity_np");
+ pragma Weak_External (pthread_attr_setaffinity_np);
+ -- Use a weak symbol because this function may be available or not,
+ -- depending on the version of the system.
+
+private
+
+ type sigset_t is
+ array (0 .. OS_Constants.SIZEOF_sigset - 1) of unsigned_char;
+ pragma Convention (C, sigset_t);
+ for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+ pragma Warnings (Off);
+ for struct_sigaction use record
+ sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1;
+ sa_mask at Linux.sa_mask_pos range 0 .. 1023;
+ sa_flags at Linux.sa_flags_pos range 0 .. int'Size - 1;
+ end record;
+ -- We intentionally leave sa_restorer unspecified and let the compiler
+ -- append it after the last field, so disable corresponding warning.
+ pragma Warnings (On);
+
+ type pid_t is new int;
+
+ subtype char_array is Interfaces.C.char_array;
+
+ type pthread_attr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_ATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_attr_t);
+ for pthread_attr_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+ type pthread_condattr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_CONDATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+ for pthread_condattr_t'Alignment use Interfaces.C.int'Alignment;
+
+ type pthread_mutexattr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_MUTEXATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+ for pthread_mutexattr_t'Alignment use Interfaces.C.int'Alignment;
+
+ type pthread_mutex_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE);
+ end record;
+ pragma Convention (C, pthread_mutex_t);
+ for pthread_mutex_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+ type pthread_rwlockattr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCKATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_rwlockattr_t);
+ for pthread_rwlockattr_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+ type pthread_rwlock_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCK_SIZE);
+ end record;
+ pragma Convention (C, pthread_rwlock_t);
+ for pthread_rwlock_t'Alignment use Interfaces.C.unsigned_long'Alignment;
+
+ type pthread_cond_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_COND_SIZE);
+ end record;
+ pragma Convention (C, pthread_cond_t);
+ for pthread_cond_t'Alignment use Interfaces.Unsigned_64'Alignment;
+
+ type pthread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a NT (native) version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by the tasking run-time (libgnarl). For non tasking
+-- oriented services consider declaring them into system-win32.
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+with Interfaces.C.Strings;
+with System.Win32;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-mthreads");
+
+ subtype int is Interfaces.C.int;
+ subtype long is Interfaces.C.long;
+
+ subtype LARGE_INTEGER is System.Win32.LARGE_INTEGER;
+
+ -------------------
+ -- General Types --
+ -------------------
+
+ subtype PSZ is Interfaces.C.Strings.chars_ptr;
+
+ Null_Void : constant Win32.PVOID := System.Null_Address;
+
+ -------------------------
+ -- Handles for objects --
+ -------------------------
+
+ subtype Thread_Id is Win32.HANDLE;
+
+ -----------
+ -- Errno --
+ -----------
+
+ NO_ERROR : constant := 0;
+ FUNC_ERR : constant := -1;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 31;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGINT : constant := 2; -- interrupt (Ctrl-C)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGFPE : constant := 8; -- floating point exception
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGBREAK : constant := 21; -- break (Ctrl-Break)
+ SIGABRT : constant := 22; -- used by abort, replace SIGIOT in the future
+
+ type sigset_t is private;
+
+ type isr_address is access procedure (sig : int);
+ pragma Convention (C, isr_address);
+
+ function intr_attach (sig : int; handler : isr_address) return long;
+ pragma Import (C, intr_attach, "signal");
+
+ Intr_Attach_Reset : constant Boolean := True;
+ -- True if intr_attach is reset after an interrupt handler is called
+
+ procedure kill (sig : Signal);
+ pragma Import (C, kill, "raise");
+
+ ------------
+ -- Clock --
+ ------------
+
+ procedure QueryPerformanceFrequency
+ (lpPerformanceFreq : access LARGE_INTEGER);
+ pragma Import
+ (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency");
+
+ -- According to the spec, on XP and later than function cannot fail,
+ -- so we ignore the return value and import it as a procedure.
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ procedure SwitchToThread;
+ pragma Import (Stdcall, SwitchToThread, "SwitchToThread");
+
+ function GetThreadTimes
+ (hThread : Win32.HANDLE;
+ lpCreationTime : access Long_Long_Integer;
+ lpExitTime : access Long_Long_Integer;
+ lpKernelTime : access Long_Long_Integer;
+ lpUserTime : access Long_Long_Integer) return Win32.BOOL;
+ pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes");
+
+ -----------------------
+ -- Critical sections --
+ -----------------------
+
+ type CRITICAL_SECTION is private;
+
+ -------------------------------------------------------------
+ -- Thread Creation, Activation, Suspension And Termination --
+ -------------------------------------------------------------
+
+ type PTHREAD_START_ROUTINE is access function
+ (pThreadParameter : Win32.PVOID) return Win32.DWORD;
+ pragma Convention (Stdcall, PTHREAD_START_ROUTINE);
+
+ function To_PTHREAD_START_ROUTINE is new
+ Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);
+
+ function CreateThread
+ (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
+ dwStackSize : Win32.DWORD;
+ pStartAddress : PTHREAD_START_ROUTINE;
+ pParameter : Win32.PVOID;
+ dwCreationFlags : Win32.DWORD;
+ pThreadId : access Win32.DWORD) return Win32.HANDLE;
+ pragma Import (Stdcall, CreateThread, "CreateThread");
+
+ function BeginThreadEx
+ (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
+ dwStackSize : Win32.DWORD;
+ pStartAddress : PTHREAD_START_ROUTINE;
+ pParameter : Win32.PVOID;
+ dwCreationFlags : Win32.DWORD;
+ pThreadId : not null access Win32.DWORD) return Win32.HANDLE;
+ pragma Import (C, BeginThreadEx, "_beginthreadex");
+
+ Debug_Process : constant := 16#00000001#;
+ Debug_Only_This_Process : constant := 16#00000002#;
+ Create_Suspended : constant := 16#00000004#;
+ Detached_Process : constant := 16#00000008#;
+ Create_New_Console : constant := 16#00000010#;
+
+ Create_New_Process_Group : constant := 16#00000200#;
+
+ Create_No_window : constant := 16#08000000#;
+
+ Profile_User : constant := 16#10000000#;
+ Profile_Kernel : constant := 16#20000000#;
+ Profile_Server : constant := 16#40000000#;
+
+ Stack_Size_Param_Is_A_Reservation : constant := 16#00010000#;
+
+ function GetExitCodeThread
+ (hThread : Win32.HANDLE;
+ pExitCode : not null access Win32.DWORD) return Win32.BOOL;
+ pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread");
+
+ function ResumeThread (hThread : Win32.HANDLE) return Win32.DWORD;
+ pragma Import (Stdcall, ResumeThread, "ResumeThread");
+
+ function SuspendThread (hThread : Win32.HANDLE) return Win32.DWORD;
+ pragma Import (Stdcall, SuspendThread, "SuspendThread");
+
+ procedure ExitThread (dwExitCode : Win32.DWORD);
+ pragma Import (Stdcall, ExitThread, "ExitThread");
+
+ procedure EndThreadEx (dwExitCode : Win32.DWORD);
+ pragma Import (C, EndThreadEx, "_endthreadex");
+
+ function TerminateThread
+ (hThread : Win32.HANDLE;
+ dwExitCode : Win32.DWORD) return Win32.BOOL;
+ pragma Import (Stdcall, TerminateThread, "TerminateThread");
+
+ function GetCurrentThread return Win32.HANDLE;
+ pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread");
+
+ function GetCurrentProcess return Win32.HANDLE;
+ pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess");
+
+ function GetCurrentThreadId return Win32.DWORD;
+ pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId");
+
+ function TlsAlloc return Win32.DWORD;
+ pragma Import (Stdcall, TlsAlloc, "TlsAlloc");
+
+ function TlsGetValue (dwTlsIndex : Win32.DWORD) return Win32.PVOID;
+ pragma Import (Stdcall, TlsGetValue, "TlsGetValue");
+
+ function TlsSetValue
+ (dwTlsIndex : Win32.DWORD; pTlsValue : Win32.PVOID) return Win32.BOOL;
+ pragma Import (Stdcall, TlsSetValue, "TlsSetValue");
+
+ function TlsFree (dwTlsIndex : Win32.DWORD) return Win32.BOOL;
+ pragma Import (Stdcall, TlsFree, "TlsFree");
+
+ TLS_Nothing : constant := Win32.DWORD'Last;
+
+ procedure ExitProcess (uExitCode : Interfaces.C.unsigned);
+ pragma Import (Stdcall, ExitProcess, "ExitProcess");
+
+ function WaitForSingleObject
+ (hHandle : Win32.HANDLE;
+ dwMilliseconds : Win32.DWORD) return Win32.DWORD;
+ pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject");
+
+ function WaitForSingleObjectEx
+ (hHandle : Win32.HANDLE;
+ dwMilliseconds : Win32.DWORD;
+ fAlertable : Win32.BOOL) return Win32.DWORD;
+ pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx");
+
+ Wait_Infinite : constant := Win32.DWORD'Last;
+ WAIT_TIMEOUT : constant := 16#0000_0102#;
+ WAIT_FAILED : constant := 16#FFFF_FFFF#;
+
+ ------------------------------------
+ -- Semaphores, Events and Mutexes --
+ ------------------------------------
+
+ function CreateSemaphore
+ (pSemaphoreAttributes : access Win32.SECURITY_ATTRIBUTES;
+ lInitialCount : Interfaces.C.long;
+ lMaximumCount : Interfaces.C.long;
+ pName : PSZ) return Win32.HANDLE;
+ pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA");
+
+ function OpenSemaphore
+ (dwDesiredAccess : Win32.DWORD;
+ bInheritHandle : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
+ pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA");
+
+ function ReleaseSemaphore
+ (hSemaphore : Win32.HANDLE;
+ lReleaseCount : Interfaces.C.long;
+ pPreviousCount : access Win32.LONG) return Win32.BOOL;
+ pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore");
+
+ function CreateEvent
+ (pEventAttributes : access Win32.SECURITY_ATTRIBUTES;
+ bManualReset : Win32.BOOL;
+ bInitialState : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
+ pragma Import (Stdcall, CreateEvent, "CreateEventA");
+
+ function OpenEvent
+ (dwDesiredAccess : Win32.DWORD;
+ bInheritHandle : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
+ pragma Import (Stdcall, OpenEvent, "OpenEventA");
+
+ function SetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
+ pragma Import (Stdcall, SetEvent, "SetEvent");
+
+ function ResetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
+ pragma Import (Stdcall, ResetEvent, "ResetEvent");
+
+ function PulseEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
+ pragma Import (Stdcall, PulseEvent, "PulseEvent");
+
+ function CreateMutex
+ (pMutexAttributes : access Win32.SECURITY_ATTRIBUTES;
+ bInitialOwner : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
+ pragma Import (Stdcall, CreateMutex, "CreateMutexA");
+
+ function OpenMutex
+ (dwDesiredAccess : Win32.DWORD;
+ bInheritHandle : Win32.BOOL;
+ pName : PSZ) return Win32.HANDLE;
+ pragma Import (Stdcall, OpenMutex, "OpenMutexA");
+
+ function ReleaseMutex (hMutex : Win32.HANDLE) return Win32.BOOL;
+ pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex");
+
+ ---------------------------------------------------
+ -- Accessing properties of Threads and Processes --
+ ---------------------------------------------------
+
+ -----------------
+ -- Priorities --
+ -----------------
+
+ function SetThreadPriority
+ (hThread : Win32.HANDLE;
+ nPriority : Interfaces.C.int) return Win32.BOOL;
+ pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority");
+
+ function GetThreadPriority (hThread : Win32.HANDLE) return Interfaces.C.int;
+ pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority");
+
+ function SetPriorityClass
+ (hProcess : Win32.HANDLE;
+ dwPriorityClass : Win32.DWORD) return Win32.BOOL;
+ pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass");
+
+ procedure SetThreadPriorityBoost
+ (hThread : Win32.HANDLE;
+ DisablePriorityBoost : Win32.BOOL);
+ pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost");
+
+ Normal_Priority_Class : constant := 16#00000020#;
+ Idle_Priority_Class : constant := 16#00000040#;
+ High_Priority_Class : constant := 16#00000080#;
+ Realtime_Priority_Class : constant := 16#00000100#;
+
+ Thread_Priority_Idle : constant := -15;
+ Thread_Priority_Lowest : constant := -2;
+ Thread_Priority_Below_Normal : constant := -1;
+ Thread_Priority_Normal : constant := 0;
+ Thread_Priority_Above_Normal : constant := 1;
+ Thread_Priority_Highest : constant := 2;
+ Thread_Priority_Time_Critical : constant := 15;
+ Thread_Priority_Error_Return : constant := Interfaces.C.long'Last;
+
+private
+
+ type sigset_t is new Interfaces.C.unsigned_long;
+
+ type CRITICAL_SECTION is record
+ DebugInfo : System.Address;
+
+ LockCount : Long_Integer;
+ RecursionCount : Long_Integer;
+ OwningThread : Win32.HANDLE;
+ -- The above three fields control entering and exiting the critical
+ -- section for the resource.
+
+ LockSemaphore : Win32.HANDLE;
+ SpinCount : Win32.DWORD;
+ end record;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for POSIX-like operating systems
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+with Interfaces.C; use Interfaces.C;
+package body System.OS_Interface is
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2009 Florida State University --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. It is --
+-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
+-- State University (http://www.gnat.com). --
+-- --
+-- The GNARL files that were developed for RTEMS are maintained by On-Line --
+-- Applications Research Corporation (http://www.oarcorp.com) in coopera- --
+-- tion with Ada Core Technologies Inc. and Florida State University. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the RTEMS version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+with Interfaces.C; use Interfaces.C;
+package body System.OS_Interface is
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to round-up, adjust for positive F value
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ -----------------
+ -- sigaltstack --
+ -----------------
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int is
+ pragma Unreferenced (ss);
+ pragma Unreferenced (oss);
+ begin
+ return 0;
+ end sigaltstack;
+
+ -----------------------------------
+ -- pthread_rwlockattr_setkind_np --
+ -----------------------------------
+
+ function pthread_rwlockattr_setkind_np
+ (attr : access pthread_rwlockattr_t;
+ pref : int) return int is
+ pragma Unreferenced (attr);
+ pragma Unreferenced (pref);
+ begin
+ return 0;
+ end pthread_rwlockattr_setkind_np;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1997-2016 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+-- The GNARL files that were developed for RTEMS are maintained by On-Line --
+-- Applications Research Corporation (http://www.oarcorp.com) in coopera- --
+-- tion with Ada Core Technologies Inc. and Florida State University. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the RTEMS version of this package.
+--
+-- RTEMS target names are of the form CPU-rtems.
+-- This implementation is designed to work on ALL RTEMS targets.
+-- The RTEMS implementation is primarily based upon the POSIX threads
+-- API but there are also bindings to GNAT/RTEMS support routines
+-- to insulate this code from C API specific details and, in some
+-- cases, obtain target architecture and BSP specific information
+-- that is unavailable at the time this package is built.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+-- PLEASE DO NOT add any with-clauses to this package
+-- or remove the pragma Preelaborate.
+-- It is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+with System.OS_Constants;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ -- This interface assumes that "unsigned" is a 32-bit entity. This
+ -- will correspond to RTEMS object ids.
+
+ subtype rtems_id is Interfaces.C.unsigned;
+
+ subtype int is Interfaces.C.int;
+ subtype char is Interfaces.C.char;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := System.OS_Constants.EAGAIN;
+ EINTR : constant := System.OS_Constants.EINTR;
+ EINVAL : constant := System.OS_Constants.EINVAL;
+ ENOMEM : constant := System.OS_Constants.ENOMEM;
+ ETIMEDOUT : constant := System.OS_Constants.ETIMEDOUT;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Num_HW_Interrupts : constant := 256;
+
+ Max_HW_Interrupt : constant := Num_HW_Interrupts - 1;
+ type HW_Interrupt is new int range 0 .. Max_HW_Interrupt;
+
+ Max_Interrupt : constant := Max_HW_Interrupt;
+
+ type Signal is new int range 0 .. Max_Interrupt;
+
+ SIGXCPU : constant := 0; -- XCPU
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+
+ SIGADAABORT : constant := SIGABRT;
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (SIGTRAP, SIGALRM, SIGEMT);
+ Reserved : constant Signal_Set := (1 .. 1 => SIGKILL);
+
+ type sigset_t is private;
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ type struct_sigaction is record
+ sa_flags : int;
+ sa_mask : sigset_t;
+ sa_handler : System.Address;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SA_SIGINFO : constant := 16#02#;
+
+ SA_ONSTACK : constant := 16#00#;
+ -- SA_ONSTACK is not defined on RTEMS, but it is referred to in the POSIX
+ -- implementation of System.Interrupt_Management. Therefore we define a
+ -- dummy value of zero here so that setting this flag is a nop.
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ Time_Slice_Supported : constant Boolean := True;
+ -- Indicates whether time slicing is supported (i.e SCHED_RR is supported)
+
+ type timespec is private;
+
+ type clockid_t is new int;
+
+ CLOCK_REALTIME : constant clockid_t;
+ CLOCK_MONOTONIC : constant clockid_t;
+
+ function clock_gettime
+ (clock_id : clockid_t;
+ tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ -------------------------
+ -- Priority Scheduling --
+ -------------------------
+
+ SCHED_FIFO : constant := 1;
+ SCHED_RR : constant := 2;
+ SCHED_OTHER : constant := 0;
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int;
+ -- Maps System.Any_Priority to a POSIX priority
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ ---------
+ -- LWP --
+ ---------
+
+ function lwp_self return System.Address;
+ -- lwp_self does not exist on this thread library, revert to pthread_self
+ -- which is the closest approximation (with getpid). This function is
+ -- needed to share 7staprop.adb across POSIX-like targets.
+ pragma Import (C, lwp_self, "pthread_self");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ type pthread_t is private;
+ subtype Thread_Id is pthread_t;
+
+ type pthread_mutex_t is limited private;
+ type pthread_rwlock_t is limited private;
+ type pthread_cond_t is limited private;
+ type pthread_attr_t is limited private;
+ type pthread_mutexattr_t is limited private;
+ type pthread_rwlockattr_t is limited private;
+ type pthread_condattr_t is limited private;
+ type pthread_key_t is private;
+
+ No_Key : constant pthread_key_t;
+
+ PTHREAD_CREATE_DETACHED : constant := 0;
+
+ PTHREAD_SCOPE_PROCESS : constant := 0;
+ PTHREAD_SCOPE_SYSTEM : constant := 1;
+
+ -----------
+ -- Stack --
+ -----------
+
+ type stack_t is record
+ ss_sp : System.Address;
+ ss_flags : int;
+ ss_size : size_t;
+ end record;
+ pragma Convention (C, stack_t);
+
+ function sigaltstack
+ (ss : not null access stack_t;
+ oss : access stack_t) return int;
+
+ Alternate_Stack : aliased System.Address;
+ -- This is a dummy definition, never used (Alternate_Stack_Size is null)
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+ Stack_Base_Available : constant Boolean := False;
+ -- Indicates whether the stack base is available on this target.
+ -- This allows us to share s-osinte.adb between all the FSU/RTEMS
+ -- run time.
+ -- Note that this value can only be true if pthread_t has a complete
+ -- definition that corresponds exactly to the C header files.
+
+ function Get_Stack_Base (thread : pthread_t) return Address;
+ pragma Inline (Get_Stack_Base);
+ -- returns the stack base of the specified thread.
+ -- Only call this function when Stack_Base_Available is True.
+
+ -- These two functions are only needed to share s-taprop.adb with
+ -- FSU threads.
+
+ function Get_Page_Size return int;
+ pragma Import (C, Get_Page_Size, "getpagesize");
+ -- Returns the size of a page
+
+ PROT_ON : constant := 0;
+ PROT_OFF : constant := 0;
+
+ function mprotect (addr : Address; len : size_t; prot : int) return int;
+ pragma Import (C, mprotect);
+
+ -----------------------------------------
+ -- Nonstandard Thread Initialization --
+ -----------------------------------------
+
+ procedure pthread_init;
+ -- FSU_THREADS requires pthread_init, which is nonstandard
+ -- and this should be invoked during the elaboration of s-taprop.adb
+ --
+ -- RTEMS does not require this so we provide an empty Ada body.
+
+ -------------------------
+ -- POSIX.1c Section 3 --
+ -------------------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal) return int;
+ pragma Import (C, sigwait, "sigwait");
+
+ function pthread_kill
+ (thread : pthread_t;
+ sig : Signal) return int;
+ pragma Import (C, pthread_kill, "pthread_kill");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+
+ ----------------------------
+ -- POSIX.1c Section 11 --
+ ----------------------------
+
+ function pthread_mutexattr_init
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
+
+ function pthread_mutexattr_destroy
+ (attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
+
+ function pthread_mutex_init
+ (mutex : access pthread_mutex_t;
+ attr : access pthread_mutexattr_t) return int;
+ pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
+
+ function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
+
+ function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
+
+ function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
+
+ function pthread_rwlockattr_init
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init");
+
+ function pthread_rwlockattr_destroy
+ (attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy");
+
+ PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0;
+ PTHREAD_RWLOCK_PREFER_WRITER_NP : constant := 1;
+ PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 2;
+
+ function pthread_rwlockattr_setkind_np
+ (attr : access pthread_rwlockattr_t;
+ pref : int) return int;
+
+ function pthread_rwlock_init
+ (mutex : access pthread_rwlock_t;
+ attr : access pthread_rwlockattr_t) return int;
+ pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init");
+
+ function pthread_rwlock_destroy
+ (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy");
+
+ function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock");
+
+ function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock");
+
+ function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int;
+ pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_unlock");
+
+ function pthread_condattr_init
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
+
+ function pthread_condattr_destroy
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
+
+ function pthread_cond_init
+ (cond : access pthread_cond_t;
+ attr : access pthread_condattr_t) return int;
+ pragma Import (C, pthread_cond_init, "pthread_cond_init");
+
+ function pthread_cond_destroy (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
+
+ function pthread_cond_signal (cond : access pthread_cond_t) return int;
+ pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
+
+ function pthread_cond_wait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t) return int;
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
+
+ function pthread_cond_timedwait
+ (cond : access pthread_cond_t;
+ mutex : access pthread_mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
+
+ Relative_Timed_Wait : constant Boolean := False;
+ -- pthread_cond_timedwait requires an absolute delay time
+
+ --------------------------
+ -- POSIX.1c Section 13 --
+ --------------------------
+
+ PTHREAD_PRIO_NONE : constant := 0;
+ PTHREAD_PRIO_PROTECT : constant := 2;
+ PTHREAD_PRIO_INHERIT : constant := 1;
+
+ function pthread_mutexattr_setprotocol
+ (attr : access pthread_mutexattr_t;
+ protocol : int) return int;
+ pragma Import (C, pthread_mutexattr_setprotocol);
+
+ function pthread_mutexattr_setprioceiling
+ (attr : access pthread_mutexattr_t;
+ prioceiling : int) return int;
+ pragma Import
+ (C, pthread_mutexattr_setprioceiling,
+ "pthread_mutexattr_setprioceiling");
+
+ type struct_sched_param is record
+ sched_priority : int;
+ ss_low_priority : int;
+ ss_replenish_period : timespec;
+ ss_initial_budget : timespec;
+ sched_ss_max_repl : int;
+ end record;
+ pragma Convention (C, struct_sched_param);
+
+ function pthread_setschedparam
+ (thread : pthread_t;
+ policy : int;
+ param : access struct_sched_param) return int;
+ pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
+
+ function pthread_attr_setscope
+ (attr : access pthread_attr_t;
+ contentionscope : int) return int;
+ pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
+
+ function pthread_attr_setinheritsched
+ (attr : access pthread_attr_t;
+ inheritsched : int) return int;
+ pragma Import (C, pthread_attr_setinheritsched);
+
+ function pthread_attr_setschedpolicy
+ (attr : access pthread_attr_t;
+ policy : int) return int;
+ pragma Import (C, pthread_attr_setschedpolicy);
+
+ function pthread_attr_setschedparam
+ (attr : access pthread_attr_t;
+ sched_param : int) return int;
+ pragma Import (C, pthread_attr_setschedparam);
+
+ function sched_yield return int;
+ pragma Import (C, sched_yield, "sched_yield");
+
+ ---------------------------
+ -- P1003.1c - Section 16 --
+ ---------------------------
+
+ function pthread_attr_init (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_init, "pthread_attr_init");
+
+ function pthread_attr_destroy
+ (attributes : access pthread_attr_t) return int;
+ pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
+
+ function pthread_attr_setdetachstate
+ (attr : access pthread_attr_t;
+ detachstate : int) return int;
+ pragma Import (C, pthread_attr_setdetachstate);
+
+ function pthread_attr_setstacksize
+ (attr : access pthread_attr_t;
+ stacksize : size_t) return int;
+ pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
+
+ function pthread_create
+ (thread : access pthread_t;
+ attributes : access pthread_attr_t;
+ start_routine : Thread_Body;
+ arg : System.Address) return int;
+ pragma Import (C, pthread_create, "pthread_create");
+
+ procedure pthread_exit (status : System.Address);
+ pragma Import (C, pthread_exit, "pthread_exit");
+
+ function pthread_self return pthread_t;
+ pragma Import (C, pthread_self, "pthread_self");
+
+ --------------------------
+ -- POSIX.1c Section 17 --
+ --------------------------
+
+ function pthread_setspecific
+ (key : pthread_key_t;
+ value : System.Address) return int;
+ pragma Import (C, pthread_setspecific, "pthread_setspecific");
+
+ function pthread_getspecific (key : pthread_key_t) return System.Address;
+ pragma Import (C, pthread_getspecific, "pthread_getspecific");
+
+ type destructor_pointer is access procedure (arg : System.Address);
+ pragma Convention (C, destructor_pointer);
+
+ function pthread_key_create
+ (key : access pthread_key_t;
+ destructor : destructor_pointer) return int;
+ pragma Import (C, pthread_key_create, "pthread_key_create");
+
+ ------------------------------------------------------------
+ -- Binary Semaphore Wrapper to Support Interrupt Tasks --
+ ------------------------------------------------------------
+
+ type Binary_Semaphore_Id is new rtems_id;
+
+ function Binary_Semaphore_Create return Binary_Semaphore_Id;
+ pragma Import (
+ C,
+ Binary_Semaphore_Create,
+ "__gnat_binary_semaphore_create");
+
+ function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int;
+ pragma Import (
+ C,
+ Binary_Semaphore_Delete,
+ "__gnat_binary_semaphore_delete");
+
+ function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int;
+ pragma Import (
+ C,
+ Binary_Semaphore_Obtain,
+ "__gnat_binary_semaphore_obtain");
+
+ function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int;
+ pragma Import (
+ C,
+ Binary_Semaphore_Release,
+ "__gnat_binary_semaphore_release");
+
+ function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int;
+ pragma Import (
+ C,
+ Binary_Semaphore_Flush,
+ "__gnat_binary_semaphore_flush");
+
+ ------------------------------------------------------------
+ -- Hardware Interrupt Wrappers to Support Interrupt Tasks --
+ ------------------------------------------------------------
+
+ type Interrupt_Handler is access procedure (parameter : System.Address);
+ pragma Convention (C, Interrupt_Handler);
+ type Interrupt_Vector is new System.Address;
+
+ function Interrupt_Connect
+ (vector : Interrupt_Vector;
+ handler : Interrupt_Handler;
+ parameter : System.Address := System.Null_Address) return int;
+ pragma Import (C, Interrupt_Connect, "__gnat_interrupt_connect");
+ -- Use this to set up an user handler. The routine installs a
+ -- a user handler which is invoked after RTEMS has saved enough
+ -- context for a high-level language routine to be safely invoked.
+
+ function Interrupt_Vector_Get
+ (Vector : Interrupt_Vector) return Interrupt_Handler;
+ pragma Import (C, Interrupt_Vector_Get, "__gnat_interrupt_get");
+ -- Use this to get the existing handler for later restoral.
+
+ procedure Interrupt_Vector_Set
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler);
+ pragma Import (C, Interrupt_Vector_Set, "__gnat_interrupt_set");
+ -- Use this to restore a handler obtained using Interrupt_Vector_Get.
+
+ function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector;
+ -- Convert a logical interrupt number to the hardware interrupt vector
+ -- number used to connect the interrupt.
+ pragma Import (
+ C,
+ Interrupt_Number_To_Vector,
+ "__gnat_interrupt_number_to_vector"
+ );
+
+private
+
+ type sigset_t is new int;
+
+ type pid_t is new int;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ CLOCK_REALTIME : constant clockid_t := System.OS_Constants.CLOCK_REALTIME;
+ CLOCK_MONOTONIC : constant clockid_t := System.OS_Constants.CLOCK_MONOTONIC;
+
+ subtype char_array is Interfaces.C.char_array;
+
+ type pthread_attr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_ATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_attr_t);
+ for pthread_attr_t'Alignment use Interfaces.C.double'Alignment;
+
+ type pthread_condattr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_CONDATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_condattr_t);
+ for pthread_condattr_t'Alignment use Interfaces.C.double'Alignment;
+
+ type pthread_mutexattr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_MUTEXATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_mutexattr_t);
+ for pthread_mutexattr_t'Alignment use Interfaces.C.double'Alignment;
+
+ type pthread_rwlockattr_t is record
+ Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCKATTR_SIZE);
+ end record;
+ pragma Convention (C, pthread_rwlockattr_t);
+ for pthread_rwlockattr_t'Alignment use Interfaces.C.double'Alignment;
+
+ type pthread_t is new rtems_id;
+
+ type pthread_mutex_t is new rtems_id;
+
+ type pthread_rwlock_t is new rtems_id;
+
+ type pthread_cond_t is new rtems_id;
+
+ type pthread_key_t is new rtems_id;
+
+ No_Key : constant pthread_key_t := 0;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris version of this package
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+with Interfaces.C; use Interfaces.C;
+
+package body System.OS_Interface is
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris (native) version of this package
+
+-- This package includes all direct interfaces to OS services
+-- that are needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+
+with Ada.Unchecked_Conversion;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ pragma Linker_Options ("-lposix4");
+ pragma Linker_Options ("-lthread");
+
+ subtype int is Interfaces.C.int;
+ subtype short is Interfaces.C.short;
+ subtype long is Interfaces.C.long;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype unsigned_short is Interfaces.C.unsigned_short;
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+ subtype plain_char is Interfaces.C.plain_char;
+ subtype size_t is Interfaces.C.size_t;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "__get_errno");
+
+ EAGAIN : constant := 11;
+ EINTR : constant := 4;
+ EINVAL : constant := 22;
+ ENOMEM : constant := 12;
+ ETIME : constant := 62;
+ ETIMEDOUT : constant := 145;
+
+ -------------
+ -- Signals --
+ -------------
+
+ Max_Interrupt : constant := 45;
+ type Signal is new int range 0 .. Max_Interrupt;
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGWINCH : constant := 20; -- window size change
+ SIGURG : constant := 21; -- urgent condition on IO channel
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias)
+ SIGSTOP : constant := 23; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 24; -- user stop requested from tty
+ SIGCONT : constant := 25; -- stopped process has been continued
+ SIGTTIN : constant := 26; -- background tty read attempted
+ SIGTTOU : constant := 27; -- background tty write attempted
+ SIGVTALRM : constant := 28; -- virtual timer expired
+ SIGPROF : constant := 29; -- profiling timer expired
+ SIGXCPU : constant := 30; -- CPU time limit exceeded
+ SIGXFSZ : constant := 31; -- filesize limit exceeded
+ SIGWAITING : constant := 32; -- process's lwps blocked (Solaris)
+ SIGLWP : constant := 33; -- used by thread library (Solaris)
+ SIGFREEZE : constant := 34; -- used by CPR (Solaris)
+ SIGTHAW : constant := 35; -- used by CPR (Solaris)
+ SIGCANCEL : constant := 36; -- thread cancellation signal (libthread)
+
+ type Signal_Set is array (Natural range <>) of Signal;
+
+ Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF);
+
+ -- Following signals should not be disturbed.
+ -- See c-posix-signals.c in FLORIST.
+
+ Reserved : constant Signal_Set :=
+ (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL, SIGTRAP, SIGSEGV);
+
+ type sigset_t is private;
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ type union_type_3 is new String (1 .. 116);
+ type siginfo_t is record
+ si_signo : int;
+ si_code : int;
+ si_errno : int;
+ X_data : union_type_3;
+ end record;
+ pragma Convention (C, siginfo_t);
+
+ -- The types mcontext_t and gregset_t are part of the ucontext_t
+ -- information, which is specific to Solaris2.4 for SPARC
+ -- The ucontext_t info seems to be used by the handler
+ -- for SIGSEGV to decide whether it is a Storage_Error (stack overflow) or
+ -- a Constraint_Error (bad pointer). The original code that did this
+ -- is suspect, so it is not clear whether we really need this part of
+ -- the signal context information, or perhaps something else.
+ -- More analysis is needed, after which these declarations may need to
+ -- be changed.
+
+ type greg_t is new int;
+
+ type gregset_t is array (0 .. 18) of greg_t;
+
+ type union_type_2 is new String (1 .. 128);
+ type record_type_1 is record
+ fpu_fr : union_type_2;
+ fpu_q : System.Address;
+ fpu_fsr : unsigned;
+ fpu_qcnt : unsigned_char;
+ fpu_q_entrysize : unsigned_char;
+ fpu_en : unsigned_char;
+ end record;
+ pragma Convention (C, record_type_1);
+
+ type array_type_7 is array (Integer range 0 .. 20) of long;
+ type mcontext_t is record
+ gregs : gregset_t;
+ gwins : System.Address;
+ fpregs : record_type_1;
+ filler : array_type_7;
+ end record;
+ pragma Convention (C, mcontext_t);
+
+ type record_type_2 is record
+ ss_sp : System.Address;
+ ss_size : int;
+ ss_flags : int;
+ end record;
+ pragma Convention (C, record_type_2);
+
+ type array_type_8 is array (Integer range 0 .. 22) of long;
+ type ucontext_t is record
+ uc_flags : unsigned_long;
+ uc_link : System.Address;
+ uc_sigmask : sigset_t;
+ uc_stack : record_type_2;
+ uc_mcontext : mcontext_t;
+ uc_filler : array_type_8;
+ end record;
+ pragma Convention (C, ucontext_t);
+
+ type Signal_Handler is access procedure
+ (signo : Signal;
+ info : access siginfo_t;
+ context : access ucontext_t);
+
+ type union_type_1 is new plain_char;
+ type array_type_2 is array (Integer range 0 .. 1) of int;
+ type struct_sigaction is record
+ sa_flags : int;
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_resv : array_type_2;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ ----------
+ -- Time --
+ ----------
+
+ type timespec is private;
+
+ type clockid_t is new int;
+
+ function clock_gettime
+ (clock_id : clockid_t; tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ function clock_getres
+ (clock_id : clockid_t; res : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+
+ -------------
+ -- Process --
+ -------------
+
+ type pid_t is private;
+
+ function kill (pid : pid_t; sig : Signal) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return pid_t;
+ pragma Import (C, getpid, "getpid");
+
+ -------------
+ -- Threads --
+ -------------
+
+ type Thread_Body is access
+ function (arg : System.Address) return System.Address;
+ pragma Convention (C, Thread_Body);
+
+ function Thread_Body_Access is new
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ THR_DETACHED : constant := 64;
+ THR_BOUND : constant := 1;
+ THR_NEW_LWP : constant := 2;
+ USYNC_THREAD : constant := 0;
+
+ type thread_t is new unsigned;
+ subtype Thread_Id is thread_t;
+ -- These types should be commented ???
+
+ function To_thread_t is new Ada.Unchecked_Conversion (Integer, thread_t);
+
+ type mutex_t is limited private;
+
+ type cond_t is limited private;
+
+ type thread_key_t is private;
+
+ function thr_create
+ (stack_base : System.Address;
+ stack_size : size_t;
+ start_routine : Thread_Body;
+ arg : System.Address;
+ flags : int;
+ new_thread : access thread_t) return int;
+ pragma Import (C, thr_create, "thr_create");
+
+ function thr_min_stack return size_t;
+ pragma Import (C, thr_min_stack, "thr_min_stack");
+
+ function thr_self return thread_t;
+ pragma Import (C, thr_self, "thr_self");
+
+ function mutex_init
+ (mutex : access mutex_t;
+ mtype : int;
+ arg : System.Address) return int;
+ pragma Import (C, mutex_init, "mutex_init");
+
+ function mutex_destroy (mutex : access mutex_t) return int;
+ pragma Import (C, mutex_destroy, "mutex_destroy");
+
+ function mutex_lock (mutex : access mutex_t) return int;
+ pragma Import (C, mutex_lock, "mutex_lock");
+
+ function mutex_unlock (mutex : access mutex_t) return int;
+ pragma Import (C, mutex_unlock, "mutex_unlock");
+
+ function cond_init
+ (cond : access cond_t;
+ ctype : int;
+ arg : int) return int;
+ pragma Import (C, cond_init, "cond_init");
+
+ function cond_wait
+ (cond : access cond_t; mutex : access mutex_t) return int;
+ pragma Import (C, cond_wait, "cond_wait");
+
+ function cond_timedwait
+ (cond : access cond_t;
+ mutex : access mutex_t;
+ abstime : access timespec) return int;
+ pragma Import (C, cond_timedwait, "cond_timedwait");
+
+ function cond_signal (cond : access cond_t) return int;
+ pragma Import (C, cond_signal, "cond_signal");
+
+ function cond_destroy (cond : access cond_t) return int;
+ pragma Import (C, cond_destroy, "cond_destroy");
+
+ function thr_setspecific
+ (key : thread_key_t; value : System.Address) return int;
+ pragma Import (C, thr_setspecific, "thr_setspecific");
+
+ function thr_getspecific
+ (key : thread_key_t;
+ value : access System.Address) return int;
+ pragma Import (C, thr_getspecific, "thr_getspecific");
+
+ function thr_keycreate
+ (key : access thread_key_t; destructor : System.Address) return int;
+ pragma Import (C, thr_keycreate, "thr_keycreate");
+
+ function thr_setprio (thread : thread_t; priority : int) return int;
+ pragma Import (C, thr_setprio, "thr_setprio");
+
+ procedure thr_exit (status : System.Address);
+ pragma Import (C, thr_exit, "thr_exit");
+
+ function thr_setconcurrency (new_level : int) return int;
+ pragma Import (C, thr_setconcurrency, "thr_setconcurrency");
+
+ function sigwait (set : access sigset_t; sig : access Signal) return int;
+ pragma Import (C, sigwait, "__posix_sigwait");
+
+ function thr_kill (thread : thread_t; sig : Signal) return int;
+ pragma Import (C, thr_kill, "thr_kill");
+
+ function thr_sigsetmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, thr_sigsetmask, "thr_sigsetmask");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "thr_sigsetmask");
+
+ function thr_suspend (target_thread : thread_t) return int;
+ pragma Import (C, thr_suspend, "thr_suspend");
+
+ function thr_continue (target_thread : thread_t) return int;
+ pragma Import (C, thr_continue, "thr_continue");
+
+ procedure thr_yield;
+ pragma Import (C, thr_yield, "thr_yield");
+
+ ---------
+ -- LWP --
+ ---------
+
+ P_PID : constant := 0;
+ P_LWPID : constant := 8;
+
+ PC_GETCID : constant := 0;
+ PC_GETCLINFO : constant := 1;
+ PC_SETPARMS : constant := 2;
+ PC_GETPARMS : constant := 3;
+ PC_ADMIN : constant := 4;
+
+ PC_CLNULL : constant := -1;
+
+ RT_NOCHANGE : constant := -1;
+ RT_TQINF : constant := -2;
+ RT_TQDEF : constant := -3;
+
+ PC_CLNMSZ : constant := 16;
+
+ PC_VERSION : constant := 1;
+
+ type lwpid_t is new int;
+
+ type pri_t is new short;
+
+ type id_t is new long;
+
+ P_MYID : constant := -1;
+ -- The specified LWP or process is the current one
+
+ type struct_pcinfo is record
+ pc_cid : id_t;
+ pc_clname : String (1 .. PC_CLNMSZ);
+ rt_maxpri : short;
+ end record;
+ pragma Convention (C, struct_pcinfo);
+
+ type struct_pcparms is record
+ pc_cid : id_t;
+ rt_pri : pri_t;
+ rt_tqsecs : long;
+ rt_tqnsecs : long;
+ end record;
+ pragma Convention (C, struct_pcparms);
+
+ function priocntl
+ (ver : int;
+ id_type : int;
+ id : lwpid_t;
+ cmd : int;
+ arg : System.Address) return Interfaces.C.long;
+ pragma Import (C, priocntl, "__priocntl");
+
+ function lwp_self return lwpid_t;
+ pragma Import (C, lwp_self, "_lwp_self");
+
+ type processorid_t is new int;
+ type processorid_t_ptr is access all processorid_t;
+
+ -- Constants for function processor_bind
+
+ PBIND_QUERY : constant processorid_t := -2;
+ -- The processor bindings are not changed
+
+ PBIND_NONE : constant processorid_t := -1;
+ -- The processor bindings of the specified LWPs are cleared
+
+ -- Flags for function p_online
+
+ PR_OFFLINE : constant int := 1;
+ -- Processor is offline, as quiet as possible
+
+ PR_ONLINE : constant int := 2;
+ -- Processor online
+
+ PR_STATUS : constant int := 3;
+ -- Value passed to p_online to request status
+
+ function p_online (processorid : processorid_t; flag : int) return int;
+ pragma Import (C, p_online, "p_online");
+
+ function processor_bind
+ (id_type : int;
+ id : id_t;
+ proc_id : processorid_t;
+ obind : processorid_t_ptr) return int;
+ pragma Import (C, processor_bind, "processor_bind");
+
+ type psetid_t is new int;
+
+ function pset_create (pset : access psetid_t) return int;
+ pragma Import (C, pset_create, "pset_create");
+
+ function pset_assign
+ (pset : psetid_t;
+ proc_id : processorid_t;
+ opset : access psetid_t) return int;
+ pragma Import (C, pset_assign, "pset_assign");
+
+ function pset_bind
+ (pset : psetid_t;
+ id_type : int;
+ id : id_t;
+ opset : access psetid_t) return int;
+ pragma Import (C, pset_bind, "pset_bind");
+
+ procedure pthread_init;
+ -- Dummy procedure to share s-intman.adb with other Solaris targets
+
+private
+
+ type array_type_1 is array (0 .. 3) of unsigned_long;
+ type sigset_t is record
+ X_X_sigbits : array_type_1;
+ end record;
+ pragma Convention (C, sigset_t);
+
+ type pid_t is new long;
+
+ type time_t is new long;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type array_type_9 is array (0 .. 3) of unsigned_char;
+ type record_type_3 is record
+ flag : array_type_9;
+ Xtype : unsigned_long;
+ end record;
+ pragma Convention (C, record_type_3);
+
+ type mutex_t is record
+ flags : record_type_3;
+ lock : String (1 .. 8);
+ data : String (1 .. 8);
+ end record;
+ pragma Convention (C, mutex_t);
+
+ type cond_t is record
+ flag : array_type_9;
+ Xtype : unsigned_long;
+ data : String (1 .. 8);
+ end record;
+ pragma Convention (C, cond_t);
+
+ type thread_key_t is new unsigned;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1997-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks version
+
+-- This package encapsulates all direct interfaces to OS services that are
+-- needed by children of System.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+package body System.OS_Interface is
+
+ use type Interfaces.C.int;
+
+ Low_Priority : constant := 255;
+ -- VxWorks native (default) lowest scheduling priority
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
+ end To_Duration;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F is negative due to a round-up, adjust for positive F value
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(ts_sec => S,
+ ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ -------------------------
+ -- To_VxWorks_Priority --
+ -------------------------
+
+ function To_VxWorks_Priority (Priority : int) return int is
+ begin
+ return Low_Priority - Priority;
+ end To_VxWorks_Priority;
+
+ --------------------
+ -- To_Clock_Ticks --
+ --------------------
+
+ -- ??? - For now, we'll always get the system clock rate since it is
+ -- allowed to be changed during run-time in VxWorks. A better method would
+ -- be to provide an operation to set it that so we can always know its
+ -- value.
+
+ -- Another thing we should probably allow for is a resultant tick count
+ -- greater than int'Last. This should probably be a procedure with two
+ -- output parameters, one in the range 0 .. int'Last, and another
+ -- representing the overflow count.
+
+ function To_Clock_Ticks (D : Duration) return int is
+ Ticks : Long_Long_Integer;
+ Rate_Duration : Duration;
+ Ticks_Duration : Duration;
+
+ begin
+ if D < 0.0 then
+ return ERROR;
+ end if;
+
+ -- Ensure that the duration can be converted to ticks
+ -- at the current clock tick rate without overflowing.
+
+ Rate_Duration := Duration (sysClkRateGet);
+
+ if D > (Duration'Last / Rate_Duration) then
+ Ticks := Long_Long_Integer (int'Last);
+ else
+ Ticks_Duration := D * Rate_Duration;
+ Ticks := Long_Long_Integer (Ticks_Duration);
+
+ if Ticks_Duration > Duration (Ticks) then
+ Ticks := Ticks + 1;
+ end if;
+
+ if Ticks > Long_Long_Integer (int'Last) then
+ Ticks := Long_Long_Integer (int'Last);
+ end if;
+ end if;
+
+ return int (Ticks);
+ end To_Clock_Ticks;
+
+ -----------------------------
+ -- Binary_Semaphore_Create --
+ -----------------------------
+
+ function Binary_Semaphore_Create return Binary_Semaphore_Id is
+ begin
+ return Binary_Semaphore_Id (semBCreate (SEM_Q_FIFO, SEM_EMPTY));
+ end Binary_Semaphore_Create;
+
+ -----------------------------
+ -- Binary_Semaphore_Delete --
+ -----------------------------
+
+ function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int is
+ begin
+ return semDelete (SEM_ID (ID));
+ end Binary_Semaphore_Delete;
+
+ -----------------------------
+ -- Binary_Semaphore_Obtain --
+ -----------------------------
+
+ function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int is
+ begin
+ return semTake (SEM_ID (ID), WAIT_FOREVER);
+ end Binary_Semaphore_Obtain;
+
+ ------------------------------
+ -- Binary_Semaphore_Release --
+ ------------------------------
+
+ function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int is
+ begin
+ return semGive (SEM_ID (ID));
+ end Binary_Semaphore_Release;
+
+ ----------------------------
+ -- Binary_Semaphore_Flush --
+ ----------------------------
+
+ function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int is
+ begin
+ return semFlush (SEM_ID (ID));
+ end Binary_Semaphore_Flush;
+
+ ----------
+ -- kill --
+ ----------
+
+ function kill (pid : t_id; sig : Signal) return int is
+ begin
+ return System.VxWorks.Ext.kill (pid, int (sig));
+ end kill;
+
+ -----------------------
+ -- Interrupt_Connect --
+ -----------------------
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int is
+ begin
+ return
+ System.VxWorks.Ext.Interrupt_Connect
+ (System.VxWorks.Ext.Interrupt_Vector (Vector),
+ System.VxWorks.Ext.Interrupt_Handler (Handler),
+ Parameter);
+ end Interrupt_Connect;
+
+ -----------------------
+ -- Interrupt_Context --
+ -----------------------
+
+ function Interrupt_Context return int is
+ begin
+ return System.VxWorks.Ext.Interrupt_Context;
+ end Interrupt_Context;
+
+ --------------------------------
+ -- Interrupt_Number_To_Vector --
+ --------------------------------
+
+ function Interrupt_Number_To_Vector
+ (intNum : int) return Interrupt_Vector
+ is
+ begin
+ return Interrupt_Vector
+ (System.VxWorks.Ext.Interrupt_Number_To_Vector (intNum));
+ end Interrupt_Number_To_Vector;
+
+ -----------------
+ -- Current_CPU --
+ -----------------
+
+ function Current_CPU return Multiprocessors.CPU is
+ begin
+ -- ??? Should use vxworks multiprocessor interface
+
+ return Multiprocessors.CPU'First;
+ end Current_CPU;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks version of this package
+
+-- This package encapsulates all direct interfaces to OS services that are
+-- needed by the tasking run-time (libgnarl).
+
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
+
+with Interfaces.C;
+with System.VxWorks;
+with System.VxWorks.Ext;
+with System.Multiprocessors;
+
+package System.OS_Interface is
+ pragma Preelaborate;
+
+ subtype int is Interfaces.C.int;
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype short is Short_Integer;
+ type unsigned_int is mod 2 ** int'Size;
+ type long is new Long_Integer;
+ type unsigned_long is mod 2 ** long'Size;
+ type long_long is new Long_Long_Integer;
+ type unsigned_long_long is mod 2 ** long_long'Size;
+ type size_t is mod 2 ** Standard'Address_Size;
+
+ -----------
+ -- Errno --
+ -----------
+
+ function errno return int;
+ pragma Import (C, errno, "errnoGet");
+
+ EINTR : constant := 4;
+ EAGAIN : constant := 35;
+ ENOMEM : constant := 12;
+ EINVAL : constant := 22;
+ ETIMEDOUT : constant := 60;
+
+ FUNC_ERR : constant := -1;
+
+ ----------------------------
+ -- Signals and interrupts --
+ ----------------------------
+
+ NSIG : constant := 64;
+ -- Number of signals on the target OS
+ type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
+
+ Max_HW_Interrupt : constant := System.VxWorks.Num_HW_Interrupts - 1;
+ type HW_Interrupt is new int range 0 .. Max_HW_Interrupt;
+
+ Max_Interrupt : constant := Max_HW_Interrupt;
+ subtype Interrupt_Range is Natural range 0 .. Max_HW_Interrupt;
+ -- For s-interr
+
+ -- Signals common to Vxworks 5.x and 6.x
+
+ SIGILL : constant := 4; -- illegal instruction (not reset when caught)
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGFPE : constant := 8; -- floating point exception
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+
+ -- Signals specific to VxWorks 6.x
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt
+ SIGQUIT : constant := 3; -- quit
+ SIGTRAP : constant := 5; -- trace trap (not reset when caught)
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGKILL : constant := 9; -- kill
+ SIGFMT : constant := 12; -- STACK FORMAT ERROR (not posix)
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGCNCL : constant := 16; -- pthreads cancellation signal
+ SIGSTOP : constant := 17; -- sendable stop signal not from tty
+ SIGTSTP : constant := 18; -- stop signal from tty
+ SIGCONT : constant := 19; -- continue a stopped process
+ SIGCHLD : constant := 20; -- to parent on child stop or exit
+ SIGTTIN : constant := 21; -- to readers pgrp upon background tty read
+ SIGTTOU : constant := 22; -- like TTIN for output
+
+ SIGRES1 : constant := 23; -- reserved signal number (Not POSIX)
+ SIGRES2 : constant := 24; -- reserved signal number (Not POSIX)
+ SIGRES3 : constant := 25; -- reserved signal number (Not POSIX)
+ SIGRES4 : constant := 26; -- reserved signal number (Not POSIX)
+ SIGRES5 : constant := 27; -- reserved signal number (Not POSIX)
+ SIGRES6 : constant := 28; -- reserved signal number (Not POSIX)
+ SIGRES7 : constant := 29; -- reserved signal number (Not POSIX)
+
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGPOLL : constant := 32; -- pollable event
+ SIGPROF : constant := 33; -- profiling timer expired
+ SIGSYS : constant := 34; -- bad system call
+ SIGURG : constant := 35; -- high bandwidth data is available at socket
+ SIGVTALRM : constant := 36; -- virtual timer expired
+ SIGXCPU : constant := 37; -- CPU time limit exceeded
+ SIGXFSZ : constant := 38; -- file size time limit exceeded
+
+ SIGEVTS : constant := 39; -- signal event thread send
+ SIGEVTD : constant := 40; -- signal event thread delete
+
+ SIGRTMIN : constant := 48; -- Realtime signal min
+ SIGRTMAX : constant := 63; -- Realtime signal max
+
+ -----------------------------------
+ -- Signal processing definitions --
+ -----------------------------------
+
+ -- The how in sigprocmask()
+
+ SIG_BLOCK : constant := 1;
+ SIG_UNBLOCK : constant := 2;
+ SIG_SETMASK : constant := 3;
+
+ -- The sa_flags in struct sigaction
+
+ SA_SIGINFO : constant := 16#0002#;
+ SA_ONSTACK : constant := 16#0004#;
+
+ SIG_DFL : constant := 0;
+ SIG_IGN : constant := 1;
+
+ type sigset_t is private;
+
+ type struct_sigaction is record
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
+ end record;
+ pragma Convention (C, struct_sigaction);
+ type struct_sigaction_ptr is access all struct_sigaction;
+
+ function sigaddset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigaddset, "sigaddset");
+
+ function sigdelset (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigdelset, "sigdelset");
+
+ function sigfillset (set : access sigset_t) return int;
+ pragma Import (C, sigfillset, "sigfillset");
+
+ function sigismember (set : access sigset_t; sig : Signal) return int;
+ pragma Import (C, sigismember, "sigismember");
+
+ function sigemptyset (set : access sigset_t) return int;
+ pragma Import (C, sigemptyset, "sigemptyset");
+
+ function sigaction
+ (sig : Signal;
+ act : struct_sigaction_ptr;
+ oact : struct_sigaction_ptr) return int;
+ pragma Import (C, sigaction, "sigaction");
+
+ type isr_address is access procedure (sig : int);
+ pragma Convention (C, isr_address);
+
+ function c_signal (sig : Signal; handler : isr_address) return isr_address;
+ pragma Import (C, c_signal, "signal");
+
+ function pthread_sigmask
+ (how : int;
+ set : access sigset_t;
+ oset : access sigset_t) return int;
+ pragma Import (C, pthread_sigmask, "sigprocmask");
+
+ subtype t_id is System.VxWorks.Ext.t_id;
+ subtype Thread_Id is t_id;
+ -- Thread_Id and t_id are VxWorks identifiers for tasks. This value,
+ -- although represented as a Long_Integer, is in fact an address. With
+ -- some BSPs, this address can have a value sufficiently high that the
+ -- Thread_Id becomes negative: this should not be considered as an error.
+
+ function kill (pid : t_id; sig : Signal) return int;
+ pragma Inline (kill);
+
+ function getpid return t_id renames System.VxWorks.Ext.getpid;
+
+ function Task_Stop (tid : t_id) return int
+ renames System.VxWorks.Ext.Task_Stop;
+ -- If we are in the kernel space, stop the task whose t_id is given in
+ -- parameter in such a way that it can be examined by the debugger. This
+ -- typically maps to taskSuspend on VxWorks 5 and to taskStop on VxWorks 6.
+
+ function Task_Cont (tid : t_id) return int
+ renames System.VxWorks.Ext.Task_Cont;
+ -- If we are in the kernel space, continue the task whose t_id is given
+ -- in parameter if it has been stopped previously to be examined by the
+ -- debugger (e.g. by taskStop). It typically maps to taskResume on VxWorks
+ -- 5 and to taskCont on VxWorks 6.
+
+ function Int_Lock return int renames System.VxWorks.Ext.Int_Lock;
+ -- If we are in the kernel space, lock interrupts. It typically maps to
+ -- intLock.
+
+ function Int_Unlock (Old : int) return int
+ renames System.VxWorks.Ext.Int_Unlock;
+ -- If we are in the kernel space, unlock interrupts. It typically maps to
+ -- intUnlock. The parameter Old is only used on PowerPC where it contains
+ -- the returned value from Int_Lock (the old MPSR).
+
+ ----------
+ -- Time --
+ ----------
+
+ type time_t is new unsigned_long;
+
+ type timespec is record
+ ts_sec : time_t;
+ ts_nsec : long;
+ end record;
+ pragma Convention (C, timespec);
+
+ type clockid_t is new int;
+
+ function To_Duration (TS : timespec) return Duration;
+ pragma Inline (To_Duration);
+
+ function To_Timespec (D : Duration) return timespec;
+ pragma Inline (To_Timespec);
+ -- Convert a Duration value to a timespec value. Note that in VxWorks,
+ -- timespec is always non-negative (since time_t is defined above as
+ -- unsigned long). This means that there is a potential problem if a
+ -- negative argument is passed for D. However, in actual usage, the
+ -- value of the input argument D is always non-negative, so no problem
+ -- arises in practice.
+
+ function To_Clock_Ticks (D : Duration) return int;
+ -- Convert a duration value (in seconds) into clock ticks
+
+ function clock_gettime
+ (clock_id : clockid_t; tp : access timespec) return int;
+ pragma Import (C, clock_gettime, "clock_gettime");
+
+ ----------------------
+ -- Utility Routines --
+ ----------------------
+
+ function To_VxWorks_Priority (Priority : int) return int;
+ pragma Inline (To_VxWorks_Priority);
+ -- Convenience routine to convert between VxWorks priority and Ada priority
+
+ --------------------------
+ -- VxWorks specific API --
+ --------------------------
+
+ subtype STATUS is int;
+ -- Equivalent of the C type STATUS
+
+ OK : constant STATUS := 0;
+ ERROR : constant STATUS := Interfaces.C.int (-1);
+
+ function taskIdVerify (tid : t_id) return STATUS;
+ pragma Import (C, taskIdVerify, "taskIdVerify");
+
+ function taskIdSelf return t_id;
+ pragma Import (C, taskIdSelf, "taskIdSelf");
+
+ function taskOptionsGet (tid : t_id; pOptions : access int) return int;
+ pragma Import (C, taskOptionsGet, "taskOptionsGet");
+
+ function taskSuspend (tid : t_id) return int;
+ pragma Import (C, taskSuspend, "taskSuspend");
+
+ function taskResume (tid : t_id) return int;
+ pragma Import (C, taskResume, "taskResume");
+
+ function taskIsSuspended (tid : t_id) return int;
+ pragma Import (C, taskIsSuspended, "taskIsSuspended");
+
+ function taskDelay (ticks : int) return int;
+ pragma Import (C, taskDelay, "taskDelay");
+
+ function sysClkRateGet return int;
+ pragma Import (C, sysClkRateGet, "sysClkRateGet");
+
+ -- VxWorks 5.x specific functions
+ -- Must not be called from run-time for versions that do not support
+ -- taskVarLib: eg VxWorks 6 RTPs
+
+ function taskVarAdd
+ (tid : t_id; pVar : access System.Address) return int;
+ pragma Import (C, taskVarAdd, "taskVarAdd");
+
+ function taskVarDelete
+ (tid : t_id; pVar : access System.Address) return int;
+ pragma Import (C, taskVarDelete, "taskVarDelete");
+
+ function taskVarSet
+ (tid : t_id;
+ pVar : access System.Address;
+ value : System.Address) return int;
+ pragma Import (C, taskVarSet, "taskVarSet");
+
+ function taskVarGet
+ (tid : t_id;
+ pVar : access System.Address) return int;
+ pragma Import (C, taskVarGet, "taskVarGet");
+
+ -- VxWorks 6.x specific functions
+
+ -- Can only be called from the VxWorks 6 run-time libary that supports
+ -- tlsLib, and not by the VxWorks 6.6 SMP library
+
+ function tlsKeyCreate return int;
+ pragma Import (C, tlsKeyCreate, "tlsKeyCreate");
+
+ function tlsValueGet (key : int) return System.Address;
+ pragma Import (C, tlsValueGet, "tlsValueGet");
+
+ function tlsValueSet (key : int; value : System.Address) return STATUS;
+ pragma Import (C, tlsValueSet, "tlsValueSet");
+
+ -- Option flags for taskSpawn
+
+ VX_UNBREAKABLE : constant := 16#0002#;
+ VX_FP_PRIVATE_ENV : constant := 16#0080#;
+ VX_NO_STACK_FILL : constant := 16#0100#;
+
+ function taskSpawn
+ (name : System.Address; -- Pointer to task name
+ priority : int;
+ options : int;
+ stacksize : size_t;
+ start_routine : System.Address;
+ arg1 : System.Address;
+ arg2 : int := 0;
+ arg3 : int := 0;
+ arg4 : int := 0;
+ arg5 : int := 0;
+ arg6 : int := 0;
+ arg7 : int := 0;
+ arg8 : int := 0;
+ arg9 : int := 0;
+ arg10 : int := 0) return t_id;
+ pragma Import (C, taskSpawn, "taskSpawn");
+
+ procedure taskDelete (tid : t_id);
+ pragma Import (C, taskDelete, "taskDelete");
+
+ function Set_Time_Slice (ticks : int) return int
+ renames System.VxWorks.Ext.Set_Time_Slice;
+ -- Calls kernelTimeSlice under VxWorks 5.x, VxWorks 653, or in VxWorks 6
+ -- kernel apps. Returns ERROR for RTPs, VxWorks 5 /CERT
+
+ function taskPriorityGet (tid : t_id; pPriority : access int) return int;
+ pragma Import (C, taskPriorityGet, "taskPriorityGet");
+
+ function taskPrioritySet (tid : t_id; newPriority : int) return int;
+ pragma Import (C, taskPrioritySet, "taskPrioritySet");
+
+ -- Semaphore creation flags
+
+ SEM_Q_FIFO : constant := 0;
+ SEM_Q_PRIORITY : constant := 1;
+ SEM_DELETE_SAFE : constant := 4; -- only valid for binary semaphore
+ SEM_INVERSION_SAFE : constant := 8; -- only valid for binary semaphore
+
+ -- Semaphore initial state flags
+
+ SEM_EMPTY : constant := 0;
+ SEM_FULL : constant := 1;
+
+ -- Semaphore take (semTake) time constants
+
+ WAIT_FOREVER : constant := -1;
+ NO_WAIT : constant := 0;
+
+ -- Error codes (errno). The lower level 16 bits are the error code, with
+ -- the upper 16 bits representing the module number in which the error
+ -- occurred. By convention, the module number is 0 for UNIX errors. VxWorks
+ -- reserves module numbers 1-500, with the remaining module numbers being
+ -- available for user applications.
+
+ M_objLib : constant := 61 * 2**16;
+ -- semTake() failure with ticks = NO_WAIT
+ S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2;
+ -- semTake() timeout with ticks > NO_WAIT
+ S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4;
+
+ subtype SEM_ID is System.VxWorks.Ext.SEM_ID;
+ -- typedef struct semaphore *SEM_ID;
+
+ -- We use two different kinds of VxWorks semaphores: mutex and binary
+ -- semaphores. A null ID is returned when a semaphore cannot be created.
+
+ function semBCreate (options : int; initial_state : int) return SEM_ID;
+ pragma Import (C, semBCreate, "semBCreate");
+ -- Create a binary semaphore. Return ID, or 0 if memory could not
+ -- be allocated.
+
+ function semMCreate (options : int) return SEM_ID;
+ pragma Import (C, semMCreate, "semMCreate");
+
+ function semDelete (Sem : SEM_ID) return int
+ renames System.VxWorks.Ext.semDelete;
+ -- Delete a semaphore
+
+ function semGive (Sem : SEM_ID) return int;
+ pragma Import (C, semGive, "semGive");
+
+ function semTake (Sem : SEM_ID; timeout : int) return int;
+ pragma Import (C, semTake, "semTake");
+ -- Attempt to take binary semaphore. Error is returned if operation
+ -- times out
+
+ function semFlush (SemID : SEM_ID) return STATUS;
+ pragma Import (C, semFlush, "semFlush");
+ -- Release all threads blocked on the semaphore
+
+ ------------------------------------------------------------
+ -- Binary Semaphore Wrapper to Support interrupt Tasks --
+ ------------------------------------------------------------
+
+ type Binary_Semaphore_Id is new Long_Integer;
+
+ function Binary_Semaphore_Create return Binary_Semaphore_Id;
+ pragma Inline (Binary_Semaphore_Create);
+
+ function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int;
+ pragma Inline (Binary_Semaphore_Delete);
+
+ function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int;
+ pragma Inline (Binary_Semaphore_Obtain);
+
+ function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int;
+ pragma Inline (Binary_Semaphore_Release);
+
+ function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int;
+ pragma Inline (Binary_Semaphore_Flush);
+
+ ------------------------------------------------------------
+ -- Hardware Interrupt Wrappers to Support Interrupt Tasks --
+ ------------------------------------------------------------
+
+ type Interrupt_Handler is access procedure (parameter : System.Address);
+ pragma Convention (C, Interrupt_Handler);
+
+ type Interrupt_Vector is new System.Address;
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int;
+ pragma Inline (Interrupt_Connect);
+ -- Use this to set up an user handler. The routine installs a user handler
+ -- which is invoked after the OS has saved enough context for a high-level
+ -- language routine to be safely invoked.
+
+ function Interrupt_Context return int;
+ pragma Inline (Interrupt_Context);
+ -- Return 1 if executing in an interrupt context; return 0 if executing in
+ -- a task context.
+
+ function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector;
+ pragma Inline (Interrupt_Number_To_Vector);
+ -- Convert a logical interrupt number to the hardware interrupt vector
+ -- number used to connect the interrupt.
+
+ --------------------------------
+ -- Processor Affinity for SMP --
+ --------------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int
+ renames System.VxWorks.Ext.taskCpuAffinitySet;
+ -- For SMP run-times the affinity to CPU.
+ -- For uniprocessor systems return ERROR status.
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int
+ renames System.VxWorks.Ext.taskMaskAffinitySet;
+ -- For SMP run-times the affinity to CPU_Set.
+ -- For uniprocessor systems return ERROR status.
+
+ ---------------------
+ -- Multiprocessors --
+ ---------------------
+
+ function Current_CPU return Multiprocessors.CPU;
+ -- Return the id of the current CPU
+
+private
+ type pid_t is new int;
+
+ ERROR_PID : constant pid_t := -1;
+
+ type sigset_t is new System.VxWorks.Ext.sigset_t;
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for Linux/x32
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+with Interfaces.C; use Interfaces.C;
+package body System.OS_Interface is
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ ------------------------
+ -- To_Target_Priority --
+ ------------------------
+
+ function To_Target_Priority
+ (Prio : System.Any_Priority) return Interfaces.C.int
+ is
+ begin
+ return Interfaces.C.int (Prio);
+ end To_Target_Priority;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ use type System.Linux.time_t;
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => Long_Long_Integer (F * 10#1#E9));
+ end To_Timespec;
+
+end System.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a no tasking version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking;
+ use System.Parameters;
+
+ pragma Warnings (Off);
+ -- Turn off warnings since so many unreferenced parameters
+
+ --------------
+ -- Specific --
+ --------------
+
+ -- Package Specific contains target specific routines, and the body of
+ -- this package is target specific.
+
+ package Specific is
+ procedure Set (Self_Id : Task_Id);
+ pragma Inline (Set);
+ -- Set the self id for the current task
+ end Specific;
+
+ package body Specific is
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ begin
+ null;
+ end Set;
+ end Specific;
+
+ ----------------------------------
+ -- ATCB allocation/deallocation --
+ ----------------------------------
+
+ package body ATCB_Allocation is separate;
+ -- The body of this package is shared across several targets
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
+ begin
+ null;
+ end Abort_Task;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
+ begin
+ return True;
+ end Check_No_Locks;
+
+ -------------------
+ -- Continue_Task --
+ -------------------
+
+ function Continue_Task (T : ST.Task_Id) return Boolean is
+ begin
+ return False;
+ end Continue_Task;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ begin
+ return False;
+ end Current_State;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_Id is
+ begin
+ return null;
+ end Environment_Task;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_Id;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ begin
+ Succeeded := False;
+ end Create_Task;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_Id) is
+ begin
+ null;
+ end Enter_Task;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ null;
+ end Exit_Task;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ begin
+ null;
+ end Finalize;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : not null access Lock) is
+ begin
+ null;
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : not null access RTS_Lock) is
+ begin
+ null;
+ end Finalize_Lock;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_Id) is
+ begin
+ null;
+ end Finalize_TCB;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_Id) return System.Any_Priority is
+ begin
+ return 0;
+ end Get_Priority;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
+ begin
+ return OSI.Thread_Id (T.Common.LL.Thread);
+ end Get_Thread_Id;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ No_Tasking : Boolean;
+ begin
+ raise Program_Error with "tasking not implemented on this configuration";
+ end Initialize;
+
+ procedure Initialize (S : in out Suspension_Object) is
+ begin
+ null;
+ end Initialize;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : not null access Lock)
+ is
+ begin
+ null;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock; Level : Lock_Level) is
+ begin
+ null;
+ end Initialize_Lock;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
+ begin
+ Succeeded := False;
+ end Initialize_TCB;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return False;
+ end Is_Valid_Task;
+
+ --------------
+ -- Lock_RTS --
+ --------------
+
+ procedure Lock_RTS is
+ begin
+ null;
+ end Lock_RTS;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ begin
+ return 0.0;
+ end Monotonic_Clock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
+ begin
+ Ceiling_Violation := False;
+ end Read_Lock;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_Id is
+ begin
+ return null;
+ end Register_Foreign_Thread;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_Id;
+ Thread_Self : OSI.Thread_Id) return Boolean
+ is
+ begin
+ return False;
+ end Resume_Task;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 10#1.0#E-6;
+ end RT_Resolution;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id is
+ begin
+ return Null_Task;
+ end Self;
+
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ begin
+ null;
+ end Set_Ceiling;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ begin
+ null;
+ end Set_False;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_Id;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ begin
+ null;
+ end Set_Priority;
+
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ begin
+ null;
+ end Set_Task_Affinity;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ begin
+ null;
+ end Set_True;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
+ begin
+ null;
+ end Sleep;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ begin
+ null;
+ end Stack_Guard;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_Id;
+ Thread_Self : OSI.Thread_Id) return Boolean
+ is
+ begin
+ return False;
+ end Suspend_Task;
+
+ --------------------
+ -- Stop_All_Tasks --
+ --------------------
+
+ procedure Stop_All_Tasks is
+ begin
+ null;
+ end Stop_All_Tasks;
+
+ ---------------
+ -- Stop_Task --
+ ---------------
+
+ function Stop_Task (T : ST.Task_Id) return Boolean is
+ pragma Unreferenced (T);
+ begin
+ return False;
+ end Stop_Task;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ begin
+ null;
+ end Suspend_Until_True;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ begin
+ null;
+ end Timed_Delay;
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ procedure Timed_Sleep
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ begin
+ Timedout := False;
+ Yielded := False;
+ end Timed_Sleep;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : not null access Lock) is
+ begin
+ null;
+ end Unlock;
+
+ procedure Unlock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ begin
+ null;
+ end Unlock;
+
+ procedure Unlock (T : Task_Id) is
+ begin
+ null;
+ end Unlock;
+
+ ----------------
+ -- Unlock_RTS --
+ ----------------
+
+ procedure Unlock_RTS is
+ begin
+ null;
+ end Unlock_RTS;
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
+ begin
+ null;
+ end Wakeup;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
+ begin
+ Ceiling_Violation := False;
+ end Write_Lock;
+
+ procedure Write_Lock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ begin
+ null;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_Id) is
+ begin
+ null;
+ end Write_Lock;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ begin
+ null;
+ end Yield;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a HP-UX DCE threads (HPUX 10) version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+with System.Tasking.Debug;
+with System.Interrupt_Management;
+with System.OS_Constants;
+with System.OS_Primitives;
+with System.Task_Primitives.Interrupt_Operations;
+
+pragma Warnings (Off);
+with System.Interrupt_Management.Operations;
+pragma Elaborate_All (System.Interrupt_Management.Operations);
+pragma Warnings (On);
+
+with System.Soft_Links;
+-- We use System.Soft_Links instead of System.Tasking.Initialization
+-- because the later is a higher level package that we shouldn't depend on.
+-- For example when using the restricted run time, it is replaced by
+-- System.Tasking.Restricted.Stages.
+
+package body System.Task_Primitives.Operations is
+
+ package OSC renames System.OS_Constants;
+ package SSL renames System.Soft_Links;
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+
+ package PIO renames System.Task_Primitives.Interrupt_Operations;
+
+ ----------------
+ -- Local Data --
+ ----------------
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ Single_RTS_Lock : aliased RTS_Lock;
+ -- This is a lock to allow only one thread of control in the RTS at
+ -- a time; it is used to execute in mutual exclusion from all other tasks.
+ -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+
+ Environment_Task_Id : Task_Id;
+ -- A variable to hold Task_Id for the environment task
+
+ Unblocked_Signal_Mask : aliased sigset_t;
+ -- The set of signals that should unblocked in all tasks
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ -- Note: the reason that Locking_Policy is not needed is that this
+ -- is not implemented for DCE threads. The HPUX 10 port is at this
+ -- stage considered dead, and no further work is planned on it.
+
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads)
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ procedure Initialize (Environment_Task : Task_Id);
+ pragma Inline (Initialize);
+ -- Initialize various data needed by this package
+
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does the executing thread have a TCB?
+
+ procedure Set (Self_Id : Task_Id);
+ pragma Inline (Set);
+ -- Set the self id for the current task
+
+ function Self return Task_Id;
+ pragma Inline (Self);
+ -- Return a pointer to the Ada Task Control Block of the calling task
+
+ end Specific;
+
+ package body Specific is separate;
+ -- The body of this package is target specific
+
+ ----------------------------------
+ -- ATCB allocation/deallocation --
+ ----------------------------------
+
+ package body ATCB_Allocation is separate;
+ -- The body of this package is shared across several targets
+
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
+ -- Allocate and Initialize a new ATCB for the current Thread
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_Id is separate;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler (Sig : Signal);
+
+ function To_Address is
+ new Ada.Unchecked_Conversion (Task_Id, System.Address);
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ procedure Abort_Handler (Sig : Signal) is
+ pragma Unreferenced (Sig);
+
+ Self_Id : constant Task_Id := Self;
+ Result : Interfaces.C.int;
+ Old_Set : aliased sigset_t;
+
+ begin
+ if Self_Id.Deferral_Level = 0
+ and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
+ and then not Self_Id.Aborting
+ then
+ Self_Id.Aborting := True;
+
+ -- Make sure signals used for RTS internal purpose are unmasked
+
+ Result :=
+ pthread_sigmask
+ (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Access,
+ Old_Set'Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+ end if;
+ end Abort_Handler;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ -- The underlying thread system sets a guard page at the bottom of a thread
+ -- stack, so nothing is needed.
+ -- ??? Check the comment above
+
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ pragma Unreferenced (T, On);
+ begin
+ null;
+ end Stack_Guard;
+
+ -------------------
+ -- Get_Thread_Id --
+ -------------------
+
+ function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id renames Specific.Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are initialized
+ -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
+ -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
+ -- status change of RTS. Therefore raising Storage_Error in the following
+ -- routines should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : not null access Lock)
+ is
+ Attributes : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutexattr_init (Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ L.Priority := Prio;
+
+ Result := pthread_mutex_init (L.L'Access, Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock;
+ Level : Lock_Level)
+ is
+ pragma Unreferenced (Level);
+
+ Attributes : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutexattr_init (Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutex_init (L, Attributes'Access);
+
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : not null access Lock) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_destroy (L.L'Access);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : not null access RTS_Lock) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_destroy (L);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ L.Owner_Priority := Get_Priority (Self);
+
+ if L.Priority < L.Owner_Priority then
+ Ceiling_Violation := True;
+ return;
+ end if;
+
+ Result := pthread_mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ Ceiling_Violation := False;
+ end Write_Lock;
+
+ procedure Write_Lock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock or else Global_Lock then
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock then
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : not null access Lock) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock or else Global_Lock then
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ procedure Unlock (T : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock then
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep
+ (Self_ID : Task_Id;
+ Reason : System.Tasking.Task_States)
+ is
+ pragma Unreferenced (Reason);
+
+ Result : Interfaces.C.int;
+
+ begin
+ Result :=
+ pthread_cond_wait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access));
+
+ -- EINTR is not considered a failure
+
+ pragma Assert (Result = 0 or else Result = EINTR);
+ end Sleep;
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ procedure Timed_Sleep
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ pragma Unreferenced (Reason);
+
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ Timedout := True;
+ Yielded := False;
+
+ Abs_Time :=
+ (if Mode = Relative
+ then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result :=
+ pthread_cond_timedwait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access),
+ abstime => Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ if Result = 0 or Result = EINTR then
+
+ -- Somebody may have called Wakeup for us
+
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIMEDOUT);
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+
+ Result : Interfaces.C.int;
+ pragma Warnings (Off, Result);
+
+ begin
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ Write_Lock (Self_ID);
+
+ Abs_Time :=
+ (if Mode = Relative
+ then Time + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result :=
+ pthread_cond_timedwait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access),
+ abstime => Request'Access);
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ pragma Assert (Result = 0 or else
+ Result = ETIMEDOUT or else
+ Result = EINTR);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ Result := sched_yield;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+ begin
+ Result := Clock_Gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 10#1.0#E-6;
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_cond_signal (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ end Wakeup;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ Result : Interfaces.C.int;
+ pragma Unreferenced (Result);
+ begin
+ if Do_Yield then
+ Result := sched_yield;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ type Prio_Array_Type is array (System.Any_Priority) of Integer;
+ pragma Atomic_Components (Prio_Array_Type);
+
+ Prio_Array : Prio_Array_Type;
+ -- Global array containing the id of the currently running task for
+ -- each priority.
+ --
+ -- Note: assume we are on single processor with run-til-blocked scheduling
+
+ procedure Set_Priority
+ (T : Task_Id;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ Array_Item : Integer;
+ Param : aliased struct_sched_param;
+
+ function Get_Policy (Prio : System.Any_Priority) return Character;
+ pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
+ -- Get priority specific dispatching policy
+
+ Priority_Specific_Policy : constant Character := Get_Policy (Prio);
+ -- Upper case first character of the policy name corresponding to the
+ -- task as set by a Priority_Specific_Dispatching pragma.
+
+ begin
+ Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
+
+ if Dispatching_Policy = 'R'
+ or else Priority_Specific_Policy = 'R'
+ or else Time_Slice_Val > 0
+ then
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
+
+ elsif Dispatching_Policy = 'F'
+ or else Priority_Specific_Policy = 'F'
+ or else Time_Slice_Val = 0
+ then
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
+
+ else
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
+ end if;
+
+ pragma Assert (Result = 0);
+
+ if Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' then
+
+ -- Annex D requirement [RM D.2.2 par. 9]:
+ -- If the task drops its priority due to the loss of inherited
+ -- priority, it is added at the head of the ready queue for its
+ -- new active priority.
+
+ if Loss_Of_Inheritance
+ and then Prio < T.Common.Current_Priority
+ then
+ Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
+ Prio_Array (T.Common.Base_Priority) := Array_Item;
+
+ loop
+ -- Let some processes a chance to arrive
+
+ Yield;
+
+ -- Then wait for our turn to proceed
+
+ exit when Array_Item = Prio_Array (T.Common.Base_Priority)
+ or else Prio_Array (T.Common.Base_Priority) = 1;
+ end loop;
+
+ Prio_Array (T.Common.Base_Priority) :=
+ Prio_Array (T.Common.Base_Priority) - 1;
+ end if;
+ end if;
+
+ T.Common.Current_Priority := Prio;
+ end Set_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_Id) return System.Any_Priority is
+ begin
+ return T.Common.Current_Priority;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_Id) is
+ begin
+ Self_ID.Common.LL.Thread := pthread_self;
+ Specific.Set (Self_ID);
+ end Enter_Task;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_Id is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (pthread_self);
+ end if;
+ end Register_Foreign_Thread;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+ Cond_Attr : aliased pthread_condattr_t;
+
+ begin
+ if not Single_Lock then
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Result :=
+ pthread_mutex_init
+ (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+ end if;
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Result :=
+ pthread_cond_init
+ (Self_ID.Common.LL.CV'Access,
+ Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+ end if;
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ if not Single_Lock then
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Succeeded := False;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_Id;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ Attributes : aliased pthread_attr_t;
+ Result : Interfaces.C.int;
+
+ function Thread_Body_Access is new
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ begin
+ Result := pthread_attr_init (Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_attr_setstacksize
+ (Attributes'Access, Interfaces.C.size_t (Stack_Size));
+ pragma Assert (Result = 0);
+
+ -- Since the initial signal mask of a thread is inherited from the
+ -- creator, and the Environment task has all its signals masked, we
+ -- do not need to manipulate caller's signal mask at this point.
+ -- All tasks in RTS will have All_Tasks_Mask initially.
+
+ Result := pthread_create
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
+ pragma Assert (Result = 0 or else Result = EAGAIN);
+
+ Succeeded := Result = 0;
+
+ pthread_detach (T.Common.LL.Thread'Access);
+ -- Detach the thread using pthread_detach, since DCE threads do not have
+ -- pthread_attr_set_detachstate.
+
+ Result := pthread_attr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+
+ Set_Priority (T, Priority);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_Id) is
+ Result : Interfaces.C.int;
+
+ begin
+ if not Single_Lock then
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := pthread_cond_destroy (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ ATCB_Allocation.Free_ATCB (T);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ Specific.Set (null);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
+ begin
+ -- Interrupt Server_Tasks may be waiting on an "event" flag (signal)
+
+ if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
+ System.Interrupt_Management.Operations.Interrupt_Self_Process
+ (PIO.Get_Interrupt_ID (T));
+ end if;
+ end Abort_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Cond_Attr : aliased pthread_condattr_t;
+ Result : Interfaces.C.int;
+ begin
+ -- Initialize internal state (always to False (ARM D.10(6)))
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ -- Initialize internal condition variable
+
+ Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+ end if;
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ -- Destroy internal mutex
+
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- Destroy internal condition variable
+
+ Result := pthread_cond_destroy (S.CV'Access);
+ pragma Assert (Result = 0);
+ end Finalize;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ begin
+ -- We do not want to use lock on this read operation. State is marked
+ -- as Atomic so that we ensure that the value retrieved is correct.
+
+ return S.State;
+ end Current_State;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ S.State := False;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- If there is already a task waiting on this suspension object then
+ -- we resume it, leaving the state of the suspension object to False,
+ -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
+ -- the state to True.
+
+ if S.Waiting then
+ S.Waiting := False;
+ S.State := False;
+
+ Result := pthread_cond_signal (S.CV'Access);
+ pragma Assert (Result = 0);
+
+ else
+ S.State := True;
+ end if;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if S.Waiting then
+ -- Program_Error must be raised upon calling Suspend_Until_True
+ -- if another task is already waiting on that suspension object
+ -- (ARM D.10 par. 10).
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+
+ raise Program_Error;
+ else
+ -- Suspend the task if the state is False. Otherwise, the task
+ -- continues its execution, and the state of the suspension object
+ -- is set to False (ARM D.10 par. 9).
+
+ if S.State then
+ S.State := False;
+ else
+ S.Waiting := True;
+
+ loop
+ -- Loop in case pthread_cond_wait returns earlier than expected
+ -- (e.g. in case of EINTR caused by a signal).
+
+ Result := pthread_cond_wait (S.CV'Access, S.L'Access);
+ pragma Assert (Result = 0 or else Result = EINTR);
+
+ exit when not S.Waiting;
+ end loop;
+ end if;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end if;
+ end Suspend_Until_True;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy version
+
+ function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
+ pragma Unreferenced (Self_ID);
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
+ pragma Unreferenced (Self_ID);
+ begin
+ return True;
+ end Check_No_Locks;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_Id is
+ begin
+ return Environment_Task_Id;
+ end Environment_Task;
+
+ --------------
+ -- Lock_RTS --
+ --------------
+
+ procedure Lock_RTS is
+ begin
+ Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Lock_RTS;
+
+ ----------------
+ -- Unlock_RTS --
+ ----------------
+
+ procedure Unlock_RTS is
+ begin
+ Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Unlock_RTS;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ pragma Unreferenced (T);
+ pragma Unreferenced (Thread_Self);
+ begin
+ return False;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ pragma Unreferenced (T);
+ pragma Unreferenced (Thread_Self);
+ begin
+ return False;
+ end Resume_Task;
+
+ --------------------
+ -- Stop_All_Tasks --
+ --------------------
+
+ procedure Stop_All_Tasks is
+ begin
+ null;
+ end Stop_All_Tasks;
+
+ ---------------
+ -- Stop_Task --
+ ---------------
+
+ function Stop_Task (T : ST.Task_Id) return Boolean is
+ pragma Unreferenced (T);
+ begin
+ return False;
+ end Stop_Task;
+
+ -------------------
+ -- Continue_Task --
+ -------------------
+
+ function Continue_Task (T : ST.Task_Id) return Boolean is
+ pragma Unreferenced (T);
+ begin
+ return False;
+ end Continue_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ function State
+ (Int : System.Interrupt_Management.Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c. The input argument is
+ -- the interrupt number, and the result is one of the following:
+
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
+ begin
+ Environment_Task_Id := Environment_Task;
+
+ Interrupt_Management.Initialize;
+
+ -- Initialize the lock used to synchronize chain of all ATCBs
+
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ Specific.Initialize (Environment_Task);
+
+ -- Make environment task known here because it doesn't go through
+ -- Activate_Tasks, which does it for all other tasks.
+
+ Known_Tasks (Known_Tasks'First) := Environment_Task;
+ Environment_Task.Known_Tasks_Index := Known_Tasks'First;
+
+ Enter_Task (Environment_Task);
+
+ -- Install the abort-signal handler
+
+ if State (System.Interrupt_Management.Abort_Task_Interrupt)
+ /= Default
+ then
+ act.sa_flags := 0;
+ act.sa_handler := Abort_Handler'Address;
+
+ Result := sigemptyset (Tmp_Set'Access);
+ pragma Assert (Result = 0);
+ act.sa_mask := Tmp_Set;
+
+ Result :=
+ sigaction (
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Initialize;
+
+ -- NOTE: Unlike other pthread implementations, we do *not* mask all
+ -- signals here since we handle signals using the process-wide primitive
+ -- signal, rather than using sigthreadmask and sigwait. The reason of
+ -- this difference is that sigwait doesn't work when some critical
+ -- signals (SIGABRT, SIGPIPE) are masked.
+
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ pragma Unreferenced (T);
+
+ begin
+ -- Setting task affinity is not supported by the underlying system
+
+ null;
+ end Set_Task_Affinity;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a GNU/Linux (GNU/LinuxThreads) version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with Interfaces.C; use Interfaces; use type Interfaces.C.int;
+
+with System.Task_Info;
+with System.Tasking.Debug;
+with System.Interrupt_Management;
+with System.OS_Constants;
+with System.OS_Primitives;
+with System.Multiprocessors;
+
+with System.Soft_Links;
+-- We use System.Soft_Links instead of System.Tasking.Initialization
+-- because the later is a higher level package that we shouldn't depend on.
+-- For example when using the restricted run time, it is replaced by
+-- System.Tasking.Restricted.Stages.
+
+package body System.Task_Primitives.Operations is
+
+ package OSC renames System.OS_Constants;
+ package SSL renames System.Soft_Links;
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+ use System.Task_Info;
+
+ ----------------
+ -- Local Data --
+ ----------------
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ Single_RTS_Lock : aliased RTS_Lock;
+ -- This is a lock to allow only one thread of control in the RTS at
+ -- a time; it is used to execute in mutual exclusion from all other tasks.
+ -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+
+ Environment_Task_Id : Task_Id;
+ -- A variable to hold Task_Id for the environment task
+
+ Unblocked_Signal_Mask : aliased sigset_t;
+ -- The set of signals that should be unblocked in all tasks
+
+ -- The followings are internal configuration constants needed
+
+ Next_Serial_Number : Task_Serial_Number := 100;
+ -- We start at 100 (reserve some special values for using in error checks)
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads)
+
+ Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
+ -- Whether to use an alternate signal stack for stack overflows
+
+ Abort_Handler_Installed : Boolean := False;
+ -- True if a handler for the abort signal is installed
+
+ Null_Thread_Id : constant pthread_t := pthread_t'Last;
+ -- Constant to indicate that the thread identifier has not yet been
+ -- initialized.
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ procedure Initialize (Environment_Task : Task_Id);
+ pragma Inline (Initialize);
+ -- Initialize various data needed by this package
+
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does executing thread have a TCB?
+
+ procedure Set (Self_Id : Task_Id);
+ pragma Inline (Set);
+ -- Set the self id for the current task
+
+ function Self return Task_Id;
+ pragma Inline (Self);
+ -- Return a pointer to the Ada Task Control Block of the calling task
+
+ end Specific;
+
+ package body Specific is separate;
+ -- The body of this package is target specific
+
+ ----------------------------------
+ -- ATCB allocation/deallocation --
+ ----------------------------------
+
+ package body ATCB_Allocation is separate;
+ -- The body of this package is shared across several targets
+
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
+ -- Allocate and Initialize a new ATCB for the current Thread
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_Id is separate;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler (signo : Signal);
+
+ function GNAT_pthread_condattr_setup
+ (attr : access pthread_condattr_t) return C.int;
+ pragma Import
+ (C, GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
+
+ function GNAT_has_cap_sys_nice return C.int;
+ pragma Import
+ (C, GNAT_has_cap_sys_nice, "__gnat_has_cap_sys_nice");
+ -- We do not have pragma Linker_Options ("-lcap"); here, because this
+ -- library is not present on many Linux systems. 'libcap' is the Linux
+ -- "capabilities" library, called by __gnat_has_cap_sys_nice.
+
+ function Prio_To_Linux_Prio (Prio : Any_Priority) return C.int is
+ (C.int (Prio) + 1);
+ -- Convert Ada priority to Linux priority. Priorities are 1 .. 99 on
+ -- GNU/Linux, so we map 0 .. 98 to 1 .. 99.
+
+ function Get_Ceiling_Support return Boolean;
+ -- Get the value of the Ceiling_Support constant (see below).
+ -- Note well: If this function or related code is modified, it should be
+ -- tested by hand, because automated testing doesn't exercise it.
+
+ function Get_Ceiling_Support return Boolean is
+ Ceiling_Support : Boolean := False;
+ begin
+ if Locking_Policy /= 'C' then
+ return False;
+ end if;
+
+ declare
+ function geteuid return Integer;
+ pragma Import (C, geteuid, "geteuid");
+ Superuser : constant Boolean := geteuid = 0;
+ Has_Cap : constant C.int := GNAT_has_cap_sys_nice;
+ pragma Assert (Has_Cap in 0 | 1);
+ begin
+ Ceiling_Support := Superuser or else Has_Cap = 1;
+ end;
+
+ return Ceiling_Support;
+ end Get_Ceiling_Support;
+
+ pragma Warnings (Off, "non-static call not allowed in preelaborated unit");
+ Ceiling_Support : constant Boolean := Get_Ceiling_Support;
+ pragma Warnings (On, "non-static call not allowed in preelaborated unit");
+ -- True if the locking policy is Ceiling_Locking, and the current process
+ -- has permission to use this policy. The process has permission if it is
+ -- running as 'root', or if the capability was set by the setcap command,
+ -- as in "sudo /sbin/setcap cap_sys_nice=ep exe_file". If it doesn't have
+ -- permission, then a request for Ceiling_Locking is ignored.
+
+ type RTS_Lock_Ptr is not null access all RTS_Lock;
+
+ function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int;
+ -- Initialize the mutex L. If Ceiling_Support is True, then set the ceiling
+ -- to Prio. Returns 0 for success, or ENOMEM for out-of-memory.
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ procedure Abort_Handler (signo : Signal) is
+ pragma Unreferenced (signo);
+
+ Self_Id : constant Task_Id := Self;
+ Result : C.int;
+ Old_Set : aliased sigset_t;
+
+ begin
+ -- It's not safe to raise an exception when using GCC ZCX mechanism.
+ -- Note that we still need to install a signal handler, since in some
+ -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
+ -- need to send the Abort signal to a task.
+
+ if ZCX_By_Default then
+ return;
+ end if;
+
+ if Self_Id.Deferral_Level = 0
+ and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
+ and then not Self_Id.Aborting
+ then
+ Self_Id.Aborting := True;
+
+ -- Make sure signals used for RTS internal purpose are unmasked
+
+ Result :=
+ pthread_sigmask
+ (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Access,
+ Old_Set'Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+ end if;
+ end Abort_Handler;
+
+ --------------
+ -- Lock_RTS --
+ --------------
+
+ procedure Lock_RTS is
+ begin
+ Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Lock_RTS;
+
+ ----------------
+ -- Unlock_RTS --
+ ----------------
+
+ procedure Unlock_RTS is
+ begin
+ Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Unlock_RTS;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ -- The underlying thread system extends the memory (up to 2MB) when needed
+
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ pragma Unreferenced (T);
+ pragma Unreferenced (On);
+ begin
+ null;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id renames Specific.Self;
+
+ ----------------
+ -- Init_Mutex --
+ ----------------
+
+ function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Result, Result_2 : C.int;
+
+ begin
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result in 0 | ENOMEM);
+
+ if Result = ENOMEM then
+ return Result;
+ end if;
+
+ if Ceiling_Support then
+ Result := pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Mutex_Attr'Access, Prio_To_Linux_Prio (Prio));
+ pragma Assert (Result = 0);
+
+ elsif Locking_Policy = 'I' then
+ Result := pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access, PTHREAD_PRIO_INHERIT);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := pthread_mutex_init (L, Mutex_Attr'Access);
+ pragma Assert (Result in 0 | ENOMEM);
+
+ Result_2 := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result_2 = 0);
+ return Result; -- of pthread_mutex_init, not pthread_mutexattr_destroy
+ end Init_Mutex;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are initialized
+ -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
+ -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
+ -- status change of RTS. Therefore raising Storage_Error in the following
+ -- routines should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : Any_Priority;
+ L : not null access Lock)
+ is
+ begin
+ if Locking_Policy = 'R' then
+ declare
+ RWlock_Attr : aliased pthread_rwlockattr_t;
+ Result : C.int;
+
+ begin
+ -- Set the rwlock to prefer writer to avoid writers starvation
+
+ Result := pthread_rwlockattr_init (RWlock_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_rwlockattr_setkind_np
+ (RWlock_Attr'Access,
+ PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP);
+ pragma Assert (Result = 0);
+
+ Result := pthread_rwlock_init (L.RW'Access, RWlock_Attr'Access);
+
+ pragma Assert (Result in 0 | ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+ end;
+
+ else
+ if Init_Mutex (L.WO'Access, Prio) = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+ end if;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock; Level : Lock_Level)
+ is
+ pragma Unreferenced (Level);
+ begin
+ if Init_Mutex (L.all'Access, Any_Priority'Last) = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : not null access Lock) is
+ Result : C.int;
+ begin
+ if Locking_Policy = 'R' then
+ Result := pthread_rwlock_destroy (L.RW'Access);
+ else
+ Result := pthread_mutex_destroy (L.WO'Access);
+ end if;
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : not null access RTS_Lock) is
+ Result : C.int;
+ begin
+ Result := pthread_mutex_destroy (L);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
+ Result : C.int;
+ begin
+ if Locking_Policy = 'R' then
+ Result := pthread_rwlock_wrlock (L.RW'Access);
+ else
+ Result := pthread_mutex_lock (L.WO'Access);
+ end if;
+
+ -- The cause of EINVAL is a priority ceiling violation
+
+ pragma Assert (Result in 0 | EINVAL);
+ Ceiling_Violation := Result = EINVAL;
+ end Write_Lock;
+
+ procedure Write_Lock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ Result : C.int;
+ begin
+ if not Single_Lock or else Global_Lock then
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_Id) is
+ Result : C.int;
+ begin
+ if not Single_Lock then
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
+ Result : C.int;
+ begin
+ if Locking_Policy = 'R' then
+ Result := pthread_rwlock_rdlock (L.RW'Access);
+ else
+ Result := pthread_mutex_lock (L.WO'Access);
+ end if;
+
+ -- The cause of EINVAL is a priority ceiling violation
+
+ pragma Assert (Result in 0 | EINVAL);
+ Ceiling_Violation := Result = EINVAL;
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : not null access Lock) is
+ Result : C.int;
+ begin
+ if Locking_Policy = 'R' then
+ Result := pthread_rwlock_unlock (L.RW'Access);
+ else
+ Result := pthread_mutex_unlock (L.WO'Access);
+ end if;
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ Result : C.int;
+ begin
+ if not Single_Lock or else Global_Lock then
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ procedure Unlock (T : Task_Id) is
+ Result : C.int;
+ begin
+ if not Single_Lock then
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep
+ (Self_ID : Task_Id;
+ Reason : System.Tasking.Task_States)
+ is
+ pragma Unreferenced (Reason);
+
+ Result : C.int;
+
+ begin
+ pragma Assert (Self_ID = Self);
+
+ Result :=
+ pthread_cond_wait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access));
+
+ -- EINTR is not considered a failure
+
+ pragma Assert (Result in 0 | EINTR);
+ end Sleep;
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ -- This is for use within the run-time system, so abort is
+ -- assumed to be already deferred, and the caller should be
+ -- holding its own ATCB lock.
+
+ procedure Timed_Sleep
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ pragma Unreferenced (Reason);
+
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : C.int;
+
+ begin
+ Timedout := True;
+ Yielded := False;
+
+ Abs_Time :=
+ (if Mode = Relative
+ then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result :=
+ pthread_cond_timedwait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access),
+ abstime => Request'Access);
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ if Result in 0 | EINTR then
+
+ -- Somebody may have called Wakeup for us
+
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIMEDOUT);
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ -- This is for use in implementing delay statements, so we assume the
+ -- caller is abort-deferred but is holding no locks.
+
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+
+ Result : C.int;
+ pragma Warnings (Off, Result);
+
+ begin
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ Write_Lock (Self_ID);
+
+ Abs_Time :=
+ (if Mode = Relative
+ then Time + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result :=
+ pthread_cond_timedwait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access),
+ abstime => Request'Access);
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ pragma Assert (Result in 0 | ETIMEDOUT | EINTR);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ Result := sched_yield;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : C.int;
+ begin
+ Result := clock_gettime
+ (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ TS : aliased timespec;
+ Result : C.int;
+
+ begin
+ Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ return To_Duration (TS);
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+ Result : C.int;
+ begin
+ Result := pthread_cond_signal (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ end Wakeup;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ Result : C.int;
+ pragma Unreferenced (Result);
+ begin
+ if Do_Yield then
+ Result := sched_yield;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_Id;
+ Prio : Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ pragma Unreferenced (Loss_Of_Inheritance);
+
+ Result : C.int;
+ Param : aliased struct_sched_param;
+
+ function Get_Policy (Prio : Any_Priority) return Character;
+ pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
+ -- Get priority specific dispatching policy
+
+ Priority_Specific_Policy : constant Character := Get_Policy (Prio);
+ -- Upper case first character of the policy name corresponding to the
+ -- task as set by a Priority_Specific_Dispatching pragma.
+
+ begin
+ T.Common.Current_Priority := Prio;
+
+ Param.sched_priority := Prio_To_Linux_Prio (Prio);
+
+ if Dispatching_Policy = 'R'
+ or else Priority_Specific_Policy = 'R'
+ or else Time_Slice_Val > 0
+ then
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
+
+ elsif Dispatching_Policy = 'F'
+ or else Priority_Specific_Policy = 'F'
+ or else Time_Slice_Val = 0
+ then
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
+
+ else
+ Param.sched_priority := 0;
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread,
+ SCHED_OTHER, Param'Access);
+ end if;
+
+ pragma Assert (Result in 0 | EPERM | EINVAL);
+ end Set_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_Id) return Any_Priority is
+ begin
+ return T.Common.Current_Priority;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_Id) is
+ begin
+ if Self_ID.Common.Task_Info /= null
+ and then Self_ID.Common.Task_Info.CPU_Affinity = No_CPU
+ then
+ raise Invalid_CPU_Number;
+ end if;
+
+ Self_ID.Common.LL.Thread := pthread_self;
+ Self_ID.Common.LL.LWP := lwp_self;
+
+ -- Set thread name to ease debugging. If the name of the task is
+ -- "foreign thread" (as set by Register_Foreign_Thread) retrieve
+ -- the name of the thread and update the name of the task instead.
+
+ if Self_ID.Common.Task_Image_Len = 14
+ and then Self_ID.Common.Task_Image (1 .. 14) = "foreign thread"
+ then
+ declare
+ Thread_Name : String (1 .. 16);
+ -- PR_GET_NAME returns a string of up to 16 bytes
+
+ Len : Natural := 0;
+ -- Length of the task name contained in Task_Name
+
+ Result : C.int;
+ -- Result from the prctl call
+ begin
+ Result := prctl (PR_GET_NAME, unsigned_long (Thread_Name'Address));
+ pragma Assert (Result = 0);
+
+ -- Find the length of the given name
+
+ for J in Thread_Name'Range loop
+ if Thread_Name (J) /= ASCII.NUL then
+ Len := Len + 1;
+ else
+ exit;
+ end if;
+ end loop;
+
+ -- Cover the odd situation where someone decides to change
+ -- Parameters.Max_Task_Image_Length to less than 16 characters.
+
+ if Len > Parameters.Max_Task_Image_Length then
+ Len := Parameters.Max_Task_Image_Length;
+ end if;
+
+ -- Copy the name of the thread to the task's ATCB
+
+ Self_ID.Common.Task_Image (1 .. Len) := Thread_Name (1 .. Len);
+ Self_ID.Common.Task_Image_Len := Len;
+ end;
+
+ elsif Self_ID.Common.Task_Image_Len > 0 then
+ declare
+ Task_Name : String (1 .. Parameters.Max_Task_Image_Length + 1);
+ Result : C.int;
+
+ begin
+ Task_Name (1 .. Self_ID.Common.Task_Image_Len) :=
+ Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len);
+ Task_Name (Self_ID.Common.Task_Image_Len + 1) := ASCII.NUL;
+
+ Result := prctl (PR_SET_NAME, unsigned_long (Task_Name'Address));
+ pragma Assert (Result = 0);
+ end;
+ end if;
+
+ Specific.Set (Self_ID);
+
+ if Use_Alternate_Stack
+ and then Self_ID.Common.Task_Alternate_Stack /= Null_Address
+ then
+ declare
+ Stack : aliased stack_t;
+ Result : C.int;
+ begin
+ Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack;
+ Stack.ss_size := Alternate_Stack_Size;
+ Stack.ss_flags := 0;
+ Result := sigaltstack (Stack'Access, null);
+ pragma Assert (Result = 0);
+ end;
+ end if;
+ end Enter_Task;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_Id is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (pthread_self);
+ end if;
+ end Register_Foreign_Thread;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
+ Result : C.int;
+ Cond_Attr : aliased pthread_condattr_t;
+
+ begin
+ -- Give the task a unique serial number
+
+ Self_ID.Serial_Number := Next_Serial_Number;
+ Next_Serial_Number := Next_Serial_Number + 1;
+ pragma Assert (Next_Serial_Number /= 0);
+
+ Self_ID.Common.LL.Thread := Null_Thread_Id;
+
+ if not Single_Lock then
+ if Init_Mutex
+ (Self_ID.Common.LL.L'Access, Any_Priority'Last) /= 0
+ then
+ Succeeded := False;
+ return;
+ end if;
+ end if;
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result in 0 | ENOMEM);
+
+ if Result = 0 then
+ Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Result :=
+ pthread_cond_init
+ (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
+ pragma Assert (Result in 0 | ENOMEM);
+ end if;
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ if not Single_Lock then
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Succeeded := False;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_Id;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : Any_Priority;
+ Succeeded : out Boolean)
+ is
+ Thread_Attr : aliased pthread_attr_t;
+ Adjusted_Stack_Size : C.size_t;
+ Result : C.int;
+
+ use type Multiprocessors.CPU_Range, Interfaces.C.size_t;
+
+ begin
+ -- Check whether both Dispatching_Domain and CPU are specified for
+ -- the task, and the CPU value is not contained within the range of
+ -- processors for the domain.
+
+ if T.Common.Domain /= null
+ and then T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU
+ and then
+ (T.Common.Base_CPU not in T.Common.Domain'Range
+ or else not T.Common.Domain (T.Common.Base_CPU))
+ then
+ Succeeded := False;
+ return;
+ end if;
+
+ Adjusted_Stack_Size := C.size_t (Stack_Size + Alternate_Stack_Size);
+
+ Result := pthread_attr_init (Thread_Attr'Access);
+ pragma Assert (Result in 0 | ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result :=
+ pthread_attr_setstacksize (Thread_Attr'Access, Adjusted_Stack_Size);
+ pragma Assert (Result = 0);
+
+ Result :=
+ pthread_attr_setdetachstate
+ (Thread_Attr'Access, PTHREAD_CREATE_DETACHED);
+ pragma Assert (Result = 0);
+
+ -- Set the required attributes for the creation of the thread
+
+ -- Note: Previously, we called pthread_setaffinity_np (after thread
+ -- creation but before thread activation) to set the affinity but it was
+ -- not behaving as expected. Setting the required attributes for the
+ -- creation of the thread works correctly and it is more appropriate.
+
+ -- Do nothing if required support not provided by the operating system
+
+ if pthread_attr_setaffinity_np'Address = Null_Address then
+ null;
+
+ -- Support is available
+
+ elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
+ declare
+ CPUs : constant size_t :=
+ C.size_t (Multiprocessors.Number_Of_CPUs);
+ CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
+ Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
+
+ begin
+ CPU_ZERO (Size, CPU_Set);
+ System.OS_Interface.CPU_SET
+ (int (T.Common.Base_CPU), Size, CPU_Set);
+ Result :=
+ pthread_attr_setaffinity_np (Thread_Attr'Access, Size, CPU_Set);
+ pragma Assert (Result = 0);
+
+ CPU_FREE (CPU_Set);
+ end;
+
+ -- Handle Task_Info
+
+ elsif T.Common.Task_Info /= null then
+ Result :=
+ pthread_attr_setaffinity_np
+ (Thread_Attr'Access,
+ CPU_SETSIZE / 8,
+ T.Common.Task_Info.CPU_Affinity'Access);
+ pragma Assert (Result = 0);
+
+ -- Handle dispatching domains
+
+ -- To avoid changing CPU affinities when not needed, we set the
+ -- affinity only when assigning to a domain other than the default
+ -- one, or when the default one has been modified.
+
+ elsif T.Common.Domain /= null and then
+ (T.Common.Domain /= ST.System_Domain
+ or else T.Common.Domain.all /=
+ (Multiprocessors.CPU'First ..
+ Multiprocessors.Number_Of_CPUs => True))
+ then
+ declare
+ CPUs : constant size_t :=
+ C.size_t (Multiprocessors.Number_Of_CPUs);
+ CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
+ Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
+
+ begin
+ CPU_ZERO (Size, CPU_Set);
+
+ -- Set the affinity to all the processors belonging to the
+ -- dispatching domain.
+
+ for Proc in T.Common.Domain'Range loop
+ if T.Common.Domain (Proc) then
+ System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
+ end if;
+ end loop;
+
+ Result :=
+ pthread_attr_setaffinity_np (Thread_Attr'Access, Size, CPU_Set);
+ pragma Assert (Result = 0);
+
+ CPU_FREE (CPU_Set);
+ end;
+ end if;
+
+ -- Since the initial signal mask of a thread is inherited from the
+ -- creator, and the Environment task has all its signals masked, we
+ -- do not need to manipulate caller's signal mask at this point.
+ -- All tasks in RTS will have All_Tasks_Mask initially.
+
+ -- Note: the use of Unrestricted_Access in the following call is needed
+ -- because otherwise we have an error of getting a access-to-volatile
+ -- value which points to a non-volatile object. But in this case it is
+ -- safe to do this, since we know we have no problems with aliasing and
+ -- Unrestricted_Access bypasses this check.
+
+ Result := pthread_create
+ (T.Common.LL.Thread'Unrestricted_Access,
+ Thread_Attr'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
+
+ pragma Assert (Result in 0 | EAGAIN | ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ Result := pthread_attr_destroy (Thread_Attr'Access);
+ pragma Assert (Result = 0);
+ return;
+ end if;
+
+ Succeeded := True;
+
+ Result := pthread_attr_destroy (Thread_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Set_Priority (T, Priority);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_Id) is
+ Result : C.int;
+
+ begin
+ if not Single_Lock then
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := pthread_cond_destroy (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ ATCB_Allocation.Free_ATCB (T);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ Specific.Set (null);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
+ Result : C.int;
+
+ ESRCH : constant := 3; -- No such process
+ -- It can happen that T has already vanished, in which case pthread_kill
+ -- returns ESRCH, so we don't consider that to be an error.
+
+ begin
+ if Abort_Handler_Installed then
+ Result :=
+ pthread_kill
+ (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ pragma Assert (Result in 0 | ESRCH);
+ end if;
+ end Abort_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ Result : C.int;
+
+ begin
+ -- Initialize internal state (always to False (RM D.10(6)))
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ Result := pthread_mutex_init (S.L'Access, null);
+
+ pragma Assert (Result in 0 | ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ -- Initialize internal condition variable
+
+ Result := pthread_cond_init (S.CV'Access, null);
+
+ pragma Assert (Result in 0 | ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+ end if;
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ Result : C.int;
+
+ begin
+ -- Destroy internal mutex
+
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- Destroy internal condition variable
+
+ Result := pthread_cond_destroy (S.CV'Access);
+ pragma Assert (Result = 0);
+ end Finalize;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ begin
+ -- We do not want to use lock on this read operation. State is marked
+ -- as Atomic so that we ensure that the value retrieved is correct.
+
+ return S.State;
+ end Current_State;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ Result : C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ S.State := False;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ Result : C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- If there is already a task waiting on this suspension object then
+ -- we resume it, leaving the state of the suspension object to False,
+ -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
+ -- the state to True.
+
+ if S.Waiting then
+ S.Waiting := False;
+ S.State := False;
+
+ Result := pthread_cond_signal (S.CV'Access);
+ pragma Assert (Result = 0);
+
+ else
+ S.State := True;
+ end if;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ Result : C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if S.Waiting then
+
+ -- Program_Error must be raised upon calling Suspend_Until_True
+ -- if another task is already waiting on that suspension object
+ -- (RM D.10(10)).
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+
+ raise Program_Error;
+
+ else
+ -- Suspend the task if the state is False. Otherwise, the task
+ -- continues its execution, and the state of the suspension object
+ -- is set to False (ARM D.10 par. 9).
+
+ if S.State then
+ S.State := False;
+ else
+ S.Waiting := True;
+
+ loop
+ -- Loop in case pthread_cond_wait returns earlier than expected
+ -- (e.g. in case of EINTR caused by a signal). This should not
+ -- happen with the current Linux implementation of pthread, but
+ -- POSIX does not guarantee it so this may change in future.
+
+ Result := pthread_cond_wait (S.CV'Access, S.L'Access);
+ pragma Assert (Result in 0 | EINTR);
+
+ exit when not S.Waiting;
+ end loop;
+ end if;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end if;
+ end Suspend_Until_True;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy version
+
+ function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
+ pragma Unreferenced (Self_ID);
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
+ pragma Unreferenced (Self_ID);
+ begin
+ return True;
+ end Check_No_Locks;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_Id is
+ begin
+ return Environment_Task_Id;
+ end Environment_Task;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0;
+ else
+ return True;
+ end if;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0;
+ else
+ return True;
+ end if;
+ end Resume_Task;
+
+ --------------------
+ -- Stop_All_Tasks --
+ --------------------
+
+ procedure Stop_All_Tasks is
+ begin
+ null;
+ end Stop_All_Tasks;
+
+ ---------------
+ -- Stop_Task --
+ ---------------
+
+ function Stop_Task (T : ST.Task_Id) return Boolean is
+ pragma Unreferenced (T);
+ begin
+ return False;
+ end Stop_Task;
+
+ -------------------
+ -- Continue_Task --
+ -------------------
+
+ function Continue_Task (T : ST.Task_Id) return Boolean is
+ pragma Unreferenced (T);
+ begin
+ return False;
+ end Continue_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : C.int;
+ -- Whether to use an alternate signal stack for stack overflows
+
+ function State
+ (Int : System.Interrupt_Management.Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
+ begin
+ Environment_Task_Id := Environment_Task;
+
+ Interrupt_Management.Initialize;
+
+ -- Prepare the set of signals that should be unblocked in all tasks
+
+ Result := sigemptyset (Unblocked_Signal_Mask'Access);
+ pragma Assert (Result = 0);
+
+ for J in Interrupt_Management.Interrupt_ID loop
+ if System.Interrupt_Management.Keep_Unmasked (J) then
+ Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ -- Initialize the global RTS lock
+
+ Specific.Initialize (Environment_Task);
+
+ if Use_Alternate_Stack then
+ Environment_Task.Common.Task_Alternate_Stack :=
+ Alternate_Stack'Address;
+ end if;
+
+ -- Make environment task known here because it doesn't go through
+ -- Activate_Tasks, which does it for all other tasks.
+
+ Known_Tasks (Known_Tasks'First) := Environment_Task;
+ Environment_Task.Known_Tasks_Index := Known_Tasks'First;
+
+ Enter_Task (Environment_Task);
+
+ if State
+ (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
+ then
+ act.sa_flags := 0;
+ act.sa_handler := Abort_Handler'Address;
+
+ Result := sigemptyset (Tmp_Set'Access);
+ pragma Assert (Result = 0);
+ act.sa_mask := Tmp_Set;
+
+ Result :=
+ sigaction
+ (Signal (Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ Abort_Handler_Installed := True;
+ end if;
+
+ -- pragma CPU and dispatching domains for the environment task
+
+ Set_Task_Affinity (Environment_Task);
+ end Initialize;
+
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ use type Multiprocessors.CPU_Range;
+
+ begin
+ -- Do nothing if there is no support for setting affinities or the
+ -- underlying thread has not yet been created. If the thread has not
+ -- yet been created then the proper affinity will be set during its
+ -- creation.
+
+ if pthread_setaffinity_np'Address /= Null_Address
+ and then T.Common.LL.Thread /= Null_Thread_Id
+ then
+ declare
+ CPUs : constant size_t :=
+ C.size_t (Multiprocessors.Number_Of_CPUs);
+ CPU_Set : cpu_set_t_ptr := null;
+ Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
+
+ Result : C.int;
+
+ begin
+ -- We look at the specific CPU (Base_CPU) first, then at the
+ -- Task_Info field, and finally at the assigned dispatching
+ -- domain, if any.
+
+ if T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
+
+ -- Set the affinity to an unique CPU
+
+ CPU_Set := CPU_ALLOC (CPUs);
+ System.OS_Interface.CPU_ZERO (Size, CPU_Set);
+ System.OS_Interface.CPU_SET
+ (int (T.Common.Base_CPU), Size, CPU_Set);
+
+ -- Handle Task_Info
+
+ elsif T.Common.Task_Info /= null then
+ CPU_Set := T.Common.Task_Info.CPU_Affinity'Access;
+
+ -- Handle dispatching domains
+
+ elsif T.Common.Domain /= null and then
+ (T.Common.Domain /= ST.System_Domain
+ or else T.Common.Domain.all /=
+ (Multiprocessors.CPU'First ..
+ Multiprocessors.Number_Of_CPUs => True))
+ then
+ -- Set the affinity to all the processors belonging to the
+ -- dispatching domain. To avoid changing CPU affinities when
+ -- not needed, we set the affinity only when assigning to a
+ -- domain other than the default one, or when the default one
+ -- has been modified.
+
+ CPU_Set := CPU_ALLOC (CPUs);
+ System.OS_Interface.CPU_ZERO (Size, CPU_Set);
+
+ for Proc in T.Common.Domain'Range loop
+ if T.Common.Domain (Proc) then
+ System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
+ end if;
+ end loop;
+ end if;
+
+ -- We set the new affinity if needed. Otherwise, the new task
+ -- will inherit its creator's CPU affinity mask (according to
+ -- the documentation of pthread_setaffinity_np), which is
+ -- consistent with Ada's required semantics.
+
+ if CPU_Set /= null then
+ Result :=
+ pthread_setaffinity_np (T.Common.LL.Thread, Size, CPU_Set);
+ pragma Assert (Result = 0);
+
+ CPU_FREE (CPU_Set);
+ end if;
+ end;
+ end if;
+ end Set_Task_Affinity;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a NT (native) version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with Interfaces.C;
+with Interfaces.C.Strings;
+
+with System.Float_Control;
+with System.Interrupt_Management;
+with System.Multiprocessors;
+with System.OS_Primitives;
+with System.Task_Info;
+with System.Tasking.Debug;
+with System.Win32.Ext;
+
+with System.Soft_Links;
+-- We use System.Soft_Links instead of System.Tasking.Initialization because
+-- the later is a higher level package that we shouldn't depend on. For
+-- example when using the restricted run time, it is replaced by
+-- System.Tasking.Restricted.Stages.
+
+package body System.Task_Primitives.Operations is
+
+ package SSL renames System.Soft_Links;
+
+ use Interfaces.C;
+ use Interfaces.C.Strings;
+ use System.OS_Interface;
+ use System.OS_Primitives;
+ use System.Parameters;
+ use System.Task_Info;
+ use System.Tasking;
+ use System.Tasking.Debug;
+ use System.Win32;
+ use System.Win32.Ext;
+
+ pragma Link_With ("-Xlinker --stack=0x200000,0x1000");
+ -- Change the default stack size (2 MB) for tasking programs on Windows.
+ -- This allows about 1000 tasks running at the same time. Note that
+ -- we set the stack size for non tasking programs on System unit.
+ -- Also note that under Windows XP, we use a Windows XP extension to
+ -- specify the stack size on a per task basis, as done under other OSes.
+
+ ---------------------
+ -- Local Functions --
+ ---------------------
+
+ procedure InitializeCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure InitializeCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import
+ (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
+
+ procedure EnterCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure EnterCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
+
+ procedure LeaveCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure LeaveCriticalSection (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
+
+ procedure DeleteCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure DeleteCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
+
+ ----------------
+ -- Local Data --
+ ----------------
+
+ Environment_Task_Id : Task_Id;
+ -- A variable to hold Task_Id for the environment task
+
+ Single_RTS_Lock : aliased RTS_Lock;
+ -- This is a lock to allow only one thread of control in the RTS at
+ -- a time; it is used to execute in mutual exclusion from all other tasks.
+ -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ function Get_Policy (Prio : System.Any_Priority) return Character;
+ pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
+ -- Get priority specific dispatching policy
+
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads)
+
+ Null_Thread_Id : constant Thread_Id := 0;
+ -- Constant to indicate that the thread identifier has not yet been
+ -- initialized.
+
+ ------------------------------------
+ -- The thread local storage index --
+ ------------------------------------
+
+ TlsIndex : DWORD;
+ pragma Export (Ada, TlsIndex);
+ -- To ensure that this variable won't be local to this package, since
+ -- in some cases, inlining forces this variable to be global anyway.
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does executing thread have a TCB?
+
+ procedure Set (Self_Id : Task_Id);
+ pragma Inline (Set);
+ -- Set the self id for the current task
+
+ end Specific;
+
+ package body Specific is
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return TlsGetValue (TlsIndex) /= System.Null_Address;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ Succeeded : BOOL;
+ begin
+ Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
+ pragma Assert (Succeeded = Win32.TRUE);
+ end Set;
+
+ end Specific;
+
+ ----------------------------------
+ -- ATCB allocation/deallocation --
+ ----------------------------------
+
+ package body ATCB_Allocation is separate;
+ -- The body of this package is shared across several targets
+
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
+ -- Allocate and Initialize a new ATCB for the current Thread
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_Id is separate;
+
+ ----------------------------------
+ -- Condition Variable Functions --
+ ----------------------------------
+
+ procedure Initialize_Cond (Cond : not null access Condition_Variable);
+ -- Initialize given condition variable Cond
+
+ procedure Finalize_Cond (Cond : not null access Condition_Variable);
+ -- Finalize given condition variable Cond
+
+ procedure Cond_Signal (Cond : not null access Condition_Variable);
+ -- Signal condition variable Cond
+
+ procedure Cond_Wait
+ (Cond : not null access Condition_Variable;
+ L : not null access RTS_Lock);
+ -- Wait on conditional variable Cond, using lock L
+
+ procedure Cond_Timed_Wait
+ (Cond : not null access Condition_Variable;
+ L : not null access RTS_Lock;
+ Rel_Time : Duration;
+ Timed_Out : out Boolean;
+ Status : out Integer);
+ -- Do timed wait on condition variable Cond using lock L. The duration
+ -- of the timed wait is given by Rel_Time. When the condition is
+ -- signalled, Timed_Out shows whether or not a time out occurred.
+ -- Status is only valid if Timed_Out is False, in which case it
+ -- shows whether Cond_Timed_Wait completed successfully.
+
+ ---------------------
+ -- Initialize_Cond --
+ ---------------------
+
+ procedure Initialize_Cond (Cond : not null access Condition_Variable) is
+ hEvent : HANDLE;
+ begin
+ hEvent := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
+ pragma Assert (hEvent /= 0);
+ Cond.all := Condition_Variable (hEvent);
+ end Initialize_Cond;
+
+ -------------------
+ -- Finalize_Cond --
+ -------------------
+
+ -- No such problem here, DosCloseEventSem has been derived.
+ -- What does such refer to in above comment???
+
+ procedure Finalize_Cond (Cond : not null access Condition_Variable) is
+ Result : BOOL;
+ begin
+ Result := CloseHandle (HANDLE (Cond.all));
+ pragma Assert (Result = Win32.TRUE);
+ end Finalize_Cond;
+
+ -----------------
+ -- Cond_Signal --
+ -----------------
+
+ procedure Cond_Signal (Cond : not null access Condition_Variable) is
+ Result : BOOL;
+ begin
+ Result := SetEvent (HANDLE (Cond.all));
+ pragma Assert (Result = Win32.TRUE);
+ end Cond_Signal;
+
+ ---------------
+ -- Cond_Wait --
+ ---------------
+
+ -- Pre-condition: Cond is posted
+ -- L is locked.
+
+ -- Post-condition: Cond is posted
+ -- L is locked.
+
+ procedure Cond_Wait
+ (Cond : not null access Condition_Variable;
+ L : not null access RTS_Lock)
+ is
+ Result : DWORD;
+ Result_Bool : BOOL;
+
+ begin
+ -- Must reset Cond BEFORE L is unlocked
+
+ Result_Bool := ResetEvent (HANDLE (Cond.all));
+ pragma Assert (Result_Bool = Win32.TRUE);
+ Unlock (L, Global_Lock => True);
+
+ -- No problem if we are interrupted here: if the condition is signaled,
+ -- WaitForSingleObject will simply not block
+
+ Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
+ pragma Assert (Result = 0);
+
+ Write_Lock (L, Global_Lock => True);
+ end Cond_Wait;
+
+ ---------------------
+ -- Cond_Timed_Wait --
+ ---------------------
+
+ -- Pre-condition: Cond is posted
+ -- L is locked.
+
+ -- Post-condition: Cond is posted
+ -- L is locked.
+
+ procedure Cond_Timed_Wait
+ (Cond : not null access Condition_Variable;
+ L : not null access RTS_Lock;
+ Rel_Time : Duration;
+ Timed_Out : out Boolean;
+ Status : out Integer)
+ is
+ Time_Out_Max : constant DWORD := 16#FFFF0000#;
+ -- NT 4 can't handle excessive timeout values (e.g. DWORD'Last - 1)
+
+ Time_Out : DWORD;
+ Result : BOOL;
+ Wait_Result : DWORD;
+
+ begin
+ -- Must reset Cond BEFORE L is unlocked
+
+ Result := ResetEvent (HANDLE (Cond.all));
+ pragma Assert (Result = Win32.TRUE);
+ Unlock (L, Global_Lock => True);
+
+ -- No problem if we are interrupted here: if the condition is signaled,
+ -- WaitForSingleObject will simply not block.
+
+ if Rel_Time <= 0.0 then
+ Timed_Out := True;
+ Wait_Result := 0;
+
+ else
+ Time_Out :=
+ (if Rel_Time >= Duration (Time_Out_Max) / 1000
+ then Time_Out_Max
+ else DWORD (Rel_Time * 1000));
+
+ Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
+
+ if Wait_Result = WAIT_TIMEOUT then
+ Timed_Out := True;
+ Wait_Result := 0;
+ else
+ Timed_Out := False;
+ end if;
+ end if;
+
+ Write_Lock (L, Global_Lock => True);
+
+ -- Ensure post-condition
+
+ if Timed_Out then
+ Result := SetEvent (HANDLE (Cond.all));
+ pragma Assert (Result = Win32.TRUE);
+ end if;
+
+ Status := Integer (Wait_Result);
+ end Cond_Timed_Wait;
+
+ ------------------
+ -- Stack_Guard --
+ ------------------
+
+ -- The underlying thread system sets a guard page at the bottom of a thread
+ -- stack, so nothing is needed.
+ -- ??? Check the comment above
+
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ pragma Unreferenced (T, On);
+ begin
+ null;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id is
+ Self_Id : constant Task_Id := To_Task_Id (TlsGetValue (TlsIndex));
+ begin
+ if Self_Id = null then
+ return Register_Foreign_Thread (GetCurrentThread);
+ else
+ return Self_Id;
+ end if;
+ end Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are initialized
+ -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
+ -- as RTS_Lock, Memory_Lock...) used in the RTS is initialized before any
+ -- status change of RTS. Therefore raising Storage_Error in the following
+ -- routines should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : not null access Lock)
+ is
+ begin
+ InitializeCriticalSection (L.Mutex'Access);
+ L.Owner_Priority := 0;
+ L.Priority := Prio;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock; Level : Lock_Level)
+ is
+ pragma Unreferenced (Level);
+ begin
+ InitializeCriticalSection (L);
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : not null access Lock) is
+ begin
+ DeleteCriticalSection (L.Mutex'Access);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : not null access RTS_Lock) is
+ begin
+ DeleteCriticalSection (L);
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock
+ (L : not null access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ L.Owner_Priority := Get_Priority (Self);
+
+ if L.Priority < L.Owner_Priority then
+ Ceiling_Violation := True;
+ return;
+ end if;
+
+ EnterCriticalSection (L.Mutex'Access);
+
+ Ceiling_Violation := False;
+ end Write_Lock;
+
+ procedure Write_Lock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ begin
+ if not Single_Lock or else Global_Lock then
+ EnterCriticalSection (L);
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_Id) is
+ begin
+ if not Single_Lock then
+ EnterCriticalSection (T.Common.LL.L'Access);
+ end if;
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock
+ (L : not null access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : not null access Lock) is
+ begin
+ LeaveCriticalSection (L.Mutex'Access);
+ end Unlock;
+
+ procedure Unlock
+ (L : not null access RTS_Lock; Global_Lock : Boolean := False) is
+ begin
+ if not Single_Lock or else Global_Lock then
+ LeaveCriticalSection (L);
+ end if;
+ end Unlock;
+
+ procedure Unlock (T : Task_Id) is
+ begin
+ if not Single_Lock then
+ LeaveCriticalSection (T.Common.LL.L'Access);
+ end if;
+ end Unlock;
+
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep
+ (Self_ID : Task_Id;
+ Reason : System.Tasking.Task_States)
+ is
+ pragma Unreferenced (Reason);
+
+ begin
+ pragma Assert (Self_ID = Self);
+
+ if Single_Lock then
+ Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ else
+ Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ end if;
+
+ if Self_ID.Deferral_Level = 0
+ and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ then
+ Unlock (Self_ID);
+ raise Standard'Abort_Signal;
+ end if;
+ end Sleep;
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ -- This is for use within the run-time system, so abort is assumed to be
+ -- already deferred, and the caller should be holding its own ATCB lock.
+
+ procedure Timed_Sleep
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ pragma Unreferenced (Reason);
+ Check_Time : Duration := Monotonic_Clock;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
+
+ Local_Timedout : Boolean;
+
+ begin
+ Timedout := True;
+ Yielded := False;
+
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ if Single_Lock then
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Rel_Time, Local_Timedout, Result);
+ else
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Rel_Time, Local_Timedout, Result);
+ end if;
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time;
+
+ if not Local_Timedout then
+
+ -- Somebody may have called Wakeup for us
+
+ Timedout := False;
+ exit;
+ end if;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Check_Time : Duration := Monotonic_Clock;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+
+ Timedout : Boolean;
+ Result : Integer;
+ pragma Unreferenced (Timedout, Result);
+
+ begin
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ Write_Lock (Self_ID);
+
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ if Single_Lock then
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Rel_Time, Timedout, Result);
+ else
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Rel_Time, Timedout, Result);
+ end if;
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ Yield;
+ end Timed_Delay;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+ begin
+ Cond_Signal (T.Common.LL.CV'Access);
+ end Wakeup;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ begin
+ -- Note: in a previous implementation if Do_Yield was False, then we
+ -- introduced a delay of 1 millisecond in an attempt to get closer to
+ -- annex D semantics, and in particular to make ACATS CXD8002 pass. But
+ -- this change introduced a huge performance regression evaluating the
+ -- Count attribute. So we decided to remove this processing.
+
+ -- Moreover, CXD8002 appears to pass on Windows (although we do not
+ -- guarantee full Annex D compliance on Windows in any case).
+
+ if Do_Yield then
+ SwitchToThread;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_Id;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Res : BOOL;
+ pragma Unreferenced (Loss_Of_Inheritance);
+
+ begin
+ Res :=
+ SetThreadPriority
+ (T.Common.LL.Thread,
+ Interfaces.C.int (Underlying_Priorities (Prio)));
+ pragma Assert (Res = Win32.TRUE);
+
+ -- Note: Annex D (RM D.2.3(5/2)) requires the task to be placed at the
+ -- head of its priority queue when decreasing its priority as a result
+ -- of a loss of inherited priority. This is not the case, but we
+ -- consider it an acceptable variation (RM 1.1.3(6)), given this is
+ -- the built-in behavior offered by the Windows operating system.
+
+ -- In older versions we attempted to better approximate the Annex D
+ -- required behavior, but this simulation was not entirely accurate,
+ -- and it seems better to live with the standard Windows semantics.
+
+ T.Common.Current_Priority := Prio;
+ end Set_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_Id) return System.Any_Priority is
+ begin
+ return T.Common.Current_Priority;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ -- There were two paths were we needed to call Enter_Task :
+ -- 1) from System.Task_Primitives.Operations.Initialize
+ -- 2) from System.Tasking.Stages.Task_Wrapper
+
+ -- The pseudo handle (LL.Thread) need not be closed when it is no
+ -- longer needed. Calling the CloseHandle function with this handle
+ -- has no effect.
+
+ procedure Enter_Task (Self_ID : Task_Id) is
+ procedure Get_Stack_Bounds (Base : Address; Limit : Address);
+ pragma Import (C, Get_Stack_Bounds, "__gnat_get_stack_bounds");
+ -- Get stack boundaries
+ begin
+ Specific.Set (Self_ID);
+
+ -- Properly initializes the FPU for x86 systems
+
+ System.Float_Control.Reset;
+
+ if Self_ID.Common.Task_Info /= null
+ and then
+ Self_ID.Common.Task_Info.CPU >= CPU_Number (Number_Of_Processors)
+ then
+ raise Invalid_CPU_Number;
+ end if;
+
+ Self_ID.Common.LL.Thread := GetCurrentThread;
+ Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
+
+ Get_Stack_Bounds
+ (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base'Address,
+ Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address);
+ end Enter_Task;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_Id is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (GetCurrentThread);
+ end if;
+ end Register_Foreign_Thread;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
+ begin
+ -- Initialize thread ID to 0, this is needed to detect threads that
+ -- are not yet activated.
+
+ Self_ID.Common.LL.Thread := Null_Thread_Id;
+
+ Initialize_Cond (Self_ID.Common.LL.CV'Access);
+
+ if not Single_Lock then
+ Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
+ end if;
+
+ Succeeded := True;
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_Id;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ Initial_Stack_Size : constant := 1024;
+ -- We set the initial stack size to 1024. On Windows version prior to XP
+ -- there is no way to fix a task stack size. Only the initial stack size
+ -- can be set, the operating system will raise the task stack size if
+ -- needed.
+
+ function Is_Windows_XP return Integer;
+ pragma Import (C, Is_Windows_XP, "__gnat_is_windows_xp");
+ -- Returns 1 if running on Windows XP
+
+ hTask : HANDLE;
+ TaskId : aliased DWORD;
+ pTaskParameter : Win32.PVOID;
+ Result : DWORD;
+ Entry_Point : PTHREAD_START_ROUTINE;
+
+ use type System.Multiprocessors.CPU_Range;
+
+ begin
+ -- Check whether both Dispatching_Domain and CPU are specified for the
+ -- task, and the CPU value is not contained within the range of
+ -- processors for the domain.
+
+ if T.Common.Domain /= null
+ and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
+ and then
+ (T.Common.Base_CPU not in T.Common.Domain'Range
+ or else not T.Common.Domain (T.Common.Base_CPU))
+ then
+ Succeeded := False;
+ return;
+ end if;
+
+ pTaskParameter := To_Address (T);
+
+ Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
+
+ if Is_Windows_XP = 1 then
+ hTask := CreateThread
+ (null,
+ DWORD (Stack_Size),
+ Entry_Point,
+ pTaskParameter,
+ DWORD (Create_Suspended)
+ or DWORD (Stack_Size_Param_Is_A_Reservation),
+ TaskId'Unchecked_Access);
+ else
+ hTask := CreateThread
+ (null,
+ Initial_Stack_Size,
+ Entry_Point,
+ pTaskParameter,
+ DWORD (Create_Suspended),
+ TaskId'Unchecked_Access);
+ end if;
+
+ -- Step 1: Create the thread in blocked mode
+
+ if hTask = 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ -- Step 2: set its TCB
+
+ T.Common.LL.Thread := hTask;
+
+ -- Note: it would be useful to initialize Thread_Id right away to avoid
+ -- a race condition in gdb where Thread_ID may not have the right value
+ -- yet, but GetThreadId is a Vista specific API, not available under XP:
+ -- T.Common.LL.Thread_Id := GetThreadId (hTask); so instead we set the
+ -- field to 0 to avoid having a random value. Thread_Id is initialized
+ -- in Enter_Task anyway.
+
+ T.Common.LL.Thread_Id := 0;
+
+ -- Step 3: set its priority (child has inherited priority from parent)
+
+ Set_Priority (T, Priority);
+
+ if Time_Slice_Val = 0
+ or else Dispatching_Policy = 'F'
+ or else Get_Policy (Priority) = 'F'
+ then
+ -- Here we need Annex D semantics so we disable the NT priority
+ -- boost. A priority boost is temporarily given by the system to
+ -- a thread when it is taken out of a wait state.
+
+ SetThreadPriorityBoost (hTask, DisablePriorityBoost => Win32.TRUE);
+ end if;
+
+ -- Step 4: Handle pragma CPU and Task_Info
+
+ Set_Task_Affinity (T);
+
+ -- Step 5: Now, start it for good
+
+ Result := ResumeThread (hTask);
+ pragma Assert (Result = 1);
+
+ Succeeded := Result = 1;
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_Id) is
+ Succeeded : BOOL;
+ pragma Unreferenced (Succeeded);
+
+ begin
+ if not Single_Lock then
+ Finalize_Lock (T.Common.LL.L'Access);
+ end if;
+
+ Finalize_Cond (T.Common.LL.CV'Access);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ if T.Common.LL.Thread /= 0 then
+
+ -- This task has been activated. Close the thread handle. This
+ -- is needed to release system resources.
+
+ Succeeded := CloseHandle (T.Common.LL.Thread);
+ -- Note that we do not check for the returned value, this is
+ -- because the above call will fail for a foreign thread. But
+ -- we still need to call it to properly close Ada tasks created
+ -- with CreateThread() in Create_Task above.
+ end if;
+
+ ATCB_Allocation.Free_ATCB (T);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ Specific.Set (null);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
+ pragma Unreferenced (T);
+ begin
+ null;
+ end Abort_Task;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_Id is
+ begin
+ return Environment_Task_Id;
+ end Environment_Task;
+
+ --------------
+ -- Lock_RTS --
+ --------------
+
+ procedure Lock_RTS is
+ begin
+ Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Lock_RTS;
+
+ ----------------
+ -- Unlock_RTS --
+ ----------------
+
+ procedure Unlock_RTS is
+ begin
+ Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Unlock_RTS;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ Discard : BOOL;
+
+ begin
+ Environment_Task_Id := Environment_Task;
+ OS_Primitives.Initialize;
+ Interrupt_Management.Initialize;
+
+ if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
+ -- Here we need Annex D semantics, switch the current process to the
+ -- Realtime_Priority_Class.
+
+ Discard := OS_Interface.SetPriorityClass
+ (GetCurrentProcess, Realtime_Priority_Class);
+ end if;
+
+ TlsIndex := TlsAlloc;
+
+ -- Initialize the lock used to synchronize chain of all ATCBs
+
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ Environment_Task.Common.LL.Thread := GetCurrentThread;
+
+ -- Make environment task known here because it doesn't go through
+ -- Activate_Tasks, which does it for all other tasks.
+
+ Known_Tasks (Known_Tasks'First) := Environment_Task;
+ Environment_Task.Known_Tasks_Index := Known_Tasks'First;
+
+ Enter_Task (Environment_Task);
+
+ -- pragma CPU and dispatching domains for the environment task
+
+ Set_Task_Affinity (Environment_Task);
+ end Initialize;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ function Internal_Clock return Duration;
+ pragma Import (Ada, Internal_Clock, "__gnat_monotonic_clock");
+ begin
+ return Internal_Clock;
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ Ticks_Per_Second : aliased LARGE_INTEGER;
+ begin
+ QueryPerformanceFrequency (Ticks_Per_Second'Access);
+ return Duration (1.0 / Ticks_Per_Second);
+ end RT_Resolution;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ begin
+ -- Initialize internal state. It is always initialized to False (ARM
+ -- D.10 par. 6).
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ InitializeCriticalSection (S.L'Access);
+
+ -- Initialize internal condition variable
+
+ S.CV := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
+ pragma Assert (S.CV /= 0);
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ Result : BOOL;
+
+ begin
+ -- Destroy internal mutex
+
+ DeleteCriticalSection (S.L'Access);
+
+ -- Destroy internal condition variable
+
+ Result := CloseHandle (S.CV);
+ pragma Assert (Result = Win32.TRUE);
+ end Finalize;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ begin
+ -- We do not want to use lock on this read operation. State is marked
+ -- as Atomic so that we ensure that the value retrieved is correct.
+
+ return S.State;
+ end Current_State;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ begin
+ SSL.Abort_Defer.all;
+
+ EnterCriticalSection (S.L'Access);
+
+ S.State := False;
+
+ LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ Result : BOOL;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ EnterCriticalSection (S.L'Access);
+
+ -- If there is already a task waiting on this suspension object then
+ -- we resume it, leaving the state of the suspension object to False,
+ -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
+ -- the state to True.
+
+ if S.Waiting then
+ S.Waiting := False;
+ S.State := False;
+
+ Result := SetEvent (S.CV);
+ pragma Assert (Result = Win32.TRUE);
+
+ else
+ S.State := True;
+ end if;
+
+ LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ Result : DWORD;
+ Result_Bool : BOOL;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ EnterCriticalSection (S.L'Access);
+
+ if S.Waiting then
+
+ -- Program_Error must be raised upon calling Suspend_Until_True
+ -- if another task is already waiting on that suspension object
+ -- (ARM D.10 par. 10).
+
+ LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
+
+ raise Program_Error;
+
+ else
+ -- Suspend the task if the state is False. Otherwise, the task
+ -- continues its execution, and the state of the suspension object
+ -- is set to False (ARM D.10 par. 9).
+
+ if S.State then
+ S.State := False;
+
+ LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
+
+ else
+ S.Waiting := True;
+
+ -- Must reset CV BEFORE L is unlocked
+
+ Result_Bool := ResetEvent (S.CV);
+ pragma Assert (Result_Bool = Win32.TRUE);
+
+ LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
+
+ Result := WaitForSingleObject (S.CV, Wait_Infinite);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end Suspend_Until_True;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions, currently this only works for solaris (native)
+
+ function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
+ pragma Unreferenced (Self_ID);
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
+ pragma Unreferenced (Self_ID);
+ begin
+ return True;
+ end Check_No_Locks;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return SuspendThread (T.Common.LL.Thread) = NO_ERROR;
+ else
+ return True;
+ end if;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return ResumeThread (T.Common.LL.Thread) = NO_ERROR;
+ else
+ return True;
+ end if;
+ end Resume_Task;
+
+ --------------------
+ -- Stop_All_Tasks --
+ --------------------
+
+ procedure Stop_All_Tasks is
+ begin
+ null;
+ end Stop_All_Tasks;
+
+ ---------------
+ -- Stop_Task --
+ ---------------
+
+ function Stop_Task (T : ST.Task_Id) return Boolean is
+ pragma Unreferenced (T);
+ begin
+ return False;
+ end Stop_Task;
+
+ -------------------
+ -- Continue_Task --
+ -------------------
+
+ function Continue_Task (T : ST.Task_Id) return Boolean is
+ pragma Unreferenced (T);
+ begin
+ return False;
+ end Continue_Task;
+
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ Result : DWORD;
+
+ use type System.Multiprocessors.CPU_Range;
+
+ begin
+ -- Do nothing if the underlying thread has not yet been created. If the
+ -- thread has not yet been created then the proper affinity will be set
+ -- during its creation.
+
+ if T.Common.LL.Thread = Null_Thread_Id then
+ null;
+
+ -- pragma CPU
+
+ elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
+
+ -- The CPU numbering in pragma CPU starts at 1 while the subprogram
+ -- to set the affinity starts at 0, therefore we must substract 1.
+
+ Result :=
+ SetThreadIdealProcessor
+ (T.Common.LL.Thread, ProcessorId (T.Common.Base_CPU) - 1);
+ pragma Assert (Result = 1);
+
+ -- Task_Info
+
+ elsif T.Common.Task_Info /= null then
+ if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then
+ Result :=
+ SetThreadIdealProcessor
+ (T.Common.LL.Thread, T.Common.Task_Info.CPU);
+ pragma Assert (Result = 1);
+ end if;
+
+ -- Dispatching domains
+
+ elsif T.Common.Domain /= null
+ and then (T.Common.Domain /= ST.System_Domain
+ or else
+ T.Common.Domain.all /=
+ (Multiprocessors.CPU'First ..
+ Multiprocessors.Number_Of_CPUs => True))
+ then
+ declare
+ CPU_Set : DWORD := 0;
+
+ begin
+ for Proc in T.Common.Domain'Range loop
+ if T.Common.Domain (Proc) then
+
+ -- The thread affinity mask is a bit vector in which each
+ -- bit represents a logical processor.
+
+ CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1);
+ end if;
+ end loop;
+
+ Result := SetThreadAffinityMask (T.Common.LL.Thread, CPU_Set);
+ pragma Assert (Result = 1);
+ end;
+ end if;
+ end Set_Task_Affinity;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a POSIX-like version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+-- Note: this file can only be used for POSIX compliant systems that implement
+-- SCHED_FIFO and Ceiling Locking correctly.
+
+-- For configurations where SCHED_FIFO and priority ceiling are not a
+-- requirement, this file can also be used (e.g AiX threads)
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+with System.Tasking.Debug;
+with System.Interrupt_Management;
+with System.OS_Constants;
+with System.OS_Primitives;
+with System.Task_Info;
+
+with System.Soft_Links;
+-- We use System.Soft_Links instead of System.Tasking.Initialization
+-- because the later is a higher level package that we shouldn't depend on.
+-- For example when using the restricted run time, it is replaced by
+-- System.Tasking.Restricted.Stages.
+
+package body System.Task_Primitives.Operations is
+
+ package OSC renames System.OS_Constants;
+ package SSL renames System.Soft_Links;
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+
+ ----------------
+ -- Local Data --
+ ----------------
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ Single_RTS_Lock : aliased RTS_Lock;
+ -- This is a lock to allow only one thread of control in the RTS at
+ -- a time; it is used to execute in mutual exclusion from all other tasks.
+ -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+
+ Environment_Task_Id : Task_Id;
+ -- A variable to hold Task_Id for the environment task
+
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+ -- Value of the pragma Locking_Policy:
+ -- 'C' for Ceiling_Locking
+ -- 'I' for Inherit_Locking
+ -- ' ' for none.
+
+ Unblocked_Signal_Mask : aliased sigset_t;
+ -- The set of signals that should unblocked in all tasks
+
+ -- The followings are internal configuration constants needed
+
+ Next_Serial_Number : Task_Serial_Number := 100;
+ -- We start at 100, to reserve some special values for
+ -- using in error checking.
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads)
+
+ Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
+ -- Whether to use an alternate signal stack for stack overflows
+
+ Abort_Handler_Installed : Boolean := False;
+ -- True if a handler for the abort signal is installed
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ procedure Initialize (Environment_Task : Task_Id);
+ pragma Inline (Initialize);
+ -- Initialize various data needed by this package
+
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does executing thread have a TCB?
+
+ procedure Set (Self_Id : Task_Id);
+ pragma Inline (Set);
+ -- Set the self id for the current task
+
+ function Self return Task_Id;
+ pragma Inline (Self);
+ -- Return a pointer to the Ada Task Control Block of the calling task
+
+ end Specific;
+
+ package body Specific is separate;
+ -- The body of this package is target specific
+
+ ----------------------------------
+ -- ATCB allocation/deallocation --
+ ----------------------------------
+
+ package body ATCB_Allocation is separate;
+ -- The body of this package is shared across several targets
+
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
+ -- Allocate and Initialize a new ATCB for the current Thread
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_Id is separate;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler (Sig : Signal);
+ -- Signal handler used to implement asynchronous abort.
+ -- See also comment before body, below.
+
+ function To_Address is
+ new Ada.Unchecked_Conversion (Task_Id, System.Address);
+
+ function GNAT_pthread_condattr_setup
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C,
+ GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
+
+ procedure Compute_Deadline
+ (Time : Duration;
+ Mode : ST.Delay_Modes;
+ Check_Time : out Duration;
+ Abs_Time : out Duration;
+ Rel_Time : out Duration);
+ -- Helper for Timed_Sleep and Timed_Delay: given a deadline specified by
+ -- Time and Mode, compute the current clock reading (Check_Time), and the
+ -- target absolute and relative clock readings (Abs_Time, Rel_Time). The
+ -- epoch for Time depends on Mode; the epoch for Check_Time and Abs_Time
+ -- is always that of CLOCK_RT_Ada.
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ -- Target-dependent binding of inter-thread Abort signal to the raising of
+ -- the Abort_Signal exception.
+
+ -- The technical issues and alternatives here are essentially the
+ -- same as for raising exceptions in response to other signals
+ -- (e.g. Storage_Error). See code and comments in the package body
+ -- System.Interrupt_Management.
+
+ -- Some implementations may not allow an exception to be propagated out of
+ -- a handler, and others might leave the signal or interrupt that invoked
+ -- this handler masked after the exceptional return to the application
+ -- code.
+
+ -- GNAT exceptions are originally implemented using setjmp()/longjmp(). On
+ -- most UNIX systems, this will allow transfer out of a signal handler,
+ -- which is usually the only mechanism available for implementing
+ -- asynchronous handlers of this kind. However, some systems do not
+ -- restore the signal mask on longjmp(), leaving the abort signal masked.
+
+ procedure Abort_Handler (Sig : Signal) is
+ pragma Unreferenced (Sig);
+
+ T : constant Task_Id := Self;
+ Old_Set : aliased sigset_t;
+
+ Result : Interfaces.C.int;
+ pragma Warnings (Off, Result);
+
+ begin
+ -- It's not safe to raise an exception when using GCC ZCX mechanism.
+ -- Note that we still need to install a signal handler, since in some
+ -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
+ -- need to send the Abort signal to a task.
+
+ if ZCX_By_Default then
+ return;
+ end if;
+
+ if T.Deferral_Level = 0
+ and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
+ not T.Aborting
+ then
+ T.Aborting := True;
+
+ -- Make sure signals used for RTS internal purpose are unmasked
+
+ Result := pthread_sigmask (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Access, Old_Set'Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+ end if;
+ end Abort_Handler;
+
+ ----------------------
+ -- Compute_Deadline --
+ ----------------------
+
+ procedure Compute_Deadline
+ (Time : Duration;
+ Mode : ST.Delay_Modes;
+ Check_Time : out Duration;
+ Abs_Time : out Duration;
+ Rel_Time : out Duration)
+ is
+ begin
+ Check_Time := Monotonic_Clock;
+
+ -- Relative deadline
+
+ if Mode = Relative then
+ Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
+
+ if Relative_Timed_Wait then
+ Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
+ end if;
+
+ pragma Warnings (Off);
+ -- Comparison "OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME" is compile
+ -- time known.
+
+ -- Absolute deadline specified using the tasking clock (CLOCK_RT_Ada)
+
+ elsif Mode = Absolute_RT
+ or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME
+ then
+ pragma Warnings (On);
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+
+ if Relative_Timed_Wait then
+ Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
+ end if;
+
+ -- Absolute deadline specified using the calendar clock, in the
+ -- case where it is not the same as the tasking clock: compensate for
+ -- difference between clock epochs (Base_Time - Base_Cal_Time).
+
+ else
+ declare
+ Cal_Check_Time : constant Duration := OS_Primitives.Clock;
+ RT_Time : constant Duration :=
+ Time + Check_Time - Cal_Check_Time;
+
+ begin
+ Abs_Time :=
+ Duration'Min (Check_Time + Max_Sensible_Delay, RT_Time);
+
+ if Relative_Timed_Wait then
+ Rel_Time :=
+ Duration'Min (Max_Sensible_Delay, RT_Time - Check_Time);
+ end if;
+ end;
+ end if;
+ end Compute_Deadline;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread);
+ Page_Size : Address;
+ Res : Interfaces.C.int;
+
+ begin
+ if Stack_Base_Available then
+
+ -- Compute the guard page address
+
+ Page_Size := Address (Get_Page_Size);
+ Res :=
+ mprotect
+ (Stack_Base - (Stack_Base mod Page_Size) + Page_Size,
+ size_t (Page_Size),
+ prot => (if On then PROT_ON else PROT_OFF));
+ pragma Assert (Res = 0);
+ end if;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id renames Specific.Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are initialized
+ -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
+ -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
+ -- status change of RTS. Therefore raising Storage_Error in the following
+ -- routines should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : not null access Lock)
+ is
+ Attributes : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutexattr_init (Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ if Locking_Policy = 'C' then
+ Result := pthread_mutexattr_setprotocol
+ (Attributes'Access, PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Attributes'Access, Interfaces.C.int (Prio));
+ pragma Assert (Result = 0);
+
+ elsif Locking_Policy = 'I' then
+ Result := pthread_mutexattr_setprotocol
+ (Attributes'Access, PTHREAD_PRIO_INHERIT);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := pthread_mutex_init (L.WO'Access, Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock; Level : Lock_Level)
+ is
+ pragma Unreferenced (Level);
+
+ Attributes : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutexattr_init (Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ if Locking_Policy = 'C' then
+ Result := pthread_mutexattr_setprotocol
+ (Attributes'Access, PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
+ pragma Assert (Result = 0);
+
+ elsif Locking_Policy = 'I' then
+ Result := pthread_mutexattr_setprotocol
+ (Attributes'Access, PTHREAD_PRIO_INHERIT);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := pthread_mutex_init (L, Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : not null access Lock) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_destroy (L.WO'Access);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : not null access RTS_Lock) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_destroy (L);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock
+ (L : not null access Lock; Ceiling_Violation : out Boolean)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_lock (L.WO'Access);
+
+ -- The cause of EINVAL is a priority ceiling violation
+
+ Ceiling_Violation := Result = EINVAL;
+ pragma Assert (Result = 0 or else Ceiling_Violation);
+ end Write_Lock;
+
+ procedure Write_Lock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock or else Global_Lock then
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock then
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock
+ (L : not null access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : not null access Lock) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_unlock (L.WO'Access);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock
+ (L : not null access RTS_Lock; Global_Lock : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock or else Global_Lock then
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ procedure Unlock (T : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock then
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep
+ (Self_ID : Task_Id;
+ Reason : System.Tasking.Task_States)
+ is
+ pragma Unreferenced (Reason);
+
+ Result : Interfaces.C.int;
+
+ begin
+ Result :=
+ pthread_cond_wait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access));
+
+ -- EINTR is not considered a failure
+
+ pragma Assert (Result = 0 or else Result = EINTR);
+ end Sleep;
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ -- This is for use within the run-time system, so abort is
+ -- assumed to be already deferred, and the caller should be
+ -- holding its own ATCB lock.
+
+ procedure Timed_Sleep
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ pragma Unreferenced (Reason);
+
+ Base_Time : Duration;
+ Check_Time : Duration;
+ Abs_Time : Duration;
+ Rel_Time : Duration;
+
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ Timedout := True;
+ Yielded := False;
+
+ Compute_Deadline
+ (Time => Time,
+ Mode => Mode,
+ Check_Time => Check_Time,
+ Abs_Time => Abs_Time,
+ Rel_Time => Rel_Time);
+ Base_Time := Check_Time;
+
+ if Abs_Time > Check_Time then
+ Request :=
+ To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time);
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result :=
+ pthread_cond_timedwait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access),
+ abstime => Request'Access);
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ if Result = 0 or Result = EINTR then
+
+ -- Somebody may have called Wakeup for us
+
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIMEDOUT);
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ -- This is for use in implementing delay statements, so we assume the
+ -- caller is abort-deferred but is holding no locks.
+
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Base_Time : Duration;
+ Check_Time : Duration;
+ Abs_Time : Duration;
+ Rel_Time : Duration;
+ Request : aliased timespec;
+
+ Result : Interfaces.C.int;
+ pragma Warnings (Off, Result);
+
+ begin
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ Write_Lock (Self_ID);
+
+ Compute_Deadline
+ (Time => Time,
+ Mode => Mode,
+ Check_Time => Check_Time,
+ Abs_Time => Abs_Time,
+ Rel_Time => Rel_Time);
+ Base_Time := Check_Time;
+
+ if Abs_Time > Check_Time then
+ Request :=
+ To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ Result :=
+ pthread_cond_timedwait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access),
+ abstime => Request'Access);
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ pragma Assert (Result = 0
+ or else Result = ETIMEDOUT
+ or else Result = EINTR);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ Result := sched_yield;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+ begin
+ Result := clock_gettime
+ (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+ begin
+ Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ return To_Duration (TS);
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_cond_signal (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ end Wakeup;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ Result : Interfaces.C.int;
+ pragma Unreferenced (Result);
+ begin
+ if Do_Yield then
+ Result := sched_yield;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_Id;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ pragma Unreferenced (Loss_Of_Inheritance);
+
+ Result : Interfaces.C.int;
+ Param : aliased struct_sched_param;
+
+ function Get_Policy (Prio : System.Any_Priority) return Character;
+ pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
+ -- Get priority specific dispatching policy
+
+ Priority_Specific_Policy : constant Character := Get_Policy (Prio);
+ -- Upper case first character of the policy name corresponding to the
+ -- task as set by a Priority_Specific_Dispatching pragma.
+
+ begin
+ T.Common.Current_Priority := Prio;
+ Param.sched_priority := To_Target_Priority (Prio);
+
+ if Time_Slice_Supported
+ and then (Dispatching_Policy = 'R'
+ or else Priority_Specific_Policy = 'R'
+ or else Time_Slice_Val > 0)
+ then
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
+
+ elsif Dispatching_Policy = 'F'
+ or else Priority_Specific_Policy = 'F'
+ or else Time_Slice_Val = 0
+ then
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
+
+ else
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
+ end if;
+
+ pragma Assert (Result = 0);
+ end Set_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_Id) return System.Any_Priority is
+ begin
+ return T.Common.Current_Priority;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_Id) is
+ begin
+ Self_ID.Common.LL.Thread := pthread_self;
+ Self_ID.Common.LL.LWP := lwp_self;
+
+ Specific.Set (Self_ID);
+
+ if Use_Alternate_Stack then
+ declare
+ Stack : aliased stack_t;
+ Result : Interfaces.C.int;
+ begin
+ Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack;
+ Stack.ss_size := Alternate_Stack_Size;
+ Stack.ss_flags := 0;
+ Result := sigaltstack (Stack'Access, null);
+ pragma Assert (Result = 0);
+ end;
+ end if;
+ end Enter_Task;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_Id is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (pthread_self);
+ end if;
+ end Register_Foreign_Thread;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+ Cond_Attr : aliased pthread_condattr_t;
+
+ begin
+ -- Give the task a unique serial number
+
+ Self_ID.Serial_Number := Next_Serial_Number;
+ Next_Serial_Number := Next_Serial_Number + 1;
+ pragma Assert (Next_Serial_Number /= 0);
+
+ if not Single_Lock then
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ if Locking_Policy = 'C' then
+ Result :=
+ pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access,
+ PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
+
+ Result :=
+ pthread_mutexattr_setprioceiling
+ (Mutex_Attr'Access,
+ Interfaces.C.int (System.Any_Priority'Last));
+ pragma Assert (Result = 0);
+
+ elsif Locking_Policy = 'I' then
+ Result :=
+ pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access,
+ PTHREAD_PRIO_INHERIT);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result :=
+ pthread_mutex_init
+ (Self_ID.Common.LL.L'Access,
+ Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+ end if;
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Result :=
+ pthread_cond_init
+ (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+ end if;
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ if not Single_Lock then
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Succeeded := False;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_Id;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ Attributes : aliased pthread_attr_t;
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Page_Size : constant Interfaces.C.size_t :=
+ Interfaces.C.size_t (Get_Page_Size);
+ Result : Interfaces.C.int;
+
+ function Thread_Body_Access is new
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+
+ use System.Task_Info;
+
+ begin
+ Adjusted_Stack_Size :=
+ Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
+
+ if Stack_Base_Available then
+
+ -- If Stack Checking is supported then allocate 2 additional pages:
+
+ -- In the worst case, stack is allocated at something like
+ -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages
+ -- to be sure the effective stack size is greater than what
+ -- has been asked.
+
+ Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Page_Size;
+ end if;
+
+ -- Round stack size as this is required by some OSes (Darwin)
+
+ Adjusted_Stack_Size := Adjusted_Stack_Size + Page_Size - 1;
+ Adjusted_Stack_Size :=
+ Adjusted_Stack_Size - Adjusted_Stack_Size mod Page_Size;
+
+ Result := pthread_attr_init (Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result :=
+ pthread_attr_setdetachstate
+ (Attributes'Access, PTHREAD_CREATE_DETACHED);
+ pragma Assert (Result = 0);
+
+ Result :=
+ pthread_attr_setstacksize
+ (Attributes'Access, Adjusted_Stack_Size);
+ pragma Assert (Result = 0);
+
+ if T.Common.Task_Info /= Default_Scope then
+ case T.Common.Task_Info is
+ when System.Task_Info.Process_Scope =>
+ Result :=
+ pthread_attr_setscope
+ (Attributes'Access, PTHREAD_SCOPE_PROCESS);
+
+ when System.Task_Info.System_Scope =>
+ Result :=
+ pthread_attr_setscope
+ (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
+
+ when System.Task_Info.Default_Scope =>
+ Result := 0;
+ end case;
+
+ pragma Assert (Result = 0);
+ end if;
+
+ -- Since the initial signal mask of a thread is inherited from the
+ -- creator, and the Environment task has all its signals masked, we
+ -- do not need to manipulate caller's signal mask at this point.
+ -- All tasks in RTS will have All_Tasks_Mask initially.
+
+ -- Note: the use of Unrestricted_Access in the following call is needed
+ -- because otherwise we have an error of getting a access-to-volatile
+ -- value which points to a non-volatile object. But in this case it is
+ -- safe to do this, since we know we have no problems with aliasing and
+ -- Unrestricted_Access bypasses this check.
+
+ Result := pthread_create
+ (T.Common.LL.Thread'Unrestricted_Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
+ pragma Assert (Result = 0 or else Result = EAGAIN);
+
+ Succeeded := Result = 0;
+
+ Result := pthread_attr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+
+ if Succeeded then
+ Set_Priority (T, Priority);
+ end if;
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_Id) is
+ Result : Interfaces.C.int;
+
+ begin
+ if not Single_Lock then
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := pthread_cond_destroy (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ ATCB_Allocation.Free_ATCB (T);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ -- Mark this task as unknown, so that if Self is called, it won't
+ -- return a dangling pointer.
+
+ Specific.Set (null);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ if Abort_Handler_Installed then
+ Result :=
+ pthread_kill
+ (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ pragma Assert (Result = 0);
+ end if;
+ end Abort_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Cond_Attr : aliased pthread_condattr_t;
+ Result : Interfaces.C.int;
+
+ begin
+ -- Initialize internal state (always to False (RM D.10 (6)))
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
+ -- Initialize internal condition variable
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- Storage_Error is propagated as intended if the allocation of the
+ -- underlying OS entities fails.
+
+ raise Storage_Error;
+
+ else
+ Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+
+ -- Storage_Error is propagated as intended if the allocation of the
+ -- underlying OS entities fails.
+
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ -- Destroy internal mutex
+
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- Destroy internal condition variable
+
+ Result := pthread_cond_destroy (S.CV'Access);
+ pragma Assert (Result = 0);
+ end Finalize;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ begin
+ -- We do not want to use lock on this read operation. State is marked
+ -- as Atomic so that we ensure that the value retrieved is correct.
+
+ return S.State;
+ end Current_State;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ S.State := False;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- If there is already a task waiting on this suspension object then
+ -- we resume it, leaving the state of the suspension object to False,
+ -- as it is specified in (RM D.10(9)). Otherwise, it just leaves
+ -- the state to True.
+
+ if S.Waiting then
+ S.Waiting := False;
+ S.State := False;
+
+ Result := pthread_cond_signal (S.CV'Access);
+ pragma Assert (Result = 0);
+
+ else
+ S.State := True;
+ end if;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if S.Waiting then
+
+ -- Program_Error must be raised upon calling Suspend_Until_True
+ -- if another task is already waiting on that suspension object
+ -- (RM D.10(10)).
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+
+ raise Program_Error;
+
+ else
+ -- Suspend the task if the state is False. Otherwise, the task
+ -- continues its execution, and the state of the suspension object
+ -- is set to False (ARM D.10 par. 9).
+
+ if S.State then
+ S.State := False;
+ else
+ S.Waiting := True;
+
+ loop
+ -- Loop in case pthread_cond_wait returns earlier than expected
+ -- (e.g. in case of EINTR caused by a signal).
+
+ Result := pthread_cond_wait (S.CV'Access, S.L'Access);
+ pragma Assert (Result = 0 or else Result = EINTR);
+
+ exit when not S.Waiting;
+ end loop;
+ end if;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end if;
+ end Suspend_Until_True;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy version
+
+ function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
+ pragma Unreferenced (Self_ID);
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
+ pragma Unreferenced (Self_ID);
+ begin
+ return True;
+ end Check_No_Locks;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_Id is
+ begin
+ return Environment_Task_Id;
+ end Environment_Task;
+
+ --------------
+ -- Lock_RTS --
+ --------------
+
+ procedure Lock_RTS is
+ begin
+ Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Lock_RTS;
+
+ ----------------
+ -- Unlock_RTS --
+ ----------------
+
+ procedure Unlock_RTS is
+ begin
+ Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Unlock_RTS;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ pragma Unreferenced (T, Thread_Self);
+ begin
+ return False;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ pragma Unreferenced (T, Thread_Self);
+ begin
+ return False;
+ end Resume_Task;
+
+ --------------------
+ -- Stop_All_Tasks --
+ --------------------
+
+ procedure Stop_All_Tasks is
+ begin
+ null;
+ end Stop_All_Tasks;
+
+ ---------------
+ -- Stop_Task --
+ ---------------
+
+ function Stop_Task (T : ST.Task_Id) return Boolean is
+ pragma Unreferenced (T);
+ begin
+ return False;
+ end Stop_Task;
+
+ -------------------
+ -- Continue_Task --
+ -------------------
+
+ function Continue_Task (T : ST.Task_Id) return Boolean is
+ pragma Unreferenced (T);
+ begin
+ return False;
+ end Continue_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ function State
+ (Int : System.Interrupt_Management.Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
+ begin
+ Environment_Task_Id := Environment_Task;
+
+ Interrupt_Management.Initialize;
+
+ -- Prepare the set of signals that should unblocked in all tasks
+
+ Result := sigemptyset (Unblocked_Signal_Mask'Access);
+ pragma Assert (Result = 0);
+
+ for J in Interrupt_Management.Interrupt_ID loop
+ if System.Interrupt_Management.Keep_Unmasked (J) then
+ Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ -- Initialize the lock used to synchronize chain of all ATCBs
+
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ Specific.Initialize (Environment_Task);
+
+ if Use_Alternate_Stack then
+ Environment_Task.Common.Task_Alternate_Stack :=
+ Alternate_Stack'Address;
+ end if;
+
+ -- Make environment task known here because it doesn't go through
+ -- Activate_Tasks, which does it for all other tasks.
+
+ Known_Tasks (Known_Tasks'First) := Environment_Task;
+ Environment_Task.Known_Tasks_Index := Known_Tasks'First;
+
+ Enter_Task (Environment_Task);
+
+ if State
+ (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
+ then
+ act.sa_flags := 0;
+ act.sa_handler := Abort_Handler'Address;
+
+ Result := sigemptyset (Tmp_Set'Access);
+ pragma Assert (Result = 0);
+ act.sa_mask := Tmp_Set;
+
+ Result :=
+ sigaction
+ (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ Abort_Handler_Installed := True;
+ end if;
+ end Initialize;
+
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ pragma Unreferenced (T);
+
+ begin
+ -- Setting task affinity is not supported by the underlying system
+
+ null;
+ end Set_Task_Affinity;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris (native) version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with Interfaces.C;
+
+with System.Multiprocessors;
+with System.Tasking.Debug;
+with System.Interrupt_Management;
+with System.OS_Constants;
+with System.OS_Primitives;
+with System.Task_Info;
+
+pragma Warnings (Off);
+with System.OS_Lib;
+pragma Warnings (On);
+
+with System.Soft_Links;
+-- We use System.Soft_Links instead of System.Tasking.Initialization
+-- because the later is a higher level package that we shouldn't depend on.
+-- For example when using the restricted run time, it is replaced by
+-- System.Tasking.Restricted.Stages.
+
+package body System.Task_Primitives.Operations is
+
+ package OSC renames System.OS_Constants;
+ package SSL renames System.Soft_Links;
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+
+ ----------------
+ -- Local Data --
+ ----------------
+
+ -- The following are logically constants, but need to be initialized
+ -- at run time.
+
+ Environment_Task_Id : Task_Id;
+ -- A variable to hold Task_Id for the environment task.
+ -- If we use this variable to get the Task_Id, we need the following
+ -- ATCB_Key only for non-Ada threads.
+
+ Unblocked_Signal_Mask : aliased sigset_t;
+ -- The set of signals that should unblocked in all tasks
+
+ ATCB_Key : aliased thread_key_t;
+ -- Key used to find the Ada Task_Id associated with a thread,
+ -- at least for C threads unknown to the Ada run-time system.
+
+ Single_RTS_Lock : aliased RTS_Lock;
+ -- This is a lock to allow only one thread of control in the RTS at
+ -- a time; it is used to execute in mutual exclusion from all other tasks.
+ -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+
+ Next_Serial_Number : Task_Serial_Number := 100;
+ -- We start at 100, to reserve some special values for
+ -- using in error checking.
+ -- The following are internal configuration constants needed.
+
+ Abort_Handler_Installed : Boolean := False;
+ -- True if a handler for the abort signal is installed
+
+ Null_Thread_Id : constant Thread_Id := Thread_Id'Last;
+ -- Constant to indicate that the thread identifier has not yet been
+ -- initialized.
+
+ ----------------------
+ -- Priority Support --
+ ----------------------
+
+ Priority_Ceiling_Emulation : constant Boolean := True;
+ -- controls whether we emulate priority ceiling locking
+
+ -- To get a scheduling close to annex D requirements, we use the real-time
+ -- class provided for LWPs and map each task/thread to a specific and
+ -- unique LWP (there is 1 thread per LWP, and 1 LWP per thread).
+
+ -- The real time class can only be set when the process has root
+ -- privileges, so in the other cases, we use the normal thread scheduling
+ -- and priority handling.
+
+ Using_Real_Time_Class : Boolean := False;
+ -- indicates whether the real time class is being used (i.e. the process
+ -- has root privileges).
+
+ Prio_Param : aliased struct_pcparms;
+ -- Hold priority info (Real_Time) initialized during the package
+ -- elaboration.
+
+ -----------------------------------
+ -- External Configuration Values --
+ -----------------------------------
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads)
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function sysconf (name : System.OS_Interface.int) return processorid_t;
+ pragma Import (C, sysconf, "sysconf");
+
+ SC_NPROCESSORS_CONF : constant System.OS_Interface.int := 14;
+
+ function Num_Procs
+ (name : System.OS_Interface.int := SC_NPROCESSORS_CONF)
+ return processorid_t renames sysconf;
+
+ procedure Abort_Handler
+ (Sig : Signal;
+ Code : not null access siginfo_t;
+ Context : not null access ucontext_t);
+ -- Target-dependent binding of inter-thread Abort signal to
+ -- the raising of the Abort_Signal exception.
+ -- See also comments in 7staprop.adb
+
+ ------------
+ -- Checks --
+ ------------
+
+ function Check_Initialize_Lock
+ (L : Lock_Ptr;
+ Level : Lock_Level) return Boolean;
+ pragma Inline (Check_Initialize_Lock);
+
+ function Check_Lock (L : Lock_Ptr) return Boolean;
+ pragma Inline (Check_Lock);
+
+ function Record_Lock (L : Lock_Ptr) return Boolean;
+ pragma Inline (Record_Lock);
+
+ function Check_Sleep (Reason : Task_States) return Boolean;
+ pragma Inline (Check_Sleep);
+
+ function Record_Wakeup
+ (L : Lock_Ptr;
+ Reason : Task_States) return Boolean;
+ pragma Inline (Record_Wakeup);
+
+ function Check_Wakeup
+ (T : Task_Id;
+ Reason : Task_States) return Boolean;
+ pragma Inline (Check_Wakeup);
+
+ function Check_Unlock (L : Lock_Ptr) return Boolean;
+ pragma Inline (Check_Unlock);
+
+ function Check_Finalize_Lock (L : Lock_Ptr) return Boolean;
+ pragma Inline (Check_Finalize_Lock);
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ procedure Initialize (Environment_Task : Task_Id);
+ pragma Inline (Initialize);
+ -- Initialize various data needed by this package
+
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does executing thread have a TCB?
+
+ procedure Set (Self_Id : Task_Id);
+ pragma Inline (Set);
+ -- Set the self id for the current task
+
+ function Self return Task_Id;
+ pragma Inline (Self);
+ -- Return a pointer to the Ada Task Control Block of the calling task
+
+ end Specific;
+
+ package body Specific is separate;
+ -- The body of this package is target specific
+
+ ----------------------------------
+ -- ATCB allocation/deallocation --
+ ----------------------------------
+
+ package body ATCB_Allocation is separate;
+ -- The body of this package is shared across several targets
+
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
+ -- Allocate and Initialize a new ATCB for the current Thread
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_Id is separate;
+
+ ------------
+ -- Checks --
+ ------------
+
+ Check_Count : Integer := 0;
+ Lock_Count : Integer := 0;
+ Unlock_Count : Integer := 0;
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ procedure Abort_Handler
+ (Sig : Signal;
+ Code : not null access siginfo_t;
+ Context : not null access ucontext_t)
+ is
+ pragma Unreferenced (Sig);
+ pragma Unreferenced (Code);
+ pragma Unreferenced (Context);
+
+ Self_ID : constant Task_Id := Self;
+ Old_Set : aliased sigset_t;
+
+ Result : Interfaces.C.int;
+ pragma Warnings (Off, Result);
+
+ begin
+ -- It's not safe to raise an exception when using GCC ZCX mechanism.
+ -- Note that we still need to install a signal handler, since in some
+ -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
+ -- need to send the Abort signal to a task.
+
+ if ZCX_By_Default then
+ return;
+ end if;
+
+ if Self_ID.Deferral_Level = 0
+ and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ and then not Self_ID.Aborting
+ then
+ Self_ID.Aborting := True;
+
+ -- Make sure signals used for RTS internal purpose are unmasked
+
+ Result :=
+ thr_sigsetmask
+ (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access,
+ Old_Set'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+ end if;
+ end Abort_Handler;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ -- The underlying thread system sets a guard page at the
+ -- bottom of a thread stack, so nothing is needed.
+
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ pragma Unreferenced (T);
+ pragma Unreferenced (On);
+ begin
+ null;
+ end Stack_Guard;
+
+ -------------------
+ -- Get_Thread_Id --
+ -------------------
+
+ function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : ST.Task_Id) is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ procedure Configure_Processors;
+ -- Processors configuration
+ -- The user can specify a processor which the program should run
+ -- on to emulate a single-processor system. This can be easily
+ -- done by setting environment variable GNAT_PROCESSOR to one of
+ -- the following :
+ --
+ -- -2 : use the default configuration (run the program on all
+ -- available processors) - this is the same as having
+ -- GNAT_PROCESSOR unset
+ -- -1 : let the RTS choose one processor and run the program on
+ -- that processor
+ -- 0 .. Last_Proc : run the program on the specified processor
+ --
+ -- Last_Proc is equal to the value of the system variable
+ -- _SC_NPROCESSORS_CONF, minus one.
+
+ procedure Configure_Processors is
+ Proc_Acc : constant System.OS_Lib.String_Access :=
+ System.OS_Lib.Getenv ("GNAT_PROCESSOR");
+ Proc : aliased processorid_t; -- User processor #
+ Last_Proc : processorid_t; -- Last processor #
+
+ begin
+ if Proc_Acc.all'Length /= 0 then
+
+ -- Environment variable is defined
+
+ Last_Proc := Num_Procs - 1;
+
+ if Last_Proc /= -1 then
+ Proc := processorid_t'Value (Proc_Acc.all);
+
+ if Proc <= -2 or else Proc > Last_Proc then
+
+ -- Use the default configuration
+
+ null;
+
+ elsif Proc = -1 then
+
+ -- Choose a processor
+
+ Result := 0;
+ while Proc < Last_Proc loop
+ Proc := Proc + 1;
+ Result := p_online (Proc, PR_STATUS);
+ exit when Result = PR_ONLINE;
+ end loop;
+
+ pragma Assert (Result = PR_ONLINE);
+ Result := processor_bind (P_PID, P_MYID, Proc, null);
+ pragma Assert (Result = 0);
+
+ else
+ -- Use user processor
+
+ Result := processor_bind (P_PID, P_MYID, Proc, null);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end if;
+
+ exception
+ when Constraint_Error =>
+
+ -- Illegal environment variable GNAT_PROCESSOR - ignored
+
+ null;
+ end Configure_Processors;
+
+ function State
+ (Int : System.Interrupt_Management.Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
+ -- Start of processing for Initialize
+
+ begin
+ Environment_Task_Id := Environment_Task;
+
+ Interrupt_Management.Initialize;
+
+ -- Prepare the set of signals that should unblocked in all tasks
+
+ Result := sigemptyset (Unblocked_Signal_Mask'Access);
+ pragma Assert (Result = 0);
+
+ for J in Interrupt_Management.Interrupt_ID loop
+ if System.Interrupt_Management.Keep_Unmasked (J) then
+ Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ if Dispatching_Policy = 'F' then
+ declare
+ Result : Interfaces.C.long;
+ Class_Info : aliased struct_pcinfo;
+ Secs, Nsecs : Interfaces.C.long;
+
+ begin
+ -- If a pragma Time_Slice is specified, takes the value in account
+
+ if Time_Slice_Val > 0 then
+
+ -- Convert Time_Slice_Val (microseconds) to seconds/nanosecs
+
+ Secs := Interfaces.C.long (Time_Slice_Val / 1_000_000);
+ Nsecs :=
+ Interfaces.C.long ((Time_Slice_Val rem 1_000_000) * 1_000);
+
+ -- Otherwise, default to no time slicing (i.e run until blocked)
+
+ else
+ Secs := RT_TQINF;
+ Nsecs := RT_TQINF;
+ end if;
+
+ -- Get the real time class id
+
+ Class_Info.pc_clname (1) := 'R';
+ Class_Info.pc_clname (2) := 'T';
+ Class_Info.pc_clname (3) := ASCII.NUL;
+
+ Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID,
+ Class_Info'Address);
+
+ -- Request the real time class
+
+ Prio_Param.pc_cid := Class_Info.pc_cid;
+ Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri);
+ Prio_Param.rt_tqsecs := Secs;
+ Prio_Param.rt_tqnsecs := Nsecs;
+
+ Result :=
+ priocntl
+ (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS, Prio_Param'Address);
+
+ Using_Real_Time_Class := Result /= -1;
+ end;
+ end if;
+
+ Specific.Initialize (Environment_Task);
+
+ -- The following is done in Enter_Task, but this is too late for the
+ -- Environment Task, since we need to call Self in Check_Locks when
+ -- the run time is compiled with assertions on.
+
+ Specific.Set (Environment_Task);
+
+ -- Initialize the lock used to synchronize chain of all ATCBs
+
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ -- Make environment task known here because it doesn't go through
+ -- Activate_Tasks, which does it for all other tasks.
+
+ Known_Tasks (Known_Tasks'First) := Environment_Task;
+ Environment_Task.Known_Tasks_Index := Known_Tasks'First;
+
+ Enter_Task (Environment_Task);
+
+ Configure_Processors;
+
+ if State
+ (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
+ then
+ -- Set sa_flags to SA_NODEFER so that during the handler execution
+ -- we do not change the Signal_Mask to be masked for the Abort_Signal
+ -- This is a temporary fix to the problem that the Signal_Mask is
+ -- not restored after the exception (longjmp) from the handler.
+ -- The right fix should be made in sigsetjmp so that we save
+ -- the Signal_Set and restore it after a longjmp.
+ -- In that case, this field should be changed back to 0. ???
+
+ act.sa_flags := 16;
+
+ act.sa_handler := Abort_Handler'Address;
+ Result := sigemptyset (Tmp_Set'Access);
+ pragma Assert (Result = 0);
+ act.sa_mask := Tmp_Set;
+
+ Result :=
+ sigaction
+ (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ Abort_Handler_Installed := True;
+ end if;
+ end Initialize;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ -- Note: mutexes and cond_variables needed per-task basis are initialized
+ -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
+ -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
+ -- status change of RTS. Therefore raising Storage_Error in the following
+ -- routines should be able to be handled safely.
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : not null access Lock)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Initialize_Lock (Lock_Ptr (L), PO_Level));
+
+ if Priority_Ceiling_Emulation then
+ L.Ceiling := Prio;
+ end if;
+
+ Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock;
+ Level : Lock_Level)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert
+ (Check_Initialize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level));
+ Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : not null access Lock) is
+ Result : Interfaces.C.int;
+ begin
+ pragma Assert (Check_Finalize_Lock (Lock_Ptr (L)));
+ Result := mutex_destroy (L.L'Access);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : not null access RTS_Lock) is
+ Result : Interfaces.C.int;
+ begin
+ pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ Result := mutex_destroy (L.L'Access);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Lock (Lock_Ptr (L)));
+
+ if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
+ declare
+ Self_Id : constant Task_Id := Self;
+ Saved_Priority : System.Any_Priority;
+
+ begin
+ if Self_Id.Common.LL.Active_Priority > L.Ceiling then
+ Ceiling_Violation := True;
+ return;
+ end if;
+
+ Saved_Priority := Self_Id.Common.LL.Active_Priority;
+
+ if Self_Id.Common.LL.Active_Priority < L.Ceiling then
+ Set_Priority (Self_Id, L.Ceiling);
+ end if;
+
+ Result := mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ Ceiling_Violation := False;
+
+ L.Saved_Priority := Saved_Priority;
+ end;
+
+ else
+ Result := mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ Ceiling_Violation := False;
+ end if;
+
+ pragma Assert (Record_Lock (Lock_Ptr (L)));
+ end Write_Lock;
+
+ procedure Write_Lock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock or else Global_Lock then
+ pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ Result := mutex_lock (L.L'Access);
+ pragma Assert (Result = 0);
+ pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock then
+ pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
+ Result := mutex_lock (T.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
+ pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
+ end if;
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : not null access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Unlock (Lock_Ptr (L)));
+
+ if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
+ declare
+ Self_Id : constant Task_Id := Self;
+
+ begin
+ Result := mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+
+ if Self_Id.Common.LL.Active_Priority > L.Saved_Priority then
+ Set_Priority (Self_Id, L.Saved_Priority);
+ end if;
+ end;
+ else
+ Result := mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ procedure Unlock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock or else Global_Lock then
+ pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
+ Result := mutex_unlock (L.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ procedure Unlock (T : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock then
+ pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access)));
+ Result := mutex_unlock (T.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
+ -- For the time delay implementation, we need to make sure we
+ -- achieve following criteria:
+
+ -- 1) We have to delay at least for the amount requested.
+ -- 2) We have to give up CPU even though the actual delay does not
+ -- result in blocking.
+ -- 3) Except for restricted run-time systems that do not support
+ -- ATC or task abort, the delay must be interrupted by the
+ -- abort_task operation.
+ -- 4) The implementation has to be efficient so that the delay overhead
+ -- is relatively cheap.
+ -- (1)-(3) are Ada requirements. Even though (2) is an Annex-D
+ -- requirement we still want to provide the effect in all cases.
+ -- The reason is that users may want to use short delays to implement
+ -- their own scheduling effect in the absence of language provided
+ -- scheduling policies.
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+ begin
+ Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+ begin
+ Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ return To_Duration (TS);
+ end RT_Resolution;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ begin
+ if Do_Yield then
+ System.OS_Interface.thr_yield;
+ end if;
+ end Yield;
+
+ -----------
+ -- Self ---
+ -----------
+
+ function Self return Task_Id renames Specific.Self;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_Id;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ pragma Unreferenced (Loss_Of_Inheritance);
+
+ Result : Interfaces.C.int;
+ pragma Unreferenced (Result);
+
+ Param : aliased struct_pcparms;
+
+ use Task_Info;
+
+ begin
+ T.Common.Current_Priority := Prio;
+
+ if Priority_Ceiling_Emulation then
+ T.Common.LL.Active_Priority := Prio;
+ end if;
+
+ if Using_Real_Time_Class then
+ Param.pc_cid := Prio_Param.pc_cid;
+ Param.rt_pri := pri_t (Prio);
+ Param.rt_tqsecs := Prio_Param.rt_tqsecs;
+ Param.rt_tqnsecs := Prio_Param.rt_tqnsecs;
+
+ Result := Interfaces.C.int (
+ priocntl (PC_VERSION, P_LWPID, T.Common.LL.LWP, PC_SETPARMS,
+ Param'Address));
+
+ else
+ if T.Common.Task_Info /= null
+ and then not T.Common.Task_Info.Bound_To_LWP
+ then
+ -- The task is not bound to a LWP, so use thr_setprio
+
+ Result :=
+ thr_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
+
+ else
+ -- The task is bound to a LWP, use priocntl
+ -- ??? TBD
+
+ null;
+ end if;
+ end if;
+ end Set_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_Id) return System.Any_Priority is
+ begin
+ return T.Common.Current_Priority;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_Id) is
+ begin
+ Self_ID.Common.LL.Thread := thr_self;
+ Self_ID.Common.LL.LWP := lwp_self;
+
+ Set_Task_Affinity (Self_ID);
+ Specific.Set (Self_ID);
+
+ -- We need the above code even if we do direct fetch of Task_Id in Self
+ -- for the main task on Sun, x86 Solaris and for gcc 2.7.2.
+ end Enter_Task;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_Id is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (thr_self);
+ end if;
+ end Register_Foreign_Thread;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
+ Result : Interfaces.C.int := 0;
+
+ begin
+ -- Give the task a unique serial number
+
+ Self_ID.Serial_Number := Next_Serial_Number;
+ Next_Serial_Number := Next_Serial_Number + 1;
+ pragma Assert (Next_Serial_Number /= 0);
+
+ Self_ID.Common.LL.Thread := Null_Thread_Id;
+
+ if not Single_Lock then
+ Result :=
+ mutex_init
+ (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address);
+ Self_ID.Common.LL.L.Level :=
+ Private_Task_Serial_Number (Self_ID.Serial_Number);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+ end if;
+
+ if Result = 0 then
+ Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+ end if;
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ if not Single_Lock then
+ Result := mutex_destroy (Self_ID.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Succeeded := False;
+ end if;
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_Id;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ pragma Unreferenced (Priority);
+
+ Result : Interfaces.C.int;
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Opts : Interfaces.C.int := THR_DETACHED;
+
+ Page_Size : constant System.Parameters.Size_Type := 4096;
+ -- This constant is for reserving extra space at the
+ -- end of the stack, which can be used by the stack
+ -- checking as guard page. The idea is that we need
+ -- to have at least Stack_Size bytes available for
+ -- actual use.
+
+ use System.Task_Info;
+ use type System.Multiprocessors.CPU_Range;
+
+ begin
+ -- Check whether both Dispatching_Domain and CPU are specified for the
+ -- task, and the CPU value is not contained within the range of
+ -- processors for the domain.
+
+ if T.Common.Domain /= null
+ and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
+ and then
+ (T.Common.Base_CPU not in T.Common.Domain'Range
+ or else not T.Common.Domain (T.Common.Base_CPU))
+ then
+ Succeeded := False;
+ return;
+ end if;
+
+ Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Page_Size);
+
+ -- Since the initial signal mask of a thread is inherited from the
+ -- creator, and the Environment task has all its signals masked, we
+ -- do not need to manipulate caller's signal mask at this point.
+ -- All tasks in RTS will have All_Tasks_Mask initially.
+
+ if T.Common.Task_Info /= null then
+ if T.Common.Task_Info.New_LWP then
+ Opts := Opts + THR_NEW_LWP;
+ end if;
+
+ if T.Common.Task_Info.Bound_To_LWP then
+ Opts := Opts + THR_BOUND;
+ end if;
+
+ else
+ Opts := THR_DETACHED + THR_BOUND;
+ end if;
+
+ -- Note: the use of Unrestricted_Access in the following call is needed
+ -- because otherwise we have an error of getting a access-to-volatile
+ -- value which points to a non-volatile object. But in this case it is
+ -- safe to do this, since we know we have no problems with aliasing and
+ -- Unrestricted_Access bypasses this check.
+
+ Result :=
+ thr_create
+ (System.Null_Address,
+ Adjusted_Stack_Size,
+ Thread_Body_Access (Wrapper),
+ To_Address (T),
+ Opts,
+ T.Common.LL.Thread'Unrestricted_Access);
+
+ Succeeded := Result = 0;
+ pragma Assert
+ (Result = 0
+ or else Result = ENOMEM
+ or else Result = EAGAIN);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_Id) is
+ Result : Interfaces.C.int;
+
+ begin
+ T.Common.LL.Thread := Null_Thread_Id;
+
+ if not Single_Lock then
+ Result := mutex_destroy (T.Common.LL.L.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := cond_destroy (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ ATCB_Allocation.Free_ATCB (T);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ -- This procedure must be called with abort deferred. It can no longer
+ -- call Self or access the current task's ATCB, since the ATCB has been
+ -- deallocated.
+
+ procedure Exit_Task is
+ begin
+ Specific.Set (null);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ if Abort_Handler_Installed then
+ pragma Assert (T /= Self);
+ Result :=
+ thr_kill
+ (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ pragma Assert (Result = 0);
+ end if;
+ end Abort_Task;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep
+ (Self_ID : Task_Id;
+ Reason : Task_States)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Sleep (Reason));
+
+ if Single_Lock then
+ Result :=
+ cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access);
+ else
+ Result :=
+ cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
+ end if;
+
+ pragma Assert
+ (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
+ pragma Assert (Result = 0 or else Result = EINTR);
+ end Sleep;
+
+ -- Note that we are relying heavily here on GNAT representing
+ -- Calendar.Time, System.Real_Time.Time, Duration,
+ -- System.Real_Time.Time_Span in the same way, i.e., as a 64-bit count of
+ -- nanoseconds.
+
+ -- This allows us to always pass the timeout value as a Duration
+
+ -- ???
+ -- We are taking liberties here with the semantics of the delays. That is,
+ -- we make no distinction between delays on the Calendar clock and delays
+ -- on the Real_Time clock. That is technically incorrect, if the Calendar
+ -- clock happens to be reset or adjusted. To solve this defect will require
+ -- modification to the compiler interface, so that it can pass through more
+ -- information, to tell us here which clock to use.
+
+ -- cond_timedwait will return if any of the following happens:
+ -- 1) some other task did cond_signal on this condition variable
+ -- In this case, the return value is 0
+ -- 2) the call just returned, for no good reason
+ -- This is called a "spurious wakeup".
+ -- In this case, the return value may also be 0.
+ -- 3) the time delay expires
+ -- In this case, the return value is ETIME
+ -- 4) this task received a signal, which was handled by some
+ -- handler procedure, and now the thread is resuming execution
+ -- UNIX calls this an "interrupted" system call.
+ -- In this case, the return value is EINTR
+
+ -- If the cond_timedwait returns 0 or EINTR, it is still possible that the
+ -- time has actually expired, and by chance a signal or cond_signal
+ -- occurred at around the same time.
+
+ -- We have also observed that on some OS's the value ETIME will be
+ -- returned, but the clock will show that the full delay has not yet
+ -- expired.
+
+ -- For these reasons, we need to check the clock after return from
+ -- cond_timedwait. If the time has expired, we will set Timedout = True.
+
+ -- This check might be omitted for systems on which the cond_timedwait()
+ -- never returns early or wakes up spuriously.
+
+ -- Annex D requires that completion of a delay cause the task to go to the
+ -- end of its priority queue, regardless of whether the task actually was
+ -- suspended by the delay. Since cond_timedwait does not do this on
+ -- Solaris, we add a call to thr_yield at the end. We might do this at the
+ -- beginning, instead, but then the round-robin effect would not be the
+ -- same; the delayed task would be ahead of other tasks of the same
+ -- priority that awoke while it was sleeping.
+
+ -- For Timed_Sleep, we are expecting possible cond_signals to indicate
+ -- other events (e.g., completion of a RV or completion of the abortable
+ -- part of an async. select), we want to always return if interrupted. The
+ -- caller will be responsible for checking the task state to see whether
+ -- the wakeup was spurious, and to go back to sleep again in that case. We
+ -- don't need to check for pending abort or priority change on the way in
+ -- our out; that is the caller's responsibility.
+
+ -- For Timed_Delay, we are not expecting any cond_signals or other
+ -- interruptions, except for priority changes and aborts. Therefore, we
+ -- don't want to return unless the delay has actually expired, or the call
+ -- has been aborted. In this case, since we want to implement the entire
+ -- delay statement semantics, we do need to check for pending abort and
+ -- priority changes. We can quietly handle priority changes inside the
+ -- procedure, since there is no entry-queue reordering involved.
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ procedure Timed_Sleep
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ pragma Assert (Check_Sleep (Reason));
+ Timedout := True;
+ Yielded := False;
+
+ Abs_Time :=
+ (if Mode = Relative
+ then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ if Single_Lock then
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock.L'Access, Request'Access);
+ else
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L.L'Access, Request'Access);
+ end if;
+
+ Yielded := True;
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ if Result = 0 or Result = EINTR then
+
+ -- Somebody may have called Wakeup for us
+
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIME);
+ end loop;
+ end if;
+
+ pragma Assert
+ (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+ Yielded : Boolean := False;
+
+ begin
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ Write_Lock (Self_ID);
+
+ Abs_Time :=
+ (if Mode = Relative
+ then Time + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+
+ if Abs_Time > Check_Time then
+ Request := To_Timespec (Abs_Time);
+ Self_ID.Common.State := Delay_Sleep;
+
+ pragma Assert (Check_Sleep (Delay_Sleep));
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ if Single_Lock then
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock.L'Access,
+ Request'Access);
+ else
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L.L'Access,
+ Request'Access);
+ end if;
+
+ Yielded := True;
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ pragma Assert
+ (Result = 0 or else
+ Result = ETIME or else
+ Result = EINTR);
+ end loop;
+
+ pragma Assert
+ (Record_Wakeup
+ (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep));
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ if not Yielded then
+ thr_yield;
+ end if;
+ end Timed_Delay;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup
+ (T : Task_Id;
+ Reason : Task_States)
+ is
+ Result : Interfaces.C.int;
+ begin
+ pragma Assert (Check_Wakeup (T, Reason));
+ Result := cond_signal (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ end Wakeup;
+
+ ---------------------------
+ -- Check_Initialize_Lock --
+ ---------------------------
+
+ -- The following code is intended to check some of the invariant assertions
+ -- related to lock usage, on which we depend.
+
+ function Check_Initialize_Lock
+ (L : Lock_Ptr;
+ Level : Lock_Level) return Boolean
+ is
+ Self_ID : constant Task_Id := Self;
+
+ begin
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level = 0 then
+ return False;
+ end if;
+
+ -- Check that the lock is not yet initialized
+
+ if L.Level /= 0 then
+ return False;
+ end if;
+
+ L.Level := Lock_Level'Pos (Level) + 1;
+ return True;
+ end Check_Initialize_Lock;
+
+ ----------------
+ -- Check_Lock --
+ ----------------
+
+ function Check_Lock (L : Lock_Ptr) return Boolean is
+ Self_ID : constant Task_Id := Self;
+ P : Lock_Ptr;
+
+ begin
+ -- Check that the argument is not null
+
+ if L = null then
+ return False;
+ end if;
+
+ -- Check that L is not frozen
+
+ if L.Frozen then
+ return False;
+ end if;
+
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level = 0 then
+ return False;
+ end if;
+
+ -- Check that caller is not holding this lock already
+
+ if L.Owner = To_Owner_ID (To_Address (Self_ID)) then
+ return False;
+ end if;
+
+ if Single_Lock then
+ return True;
+ end if;
+
+ -- Check that TCB lock order rules are satisfied
+
+ P := Self_ID.Common.LL.Locks;
+ if P /= null then
+ if P.Level >= L.Level
+ and then (P.Level > 2 or else L.Level > 2)
+ then
+ return False;
+ end if;
+ end if;
+
+ return True;
+ end Check_Lock;
+
+ -----------------
+ -- Record_Lock --
+ -----------------
+
+ function Record_Lock (L : Lock_Ptr) return Boolean is
+ Self_ID : constant Task_Id := Self;
+ P : Lock_Ptr;
+
+ begin
+ Lock_Count := Lock_Count + 1;
+
+ -- There should be no owner for this lock at this point
+
+ if L.Owner /= null then
+ return False;
+ end if;
+
+ -- Record new owner
+
+ L.Owner := To_Owner_ID (To_Address (Self_ID));
+
+ if Single_Lock then
+ return True;
+ end if;
+
+ -- Check that TCB lock order rules are satisfied
+
+ P := Self_ID.Common.LL.Locks;
+
+ if P /= null then
+ L.Next := P;
+ end if;
+
+ Self_ID.Common.LL.Locking := null;
+ Self_ID.Common.LL.Locks := L;
+ return True;
+ end Record_Lock;
+
+ -----------------
+ -- Check_Sleep --
+ -----------------
+
+ function Check_Sleep (Reason : Task_States) return Boolean is
+ pragma Unreferenced (Reason);
+
+ Self_ID : constant Task_Id := Self;
+ P : Lock_Ptr;
+
+ begin
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level = 0 then
+ return False;
+ end if;
+
+ if Single_Lock then
+ return True;
+ end if;
+
+ -- Check that caller is holding own lock, on top of list
+
+ if Self_ID.Common.LL.Locks /=
+ To_Lock_Ptr (Self_ID.Common.LL.L'Access)
+ then
+ return False;
+ end if;
+
+ -- Check that TCB lock order rules are satisfied
+
+ if Self_ID.Common.LL.Locks.Next /= null then
+ return False;
+ end if;
+
+ Self_ID.Common.LL.L.Owner := null;
+ P := Self_ID.Common.LL.Locks;
+ Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
+ P.Next := null;
+ return True;
+ end Check_Sleep;
+
+ -------------------
+ -- Record_Wakeup --
+ -------------------
+
+ function Record_Wakeup
+ (L : Lock_Ptr;
+ Reason : Task_States) return Boolean
+ is
+ pragma Unreferenced (Reason);
+
+ Self_ID : constant Task_Id := Self;
+ P : Lock_Ptr;
+
+ begin
+ -- Record new owner
+
+ L.Owner := To_Owner_ID (To_Address (Self_ID));
+
+ if Single_Lock then
+ return True;
+ end if;
+
+ -- Check that TCB lock order rules are satisfied
+
+ P := Self_ID.Common.LL.Locks;
+
+ if P /= null then
+ L.Next := P;
+ end if;
+
+ Self_ID.Common.LL.Locking := null;
+ Self_ID.Common.LL.Locks := L;
+ return True;
+ end Record_Wakeup;
+
+ ------------------
+ -- Check_Wakeup --
+ ------------------
+
+ function Check_Wakeup
+ (T : Task_Id;
+ Reason : Task_States) return Boolean
+ is
+ Self_ID : constant Task_Id := Self;
+
+ begin
+ -- Is caller holding T's lock?
+
+ if T.Common.LL.L.Owner /= To_Owner_ID (To_Address (Self_ID)) then
+ return False;
+ end if;
+
+ -- Are reasons for wakeup and sleep consistent?
+
+ if T.Common.State /= Reason then
+ return False;
+ end if;
+
+ return True;
+ end Check_Wakeup;
+
+ ------------------
+ -- Check_Unlock --
+ ------------------
+
+ function Check_Unlock (L : Lock_Ptr) return Boolean is
+ Self_ID : constant Task_Id := Self;
+ P : Lock_Ptr;
+
+ begin
+ Unlock_Count := Unlock_Count + 1;
+
+ if L = null then
+ return False;
+ end if;
+
+ if L.Buddy /= null then
+ return False;
+ end if;
+
+ -- Magic constant 4???
+
+ if L.Level = 4 then
+ Check_Count := Unlock_Count;
+ end if;
+
+ -- Magic constant 1000???
+
+ if Unlock_Count - Check_Count > 1000 then
+ Check_Count := Unlock_Count;
+ end if;
+
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level = 0 then
+ return False;
+ end if;
+
+ -- Check that caller is holding this lock, on top of list
+
+ if Self_ID.Common.LL.Locks /= L then
+ return False;
+ end if;
+
+ -- Record there is no owner now
+
+ L.Owner := null;
+ P := Self_ID.Common.LL.Locks;
+ Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
+ P.Next := null;
+ return True;
+ end Check_Unlock;
+
+ --------------------
+ -- Check_Finalize --
+ --------------------
+
+ function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is
+ Self_ID : constant Task_Id := Self;
+
+ begin
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level = 0 then
+ return False;
+ end if;
+
+ -- Check that no one is holding this lock
+
+ if L.Owner /= null then
+ return False;
+ end if;
+
+ L.Frozen := True;
+ return True;
+ end Check_Finalize_Lock;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ -- Initialize internal state (always to zero (RM D.10(6)))
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ Result := mutex_init (S.L'Access, USYNC_THREAD, System.Null_Address);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+
+ -- Initialize internal condition variable
+
+ Result := cond_init (S.CV'Access, USYNC_THREAD, 0);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+ end if;
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ -- Destroy internal mutex
+
+ Result := mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- Destroy internal condition variable
+
+ Result := cond_destroy (S.CV'Access);
+ pragma Assert (Result = 0);
+ end Finalize;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ begin
+ -- We do not want to use lock on this read operation. State is marked
+ -- as Atomic so that we ensure that the value retrieved is correct.
+
+ return S.State;
+ end Current_State;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ S.State := False;
+
+ Result := mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- If there is already a task waiting on this suspension object then
+ -- we resume it, leaving the state of the suspension object to False,
+ -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
+ -- the state to True.
+
+ if S.Waiting then
+ S.Waiting := False;
+ S.State := False;
+
+ Result := cond_signal (S.CV'Access);
+ pragma Assert (Result = 0);
+
+ else
+ S.State := True;
+ end if;
+
+ Result := mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if S.Waiting then
+
+ -- Program_Error must be raised upon calling Suspend_Until_True
+ -- if another task is already waiting on that suspension object
+ -- (RM D.10(10)).
+
+ Result := mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+
+ raise Program_Error;
+
+ else
+ -- Suspend the task if the state is False. Otherwise, the task
+ -- continues its execution, and the state of the suspension object
+ -- is set to False (ARM D.10 par. 9).
+
+ if S.State then
+ S.State := False;
+ else
+ S.Waiting := True;
+
+ loop
+ -- Loop in case pthread_cond_wait returns earlier than expected
+ -- (e.g. in case of EINTR caused by a signal).
+
+ Result := cond_wait (S.CV'Access, S.L'Access);
+ pragma Assert (Result = 0 or else Result = EINTR);
+
+ exit when not S.Waiting;
+ end loop;
+ end if;
+
+ Result := mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end if;
+ end Suspend_Until_True;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ function Check_Exit (Self_ID : Task_Id) return Boolean is
+ begin
+ -- Check that caller is just holding Global_Task_Lock and no other locks
+
+ if Self_ID.Common.LL.Locks = null then
+ return False;
+ end if;
+
+ -- 2 = Global_Task_Level
+
+ if Self_ID.Common.LL.Locks.Level /= 2 then
+ return False;
+ end if;
+
+ if Self_ID.Common.LL.Locks.Next /= null then
+ return False;
+ end if;
+
+ -- Check that caller is abort-deferred
+
+ if Self_ID.Deferral_Level = 0 then
+ return False;
+ end if;
+
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : Task_Id) return Boolean is
+ begin
+ return Self_ID.Common.LL.Locks = null;
+ end Check_No_Locks;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_Id is
+ begin
+ return Environment_Task_Id;
+ end Environment_Task;
+
+ --------------
+ -- Lock_RTS --
+ --------------
+
+ procedure Lock_RTS is
+ begin
+ Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Lock_RTS;
+
+ ----------------
+ -- Unlock_RTS --
+ ----------------
+
+ procedure Unlock_RTS is
+ begin
+ Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Unlock_RTS;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return thr_suspend (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ begin
+ if T.Common.LL.Thread /= Thread_Self then
+ return thr_continue (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Resume_Task;
+
+ --------------------
+ -- Stop_All_Tasks --
+ --------------------
+
+ procedure Stop_All_Tasks is
+ begin
+ null;
+ end Stop_All_Tasks;
+
+ ---------------
+ -- Stop_Task --
+ ---------------
+
+ function Stop_Task (T : ST.Task_Id) return Boolean is
+ pragma Unreferenced (T);
+ begin
+ return False;
+ end Stop_Task;
+
+ -------------------
+ -- Continue_Task --
+ -------------------
+
+ function Continue_Task (T : ST.Task_Id) return Boolean is
+ pragma Unreferenced (T);
+ begin
+ return False;
+ end Continue_Task;
+
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ Result : Interfaces.C.int;
+ Proc : processorid_t; -- User processor #
+ Last_Proc : processorid_t; -- Last processor #
+
+ use System.Task_Info;
+ use type System.Multiprocessors.CPU_Range;
+
+ begin
+ -- Do nothing if the underlying thread has not yet been created. If the
+ -- thread has not yet been created then the proper affinity will be set
+ -- during its creation.
+
+ if T.Common.LL.Thread = Null_Thread_Id then
+ null;
+
+ -- pragma CPU
+
+ elsif T.Common.Base_CPU /=
+ System.Multiprocessors.Not_A_Specific_CPU
+ then
+ -- The CPU numbering in pragma CPU starts at 1 while the subprogram
+ -- to set the affinity starts at 0, therefore we must substract 1.
+
+ Result :=
+ processor_bind
+ (P_LWPID, id_t (T.Common.LL.LWP),
+ processorid_t (T.Common.Base_CPU) - 1, null);
+ pragma Assert (Result = 0);
+
+ -- Task_Info
+
+ elsif T.Common.Task_Info /= null then
+ if T.Common.Task_Info.New_LWP
+ and then T.Common.Task_Info.CPU /= CPU_UNCHANGED
+ then
+ Last_Proc := Num_Procs - 1;
+
+ if T.Common.Task_Info.CPU = ANY_CPU then
+ Result := 0;
+
+ Proc := 0;
+ while Proc < Last_Proc loop
+ Result := p_online (Proc, PR_STATUS);
+ exit when Result = PR_ONLINE;
+ Proc := Proc + 1;
+ end loop;
+
+ Result :=
+ processor_bind
+ (P_LWPID, id_t (T.Common.LL.LWP), Proc, null);
+ pragma Assert (Result = 0);
+
+ else
+ -- Use specified processor
+
+ if T.Common.Task_Info.CPU < 0
+ or else T.Common.Task_Info.CPU > Last_Proc
+ then
+ raise Invalid_CPU_Number;
+ end if;
+
+ Result :=
+ processor_bind
+ (P_LWPID, id_t (T.Common.LL.LWP),
+ T.Common.Task_Info.CPU, null);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+
+ -- Handle dispatching domains
+
+ elsif T.Common.Domain /= null
+ and then (T.Common.Domain /= ST.System_Domain
+ or else T.Common.Domain.all /=
+ (Multiprocessors.CPU'First ..
+ Multiprocessors.Number_Of_CPUs => True))
+ then
+ declare
+ CPU_Set : aliased psetid_t;
+ Result : int;
+
+ begin
+ Result := pset_create (CPU_Set'Access);
+ pragma Assert (Result = 0);
+
+ -- Set the affinity to all the processors belonging to the
+ -- dispatching domain.
+
+ for Proc in T.Common.Domain'Range loop
+
+ -- The Ada CPU numbering starts at 1 while the subprogram to
+ -- set the affinity starts at 0, therefore we must substract 1.
+
+ if T.Common.Domain (Proc) then
+ Result :=
+ pset_assign (CPU_Set, processorid_t (Proc) - 1, null);
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+
+ Result :=
+ pset_bind (CPU_Set, P_LWPID, id_t (T.Common.LL.LWP), null);
+ pragma Assert (Result = 0);
+ end;
+ end if;
+ end Set_Task_Affinity;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks version of this package
+
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+with System.Multiprocessors;
+with System.Tasking.Debug;
+with System.Interrupt_Management;
+with System.Float_Control;
+with System.OS_Constants;
+
+with System.Soft_Links;
+-- We use System.Soft_Links instead of System.Tasking.Initialization
+-- because the later is a higher level package that we shouldn't depend
+-- on. For example when using the restricted run time, it is replaced by
+-- System.Tasking.Restricted.Stages.
+
+with System.Task_Info;
+with System.VxWorks.Ext;
+
+package body System.Task_Primitives.Operations is
+
+ package OSC renames System.OS_Constants;
+ package SSL renames System.Soft_Links;
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use System.OS_Interface;
+ use System.Parameters;
+ use type System.VxWorks.Ext.t_id;
+ use type Interfaces.C.int;
+ use type System.OS_Interface.unsigned;
+
+ subtype int is System.OS_Interface.int;
+ subtype unsigned is System.OS_Interface.unsigned;
+
+ Relative : constant := 0;
+
+ ----------------
+ -- Local Data --
+ ----------------
+
+ -- The followings are logically constants, but need to be initialized at
+ -- run time.
+
+ Environment_Task_Id : Task_Id;
+ -- A variable to hold Task_Id for the environment task
+
+ -- The followings are internal configuration constants needed
+
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads)
+
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+
+ Mutex_Protocol : Priority_Type;
+
+ Single_RTS_Lock : aliased RTS_Lock;
+ -- This is a lock to allow only one thread of control in the RTS at a
+ -- time; it is used to execute in mutual exclusion from all other tasks.
+ -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Null_Thread_Id : constant Thread_Id := 0;
+ -- Constant to indicate that the thread identifier has not yet been
+ -- initialized.
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ procedure Initialize;
+ pragma Inline (Initialize);
+ -- Initialize task specific data
+
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does executing thread have a TCB?
+
+ procedure Set (Self_Id : Task_Id);
+ pragma Inline (Set);
+ -- Set the self id for the current task, unless Self_Id is null, in
+ -- which case the task specific data is deleted.
+
+ function Self return Task_Id;
+ pragma Inline (Self);
+ -- Return a pointer to the Ada Task Control Block of the calling task
+
+ end Specific;
+
+ package body Specific is separate;
+ -- The body of this package is target specific
+
+ ----------------------------------
+ -- ATCB allocation/deallocation --
+ ----------------------------------
+
+ package body ATCB_Allocation is separate;
+ -- The body of this package is shared across several targets
+
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
+ -- Allocate and Initialize a new ATCB for the current Thread
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_Id is separate;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler (signo : Signal);
+ -- Handler for the abort (SIGABRT) signal to handle asynchronous abort
+
+ procedure Install_Signal_Handlers;
+ -- Install the default signal handlers for the current task
+
+ function Is_Task_Context return Boolean;
+ -- This function returns True if the current execution is in the context of
+ -- a task, and False if it is an interrupt context.
+
+ type Set_Stack_Limit_Proc_Acc is access procedure;
+ pragma Convention (C, Set_Stack_Limit_Proc_Acc);
+
+ Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
+ pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
+ -- Procedure to be called when a task is created to set stack limit. Used
+ -- only for VxWorks 5 and VxWorks MILS guest OS.
+
+ function To_Address is
+ new Ada.Unchecked_Conversion (Task_Id, System.Address);
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ procedure Abort_Handler (signo : Signal) is
+ pragma Unreferenced (signo);
+
+ Self_ID : constant Task_Id := Self;
+ Old_Set : aliased sigset_t;
+ Unblocked_Mask : aliased sigset_t;
+ Result : int;
+ pragma Warnings (Off, Result);
+
+ use System.Interrupt_Management;
+
+ begin
+ -- It is not safe to raise an exception when using ZCX and the GCC
+ -- exception handling mechanism.
+
+ if ZCX_By_Default then
+ return;
+ end if;
+
+ if Self_ID.Deferral_Level = 0
+ and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ and then not Self_ID.Aborting
+ then
+ Self_ID.Aborting := True;
+
+ -- Make sure signals used for RTS internal purposes are unmasked
+
+ Result := sigemptyset (Unblocked_Mask'Access);
+ pragma Assert (Result = 0);
+ Result :=
+ sigaddset
+ (Unblocked_Mask'Access,
+ Signal (Abort_Task_Interrupt));
+ pragma Assert (Result = 0);
+ Result := sigaddset (Unblocked_Mask'Access, SIGBUS);
+ pragma Assert (Result = 0);
+ Result := sigaddset (Unblocked_Mask'Access, SIGFPE);
+ pragma Assert (Result = 0);
+ Result := sigaddset (Unblocked_Mask'Access, SIGILL);
+ pragma Assert (Result = 0);
+ Result := sigaddset (Unblocked_Mask'Access, SIGSEGV);
+ pragma Assert (Result = 0);
+
+ Result :=
+ pthread_sigmask
+ (SIG_UNBLOCK,
+ Unblocked_Mask'Access,
+ Old_Set'Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+ end if;
+ end Abort_Handler;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
+ pragma Unreferenced (T);
+ pragma Unreferenced (On);
+
+ begin
+ -- Nothing needed (why not???)
+
+ null;
+ end Stack_Guard;
+
+ -------------------
+ -- Get_Thread_Id --
+ -------------------
+
+ function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id renames Specific.Self;
+
+ -----------------------------
+ -- Install_Signal_Handlers --
+ -----------------------------
+
+ procedure Install_Signal_Handlers is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : int;
+
+ begin
+ act.sa_flags := 0;
+ act.sa_handler := Abort_Handler'Address;
+
+ Result := sigemptyset (Tmp_Set'Access);
+ pragma Assert (Result = 0);
+ act.sa_mask := Tmp_Set;
+
+ Result :=
+ sigaction
+ (Signal (Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ Interrupt_Management.Initialize_Interrupts;
+ end Install_Signal_Handlers;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : not null access Lock)
+ is
+ begin
+ L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
+ L.Prio_Ceiling := int (Prio);
+ L.Protocol := Mutex_Protocol;
+ pragma Assert (L.Mutex /= 0);
+ end Initialize_Lock;
+
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock;
+ Level : Lock_Level)
+ is
+ pragma Unreferenced (Level);
+ begin
+ L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
+ L.Prio_Ceiling := int (System.Any_Priority'Last);
+ L.Protocol := Mutex_Protocol;
+ pragma Assert (L.Mutex /= 0);
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : not null access Lock) is
+ Result : int;
+ begin
+ Result := semDelete (L.Mutex);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : not null access RTS_Lock) is
+ Result : int;
+ begin
+ Result := semDelete (L.Mutex);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
+ Result : int;
+
+ begin
+ if L.Protocol = Prio_Protect
+ and then int (Self.Common.Current_Priority) > L.Prio_Ceiling
+ then
+ Ceiling_Violation := True;
+ return;
+ else
+ Ceiling_Violation := False;
+ end if;
+
+ Result := semTake (L.Mutex, WAIT_FOREVER);
+ pragma Assert (Result = 0);
+ end Write_Lock;
+
+ procedure Write_Lock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ Result : int;
+ begin
+ if not Single_Lock or else Global_Lock then
+ Result := semTake (L.Mutex, WAIT_FOREVER);
+ pragma Assert (Result = 0);
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_Id) is
+ Result : int;
+ begin
+ if not Single_Lock then
+ Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
+ pragma Assert (Result = 0);
+ end if;
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : not null access Lock) is
+ Result : int;
+ begin
+ Result := semGive (L.Mutex);
+ pragma Assert (Result = 0);
+ end Unlock;
+
+ procedure Unlock
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
+ Result : int;
+ begin
+ if not Single_Lock or else Global_Lock then
+ Result := semGive (L.Mutex);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ procedure Unlock (T : Task_Id) is
+ Result : int;
+ begin
+ if not Single_Lock then
+ Result := semGive (T.Common.LL.L.Mutex);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+
+ Result : int;
+
+ begin
+ pragma Assert (Self_ID = Self);
+
+ -- Release the mutex before sleeping
+
+ Result :=
+ semGive (if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex);
+ pragma Assert (Result = 0);
+
+ -- Perform a blocking operation to take the CV semaphore. Note that a
+ -- blocking operation in VxWorks will reenable task scheduling. When we
+ -- are no longer blocked and control is returned, task scheduling will
+ -- again be disabled.
+
+ Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER);
+ pragma Assert (Result = 0);
+
+ -- Take the mutex back
+
+ Result :=
+ semTake ((if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
+ pragma Assert (Result = 0);
+ end Sleep;
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ -- This is for use within the run-time system, so abort is assumed to be
+ -- already deferred, and the caller should be holding its own ATCB lock.
+
+ procedure Timed_Sleep
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : System.Tasking.Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ pragma Unreferenced (Reason);
+
+ Orig : constant Duration := Monotonic_Clock;
+ Absolute : Duration;
+ Ticks : int;
+ Result : int;
+ Wakeup : Boolean := False;
+
+ begin
+ Timedout := False;
+ Yielded := True;
+
+ if Mode = Relative then
+ Absolute := Orig + Time;
+
+ -- Systematically add one since the first tick will delay *at most*
+ -- 1 / Rate_Duration seconds, so we need to add one to be on the
+ -- safe side.
+
+ Ticks := To_Clock_Ticks (Time);
+
+ if Ticks > 0 and then Ticks < int'Last then
+ Ticks := Ticks + 1;
+ end if;
+
+ else
+ Absolute := Time;
+ Ticks := To_Clock_Ticks (Time - Monotonic_Clock);
+ end if;
+
+ if Ticks > 0 then
+ loop
+ -- Release the mutex before sleeping
+
+ Result :=
+ semGive (if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex);
+ pragma Assert (Result = 0);
+
+ -- Perform a blocking operation to take the CV semaphore. Note
+ -- that a blocking operation in VxWorks will reenable task
+ -- scheduling. When we are no longer blocked and control is
+ -- returned, task scheduling will again be disabled.
+
+ Result := semTake (Self_ID.Common.LL.CV, Ticks);
+
+ if Result = 0 then
+
+ -- Somebody may have called Wakeup for us
+
+ Wakeup := True;
+
+ else
+ if errno /= S_objLib_OBJ_TIMEOUT then
+ Wakeup := True;
+
+ else
+ -- If Ticks = int'last, it was most probably truncated so
+ -- let's make another round after recomputing Ticks from
+ -- the absolute time.
+
+ if Ticks /= int'Last then
+ Timedout := True;
+
+ else
+ Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
+
+ if Ticks < 0 then
+ Timedout := True;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- Take the mutex back
+
+ Result :=
+ semTake ((if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
+ pragma Assert (Result = 0);
+
+ exit when Timedout or Wakeup;
+ end loop;
+
+ else
+ Timedout := True;
+
+ -- Should never hold a lock while yielding
+
+ if Single_Lock then
+ Result := semGive (Single_RTS_Lock.Mutex);
+ Result := taskDelay (0);
+ Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
+
+ else
+ Result := semGive (Self_ID.Common.LL.L.Mutex);
+ Result := taskDelay (0);
+ Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
+ end if;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ -- This is for use in implementing delay statements, so we assume the
+ -- caller is holding no locks.
+
+ procedure Timed_Delay
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Orig : constant Duration := Monotonic_Clock;
+ Absolute : Duration;
+ Ticks : int;
+ Timedout : Boolean;
+ Aborted : Boolean := False;
+
+ Result : int;
+ pragma Warnings (Off, Result);
+
+ begin
+ if Mode = Relative then
+ Absolute := Orig + Time;
+ Ticks := To_Clock_Ticks (Time);
+
+ if Ticks > 0 and then Ticks < int'Last then
+
+ -- First tick will delay anytime between 0 and 1 / sysClkRateGet
+ -- seconds, so we need to add one to be on the safe side.
+
+ Ticks := Ticks + 1;
+ end if;
+
+ else
+ Absolute := Time;
+ Ticks := To_Clock_Ticks (Time - Orig);
+ end if;
+
+ if Ticks > 0 then
+
+ -- Modifying State, locking the TCB
+
+ Result :=
+ semTake ((if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
+
+ pragma Assert (Result = 0);
+
+ Self_ID.Common.State := Delay_Sleep;
+ Timedout := False;
+
+ loop
+ Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ -- Release the TCB before sleeping
+
+ Result :=
+ semGive (if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex);
+ pragma Assert (Result = 0);
+
+ exit when Aborted;
+
+ Result := semTake (Self_ID.Common.LL.CV, Ticks);
+
+ if Result /= 0 then
+
+ -- If Ticks = int'last, it was most probably truncated, so make
+ -- another round after recomputing Ticks from absolute time.
+
+ if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then
+ Timedout := True;
+ else
+ Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
+
+ if Ticks < 0 then
+ Timedout := True;
+ end if;
+ end if;
+ end if;
+
+ -- Take back the lock after having slept, to protect further
+ -- access to Self_ID.
+
+ Result :=
+ semTake
+ ((if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
+
+ pragma Assert (Result = 0);
+
+ exit when Timedout;
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+
+ Result :=
+ semGive
+ (if Single_Lock
+ then Single_RTS_Lock.Mutex
+ else Self_ID.Common.LL.L.Mutex);
+
+ else
+ Result := taskDelay (0);
+ end if;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : int;
+ begin
+ Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ begin
+ return 1.0 / Duration (sysClkRateGet);
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+ Result : int;
+ begin
+ Result := semGive (T.Common.LL.CV);
+ pragma Assert (Result = 0);
+ end Wakeup;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ pragma Unreferenced (Do_Yield);
+ Result : int;
+ pragma Unreferenced (Result);
+ begin
+ Result := taskDelay (0);
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_Priority
+ (T : Task_Id;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ pragma Unreferenced (Loss_Of_Inheritance);
+
+ Result : int;
+
+ begin
+ Result :=
+ taskPrioritySet
+ (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio)));
+ pragma Assert (Result = 0);
+
+ -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of
+ -- the priority queue instead of the head. This is not the behavior
+ -- required by Annex D (RM D.2.3(5/2)), but we consider it an acceptable
+ -- variation (RM 1.1.3(6)), given this is the built-in behavior of the
+ -- operating system. VxWorks versions starting from 6.7 implement the
+ -- required Annex D semantics.
+
+ -- In older versions we attempted to better approximate the Annex D
+ -- required behavior, but this simulation was not entirely accurate,
+ -- and it seems better to live with the standard VxWorks semantics.
+
+ T.Common.Current_Priority := Prio;
+ end Set_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_Id) return System.Any_Priority is
+ begin
+ return T.Common.Current_Priority;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_Id) is
+ begin
+ -- Store the user-level task id in the Thread field (to be used
+ -- internally by the run-time system) and the kernel-level task id in
+ -- the LWP field (to be used by the debugger).
+
+ Self_ID.Common.LL.Thread := taskIdSelf;
+ Self_ID.Common.LL.LWP := getpid;
+
+ Specific.Set (Self_ID);
+
+ -- Properly initializes the FPU for PPC/MIPS systems
+
+ System.Float_Control.Reset;
+
+ -- Install the signal handlers
+
+ -- This is called for each task since there is no signal inheritance
+ -- between VxWorks tasks.
+
+ Install_Signal_Handlers;
+
+ -- If stack checking is enabled, set the stack limit for this task
+
+ if Set_Stack_Limit_Hook /= null then
+ Set_Stack_Limit_Hook.all;
+ end if;
+ end Enter_Task;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_Id is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (taskIdSelf);
+ end if;
+ end Register_Foreign_Thread;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
+
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
+ begin
+ Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
+ Self_ID.Common.LL.Thread := Null_Thread_Id;
+
+ if Self_ID.Common.LL.CV = 0 then
+ Succeeded := False;
+
+ else
+ Succeeded := True;
+
+ if not Single_Lock then
+ Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
+ end if;
+ end if;
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_Id;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ Adjusted_Stack_Size : size_t;
+
+ use type System.Multiprocessors.CPU_Range;
+
+ begin
+ -- Check whether both Dispatching_Domain and CPU are specified for
+ -- the task, and the CPU value is not contained within the range of
+ -- processors for the domain.
+
+ if T.Common.Domain /= null
+ and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
+ and then
+ (T.Common.Base_CPU not in T.Common.Domain'Range
+ or else not T.Common.Domain (T.Common.Base_CPU))
+ then
+ Succeeded := False;
+ return;
+ end if;
+
+ -- Ask for four extra bytes of stack space so that the ATCB pointer can
+ -- be stored below the stack limit, plus extra space for the frame of
+ -- Task_Wrapper. This is so the user gets the amount of stack requested
+ -- exclusive of the needs.
+
+ -- We also have to allocate n more bytes for the task name storage and
+ -- enough space for the Wind Task Control Block which is around 0x778
+ -- bytes. VxWorks also seems to carve out additional space, so use 2048
+ -- as a nice round number. We might want to increment to the nearest
+ -- page size in case we ever support VxVMI.
+
+ -- ??? - we should come back and visit this so we can set the task name
+ -- to something appropriate.
+
+ Adjusted_Stack_Size := size_t (Stack_Size) + 2048;
+
+ -- Since the initial signal mask of a thread is inherited from the
+ -- creator, and the Environment task has all its signals masked, we do
+ -- not need to manipulate caller's signal mask at this point. All tasks
+ -- in RTS will have All_Tasks_Mask initially.
+
+ -- We now compute the VxWorks task name and options, then spawn ...
+
+ declare
+ Name : aliased String (1 .. T.Common.Task_Image_Len + 1);
+ Name_Address : System.Address;
+ -- Task name we are going to hand down to VxWorks
+
+ function Get_Task_Options return int;
+ pragma Import (C, Get_Task_Options, "__gnat_get_task_options");
+ -- Function that returns the options to be set for the task that we
+ -- are creating. We fetch the options assigned to the current task,
+ -- so offering some user level control over the options for a task
+ -- hierarchy, and force VX_FP_TASK because it is almost always
+ -- required.
+
+ begin
+ -- If there is no Ada task name handy, let VxWorks choose one.
+ -- Otherwise, tell VxWorks what the Ada task name is.
+
+ if T.Common.Task_Image_Len = 0 then
+ Name_Address := System.Null_Address;
+ else
+ Name (1 .. Name'Last - 1) :=
+ T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
+ Name (Name'Last) := ASCII.NUL;
+ Name_Address := Name'Address;
+ end if;
+
+ -- Now spawn the VxWorks task for real
+
+ T.Common.LL.Thread :=
+ taskSpawn
+ (Name_Address,
+ To_VxWorks_Priority (int (Priority)),
+ Get_Task_Options,
+ Adjusted_Stack_Size,
+ Wrapper,
+ To_Address (T));
+ end;
+
+ -- Set processor affinity
+
+ Set_Task_Affinity (T);
+
+ -- Only case of failure is if taskSpawn returned 0 (aka Null_Thread_Id)
+
+ if T.Common.LL.Thread = Null_Thread_Id then
+ Succeeded := False;
+ else
+ Succeeded := True;
+ Task_Creation_Hook (T.Common.LL.Thread);
+ Set_Priority (T, Priority);
+ end if;
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_Id) is
+ Result : int;
+
+ begin
+ if not Single_Lock then
+ Result := semDelete (T.Common.LL.L.Mutex);
+ pragma Assert (Result = 0);
+ end if;
+
+ T.Common.LL.Thread := Null_Thread_Id;
+
+ Result := semDelete (T.Common.LL.CV);
+ pragma Assert (Result = 0);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ ATCB_Allocation.Free_ATCB (T);
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ Specific.Set (null);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_Id) is
+ Result : int;
+ begin
+ Result :=
+ kill
+ (T.Common.LL.Thread,
+ Signal (Interrupt_Management.Abort_Task_Interrupt));
+ pragma Assert (Result = 0);
+ end Abort_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ begin
+ -- Initialize internal state (always to False (RM D.10(6)))
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ -- Use simpler binary semaphore instead of VxWorks mutual exclusion
+ -- semaphore, because we don't need the fancier semantics and their
+ -- overhead.
+
+ S.L := semBCreate (SEM_Q_FIFO, SEM_FULL);
+
+ -- Initialize internal condition variable
+
+ S.CV := semBCreate (SEM_Q_FIFO, SEM_EMPTY);
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ pragma Unmodified (S);
+ -- S may be modified on other targets, but not on VxWorks
+
+ Result : STATUS;
+
+ begin
+ -- Destroy internal mutex
+
+ Result := semDelete (S.L);
+ pragma Assert (Result = OK);
+
+ -- Destroy internal condition variable
+
+ Result := semDelete (S.CV);
+ pragma Assert (Result = OK);
+ end Finalize;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ begin
+ -- We do not want to use lock on this read operation. State is marked
+ -- as Atomic so that we ensure that the value retrieved is correct.
+
+ return S.State;
+ end Current_State;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ Result : STATUS;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := semTake (S.L, WAIT_FOREVER);
+ pragma Assert (Result = OK);
+
+ S.State := False;
+
+ Result := semGive (S.L);
+ pragma Assert (Result = OK);
+
+ SSL.Abort_Undefer.all;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ Result : STATUS;
+
+ begin
+ -- Set_True can be called from an interrupt context, in which case
+ -- Abort_Defer is undefined.
+
+ if Is_Task_Context then
+ SSL.Abort_Defer.all;
+ end if;
+
+ Result := semTake (S.L, WAIT_FOREVER);
+ pragma Assert (Result = OK);
+
+ -- If there is already a task waiting on this suspension object then we
+ -- resume it, leaving the state of the suspension object to False, as it
+ -- is specified in (RM D.10 (9)). Otherwise, it just leaves the state to
+ -- True.
+
+ if S.Waiting then
+ S.Waiting := False;
+ S.State := False;
+
+ Result := semGive (S.CV);
+ pragma Assert (Result = OK);
+ else
+ S.State := True;
+ end if;
+
+ Result := semGive (S.L);
+ pragma Assert (Result = OK);
+
+ -- Set_True can be called from an interrupt context, in which case
+ -- Abort_Undefer is undefined.
+
+ if Is_Task_Context then
+ SSL.Abort_Undefer.all;
+ end if;
+
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ Result : STATUS;
+
+ begin
+ SSL.Abort_Defer.all;
+
+ Result := semTake (S.L, WAIT_FOREVER);
+
+ if S.Waiting then
+
+ -- Program_Error must be raised upon calling Suspend_Until_True
+ -- if another task is already waiting on that suspension object
+ -- (RM D.10(10)).
+
+ Result := semGive (S.L);
+ pragma Assert (Result = OK);
+
+ SSL.Abort_Undefer.all;
+
+ raise Program_Error;
+
+ else
+ -- Suspend the task if the state is False. Otherwise, the task
+ -- continues its execution, and the state of the suspension object
+ -- is set to False (RM D.10 (9)).
+
+ if S.State then
+ S.State := False;
+
+ Result := semGive (S.L);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+
+ else
+ S.Waiting := True;
+
+ -- Release the mutex before sleeping
+
+ Result := semGive (S.L);
+ pragma Assert (Result = OK);
+
+ SSL.Abort_Undefer.all;
+
+ Result := semTake (S.CV, WAIT_FOREVER);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end Suspend_Until_True;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy version
+
+ function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
+ pragma Unreferenced (Self_ID);
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
+ pragma Unreferenced (Self_ID);
+ begin
+ return True;
+ end Check_No_Locks;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_Id is
+ begin
+ return Environment_Task_Id;
+ end Environment_Task;
+
+ --------------
+ -- Lock_RTS --
+ --------------
+
+ procedure Lock_RTS is
+ begin
+ Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Lock_RTS;
+
+ ----------------
+ -- Unlock_RTS --
+ ----------------
+
+ procedure Unlock_RTS is
+ begin
+ Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Unlock_RTS;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ begin
+ if T.Common.LL.Thread /= Null_Thread_Id
+ and then T.Common.LL.Thread /= Thread_Self
+ then
+ return taskSuspend (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
+ is
+ begin
+ if T.Common.LL.Thread /= Null_Thread_Id
+ and then T.Common.LL.Thread /= Thread_Self
+ then
+ return taskResume (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Resume_Task;
+
+ --------------------
+ -- Stop_All_Tasks --
+ --------------------
+
+ procedure Stop_All_Tasks
+ is
+ Thread_Self : constant Thread_Id := taskIdSelf;
+ C : Task_Id;
+
+ Dummy : int;
+ Old : int;
+
+ begin
+ Old := Int_Lock;
+
+ C := All_Tasks_List;
+ while C /= null loop
+ if C.Common.LL.Thread /= Null_Thread_Id
+ and then C.Common.LL.Thread /= Thread_Self
+ then
+ Dummy := Task_Stop (C.Common.LL.Thread);
+ end if;
+
+ C := C.Common.All_Tasks_Link;
+ end loop;
+
+ Dummy := Int_Unlock (Old);
+ end Stop_All_Tasks;
+
+ ---------------
+ -- Stop_Task --
+ ---------------
+
+ function Stop_Task (T : ST.Task_Id) return Boolean is
+ begin
+ if T.Common.LL.Thread /= Null_Thread_Id then
+ return Task_Stop (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Stop_Task;
+
+ -------------------
+ -- Continue_Task --
+ -------------------
+
+ function Continue_Task (T : ST.Task_Id) return Boolean
+ is
+ begin
+ if T.Common.LL.Thread /= Null_Thread_Id then
+ return Task_Cont (T.Common.LL.Thread) = 0;
+ else
+ return True;
+ end if;
+ end Continue_Task;
+
+ ---------------------
+ -- Is_Task_Context --
+ ---------------------
+
+ function Is_Task_Context return Boolean is
+ begin
+ return System.OS_Interface.Interrupt_Context /= 1;
+ end Is_Task_Context;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ Result : int;
+ pragma Unreferenced (Result);
+
+ begin
+ Environment_Task_Id := Environment_Task;
+
+ Interrupt_Management.Initialize;
+ Specific.Initialize;
+
+ if Locking_Policy = 'C' then
+ Mutex_Protocol := Prio_Protect;
+ elsif Locking_Policy = 'I' then
+ Mutex_Protocol := Prio_Inherit;
+ else
+ Mutex_Protocol := Prio_None;
+ end if;
+
+ if Time_Slice_Val > 0 then
+ Result :=
+ Set_Time_Slice
+ (To_Clock_Ticks
+ (Duration (Time_Slice_Val) / Duration (1_000_000.0)));
+
+ elsif Dispatching_Policy = 'R' then
+ Result := Set_Time_Slice (To_Clock_Ticks (0.01));
+
+ end if;
+
+ -- Initialize the lock used to synchronize chain of all ATCBs
+
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ -- Make environment task known here because it doesn't go through
+ -- Activate_Tasks, which does it for all other tasks.
+
+ Known_Tasks (Known_Tasks'First) := Environment_Task;
+ Environment_Task.Known_Tasks_Index := Known_Tasks'First;
+
+ Enter_Task (Environment_Task);
+
+ -- Set processor affinity
+
+ Set_Task_Affinity (Environment_Task);
+ end Initialize;
+
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ Result : int := 0;
+ pragma Unreferenced (Result);
+
+ use System.Task_Info;
+ use type System.Multiprocessors.CPU_Range;
+
+ begin
+ -- Do nothing if the underlying thread has not yet been created. If the
+ -- thread has not yet been created then the proper affinity will be set
+ -- during its creation.
+
+ if T.Common.LL.Thread = Null_Thread_Id then
+ null;
+
+ -- pragma CPU
+
+ elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
+
+ -- Ada 2012 pragma CPU uses CPU numbers starting from 1, while on
+ -- VxWorks the first CPU is identified by a 0, so we need to adjust.
+
+ Result :=
+ taskCpuAffinitySet
+ (T.Common.LL.Thread, int (T.Common.Base_CPU) - 1);
+
+ -- Task_Info
+
+ elsif T.Common.Task_Info /= Unspecified_Task_Info then
+ Result := taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info);
+
+ -- Handle dispatching domains
+
+ elsif T.Common.Domain /= null
+ and then (T.Common.Domain /= ST.System_Domain
+ or else T.Common.Domain.all /=
+ (Multiprocessors.CPU'First ..
+ Multiprocessors.Number_Of_CPUs => True))
+ then
+ declare
+ CPU_Set : unsigned := 0;
+
+ begin
+ -- Set the affinity to all the processors belonging to the
+ -- dispatching domain.
+
+ for Proc in T.Common.Domain'Range loop
+ if T.Common.Domain (Proc) then
+
+ -- The thread affinity mask is a bit vector in which each
+ -- bit represents a logical processor.
+
+ CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1);
+ end if;
+ end loop;
+
+ Result := taskMaskAffinitySet (T.Common.LL.Thread, CPU_Set);
+ end;
+ end if;
+ end Set_Task_Affinity;
+
+end System.Task_Primitives.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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: <none>");
+ 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2009-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the GNU/Linux version of this module
+
+package body System.Task_Info is
+
+ N_CPU : Natural := 0;
+ pragma Atomic (N_CPU);
+ -- Cache CPU number. Use pragma Atomic to avoid a race condition when
+ -- setting N_CPU in Number_Of_Processors below.
+
+ --------------------------
+ -- Number_Of_Processors --
+ --------------------------
+
+ function Number_Of_Processors return Positive is
+ begin
+ if N_CPU = 0 then
+ N_CPU := Natural
+ (OS_Interface.sysconf (OS_Interface.SC_NPROCESSORS_ONLN));
+ end if;
+
+ return N_CPU;
+ end Number_Of_Processors;
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines associated with the
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+-- The functionality in this unit is now provided by the predefined package
+-- System.Multiprocessors and the CPU aspect. This package is obsolescent.
+
+-- This is the GNU/Linux version of this module
+
+with System.OS_Interface;
+
+package System.Task_Info is
+ pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
+ pragma Preelaborate;
+ pragma Elaborate_Body;
+ -- To ensure that a body is allowed
+
+ -- The Linux kernel provides a way to define the ideal processor to use for
+ -- a given thread. The ideal processor is not necessarily the one that will
+ -- be used by the OS but the OS will always try to schedule this thread to
+ -- the specified processor if it is available.
+
+ -- The Task_Info pragma:
+
+ -- pragma Task_Info (EXPRESSION);
+
+ -- allows the specification on a task by task basis of a value of type
+ -- System.Task_Info.Task_Info_Type to be passed to a task when it is
+ -- created. The specification of this type, and the effect on the task
+ -- that is created is target dependent.
+
+ -- The Task_Info pragma appears within a task definition (compare the
+ -- definition and implementation of pragma Priority). If no such pragma
+ -- appears, then the value Unspecified_Task_Info is passed. If a pragma
+ -- is present, then it supplies an alternative value. If the argument of
+ -- the pragma is a discriminant reference, then the value can be set on
+ -- a task by task basis by supplying the appropriate discriminant value.
+
+ -- Note that this means that the type used for Task_Info_Type must be
+ -- suitable for use as a discriminant (i.e. a scalar or access type).
+
+ -----------------------
+ -- Thread Attributes --
+ -----------------------
+
+ subtype CPU_Set is System.OS_Interface.cpu_set_t;
+
+ Any_CPU : constant CPU_Set := (bits => (others => True));
+ No_CPU : constant CPU_Set := (bits => (others => False));
+
+ Invalid_CPU_Number : exception;
+ -- Raised when an invalid CPU mask has been specified
+ -- i.e. An empty CPU set
+
+ type Thread_Attributes is record
+ CPU_Affinity : aliased CPU_Set := Any_CPU;
+ end record;
+
+ Default_Thread_Attributes : constant Thread_Attributes := (others => <>);
+
+ type Task_Info_Type is access all Thread_Attributes;
+
+ Unspecified_Task_Info : constant Task_Info_Type := null;
+
+ function Number_Of_Processors return Positive;
+ -- Returns the number of processors on the running host
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Windows (native) version of this module
+
+with System.OS_Interface;
+pragma Unreferenced (System.OS_Interface);
+-- System.OS_Interface is not used today, but the protocol between the
+-- run-time and the binder is that any tasking application uses
+-- System.OS_Interface, so notify the binder with this "with" clause.
+
+package body System.Task_Info is
+
+ N_CPU : Natural := 0;
+ pragma Atomic (N_CPU);
+ -- Cache CPU number. Use pragma Atomic to avoid a race condition when
+ -- setting N_CPU in Number_Of_Processors below.
+
+ --------------------------
+ -- Number_Of_Processors --
+ --------------------------
+
+ function Number_Of_Processors return Positive is
+ begin
+ if N_CPU = 0 then
+ declare
+ SI : aliased Win32.SYSTEM_INFO;
+ begin
+ Win32.GetSystemInfo (SI'Access);
+ N_CPU := Positive (SI.dwNumberOfProcessors);
+ end;
+ end if;
+
+ return N_CPU;
+ end Number_Of_Processors;
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines associated with the
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+-- The functionality in this unit is now provided by the predefined package
+-- System.Multiprocessors and the CPU aspect. This package is obsolescent.
+
+-- This is the Windows (native) version of this module
+
+with System.Win32;
+
+package System.Task_Info is
+ pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
+ pragma Preelaborate;
+ pragma Elaborate_Body;
+ -- To ensure that a body is allowed
+
+ use type System.Win32.ProcessorId;
+
+ -- Windows provides a way to define the ideal processor to use for a given
+ -- thread. The ideal processor is not necessarily the one that will be used
+ -- by the OS but the OS will always try to schedule this thread to the
+ -- specified processor if it is available.
+
+ -- The Task_Info pragma:
+
+ -- pragma Task_Info (EXPRESSION);
+
+ -- allows the specification on a task by task basis of a value of type
+ -- System.Task_Info.Task_Info_Type to be passed to a task when it is
+ -- created. The specification of this type, and the effect on the task
+ -- that is created is target dependent.
+
+ -- The Task_Info pragma appears within a task definition (compare the
+ -- definition and implementation of pragma Priority). If no such pragma
+ -- appears, then the value Unspecified_Task_Info is passed. If a pragma
+ -- is present, then it supplies an alternative value. If the argument of
+ -- the pragma is a discriminant reference, then the value can be set on
+ -- a task by task basis by supplying the appropriate discriminant value.
+
+ -- Note that this means that the type used for Task_Info_Type must be
+ -- suitable for use as a discriminant (i.e. a scalar or access type).
+
+ -----------------------
+ -- Thread Attributes --
+ -----------------------
+
+ subtype CPU_Number is System.Win32.ProcessorId;
+
+ Any_CPU : constant CPU_Number := -1;
+
+ Invalid_CPU_Number : exception;
+ -- Raised when an invalid CPU number has been specified
+ -- i.e. CPU > Number_Of_Processors.
+
+ type Thread_Attributes is record
+ CPU : CPU_Number := Any_CPU;
+ end record;
+
+ Default_Thread_Attributes : constant Thread_Attributes := (others => <>);
+
+ type Task_Info_Type is access all Thread_Attributes;
+
+ Unspecified_Task_Info : constant Task_Info_Type := null;
+
+ function Number_Of_Processors return Positive;
+ -- Returns the number of processors on the running host
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package body contains the routines associated with the implementation
+-- of the Task_Info pragma.
+
+-- This is the Solaris (native) version of this module
+
+package body System.Task_Info is
+
+ -----------------------------
+ -- Bound_Thread_Attributes --
+ -----------------------------
+
+ function Bound_Thread_Attributes return Thread_Attributes is
+ begin
+ return (False, True);
+ end Bound_Thread_Attributes;
+
+ function Bound_Thread_Attributes (CPU : CPU_Number)
+ return Thread_Attributes is
+ begin
+ return (True, True, CPU);
+ end Bound_Thread_Attributes;
+
+ ---------------------------------
+ -- New_Bound_Thread_Attributes --
+ ---------------------------------
+
+ function New_Bound_Thread_Attributes return Task_Info_Type is
+ begin
+ return new Thread_Attributes'(False, True);
+ end New_Bound_Thread_Attributes;
+
+ function New_Bound_Thread_Attributes (CPU : CPU_Number)
+ return Task_Info_Type is
+ begin
+ return new Thread_Attributes'(True, True, CPU);
+ end New_Bound_Thread_Attributes;
+
+ -----------------------------------
+ -- New_Unbound_Thread_Attributes --
+ -----------------------------------
+
+ function New_Unbound_Thread_Attributes return Task_Info_Type is
+ begin
+ return new Thread_Attributes'(False, False);
+ end New_Unbound_Thread_Attributes;
+
+ -------------------------------
+ -- Unbound_Thread_Attributes --
+ -------------------------------
+
+ function Unbound_Thread_Attributes return Thread_Attributes is
+ begin
+ return (False, False);
+ end Unbound_Thread_Attributes;
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines associated with the
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+-- The functionality in this unit is now provided by the predefined package
+-- System.Multiprocessors and the CPU aspect. This package is obsolescent.
+
+-- This is the Solaris (native) version of this module
+
+with System.OS_Interface;
+
+package System.Task_Info is
+ pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
+ pragma Preelaborate;
+ pragma Elaborate_Body;
+ -- To ensure that a body is allowed
+
+ -----------------------------------------------------
+ -- Binding of Tasks to LWPs and LWPs to processors --
+ -----------------------------------------------------
+
+ -- The Solaris implementation of the GNU Low-Level Interface (GNULLI)
+ -- implements each Ada task as a Solaris thread. The Solaris thread
+ -- library distributes threads across one or more LWPs (Light Weight
+ -- Process) that are members of the same process. Solaris distributes
+ -- processes and LWPs across the available CPUs on a given machine. The
+ -- pragma Task_Info provides the mechanism to control the distribution
+ -- of tasks to LWPs, and LWPs to processors.
+
+ -- Each thread has a number of attributes that dictate it's scheduling.
+ -- These attributes are:
+ --
+ -- New_LWP: whether a new LWP is created for this thread.
+ --
+ -- Bound_To_LWP: whether the thread is bound to a specific LWP
+ -- for its entire lifetime.
+ --
+ -- CPU: the CPU number associated to the LWP
+ --
+
+ -- The Task_Info pragma:
+
+ -- pragma Task_Info (EXPRESSION);
+
+ -- allows the specification on a task by task basis of a value of type
+ -- System.Task_Info.Task_Info_Type to be passed to a task when it is
+ -- created. The specification of this type, and the effect on the task
+ -- that is created is target dependent.
+
+ -- The Task_Info pragma appears within a task definition (compare the
+ -- definition and implementation of pragma Priority). If no such pragma
+ -- appears, then the value Unspecified_Task_Info is passed. If a pragma
+ -- is present, then it supplies an alternative value. If the argument of
+ -- the pragma is a discriminant reference, then the value can be set on
+ -- a task by task basis by supplying the appropriate discriminant value.
+
+ -- Note that this means that the type used for Task_Info_Type must be
+ -- suitable for use as a discriminant (i.e. a scalar or access type).
+
+ -----------------------
+ -- Thread Attributes --
+ -----------------------
+
+ subtype CPU_Number is System.OS_Interface.processorid_t;
+
+ CPU_UNCHANGED : constant CPU_Number := System.OS_Interface.PBIND_QUERY;
+ -- Do not bind the LWP to a specific processor
+
+ ANY_CPU : constant CPU_Number := System.OS_Interface.PBIND_NONE;
+ -- Bind the LWP to any processor
+
+ Invalid_CPU_Number : exception;
+
+ type Thread_Attributes (New_LWP : Boolean) is record
+ Bound_To_LWP : Boolean := True;
+ case New_LWP is
+ when False =>
+ null;
+ when True =>
+ CPU : CPU_Number := CPU_UNCHANGED;
+ end case;
+ end record;
+
+ Default_Thread_Attributes : constant Thread_Attributes := (False, True);
+
+ function Unbound_Thread_Attributes
+ return Thread_Attributes;
+
+ function Bound_Thread_Attributes
+ return Thread_Attributes;
+
+ function Bound_Thread_Attributes (CPU : CPU_Number)
+ return Thread_Attributes;
+
+ type Task_Info_Type is access all Thread_Attributes;
+
+ function New_Unbound_Thread_Attributes
+ return Task_Info_Type;
+
+ function New_Bound_Thread_Attributes
+ return Task_Info_Type;
+
+ function New_Bound_Thread_Attributes (CPU : CPU_Number)
+ return Task_Info_Type;
+
+ Unspecified_Task_Info : constant Task_Info_Type := null;
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines associated with the
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+-- The functionality in this unit is now provided by the predefined package
+-- System.Multiprocessors and the CPU aspect. This package is obsolescent.
+
+-- This is the VxWorks version of this package
+
+with Interfaces.C;
+
+package System.Task_Info is
+ pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
+ pragma Preelaborate;
+ pragma Elaborate_Body;
+ -- To ensure that a body is allowed
+
+ -----------------------------------------
+ -- Implementation of Task_Info Feature --
+ -----------------------------------------
+
+ -- The Task_Info pragma:
+
+ -- pragma Task_Info (EXPRESSION);
+
+ -- allows the specification on a task by task basis of a value of type
+ -- System.Task_Info.Task_Info_Type to be passed to a task when it is
+ -- created. The specification of this type, and the effect on the task
+ -- that is created is target dependent.
+
+ -- The Task_Info pragma appears within a task definition (compare the
+ -- definition and implementation of pragma Priority). If no such pragma
+ -- appears, then the value Unspecified_Task_Info is passed. If a pragma
+ -- is present, then it supplies an alternative value. If the argument of
+ -- the pragma is a discriminant reference, then the value can be set on
+ -- a task by task basis by supplying the appropriate discriminant value.
+
+ -- Note that this means that the type used for Task_Info_Type must be
+ -- suitable for use as a discriminant (i.e. a scalar or access type).
+
+ ------------------
+ -- Declarations --
+ ------------------
+
+ subtype Task_Info_Type is Interfaces.C.int;
+ -- This is a CPU number (natural - CPUs are 0-indexed on VxWorks)
+
+ use type Interfaces.C.int;
+
+ Unspecified_Task_Info : constant Task_Info_Type := -1;
+ -- Value passed to task in the absence of a Task_Info pragma
+ -- This value means do not try to set the CPU affinity
+
+end System.Task_Info;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- B o d y --
+-- (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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ I N F O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the definitions and routines associated with the
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+-- The functionality in this unit is now provided by the predefined package
+-- System.Multiprocessors and the CPU aspect. This package is obsolescent.
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a no tasking version of this package
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is new Integer;
+
+ type RTS_Lock is new Integer;
+
+ type Suspension_Object is new Integer;
+
+ type Task_Body_Access is access procedure;
+
+ type Private_Data is limited record
+ Thread : aliased Integer;
+ CV : aliased Integer;
+ L : aliased RTS_Lock;
+ end record;
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2014, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a HP-UX version of this package
+
+-- This package provides low-level support for most tasking features
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with System.OS_Interface;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the later one serves only as a semaphore so
+ -- that do not check for ceiling violations.
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+private
+ type Lock is record
+ L : aliased System.OS_Interface.pthread_mutex_t;
+ Priority : Integer;
+ Owner_Priority : Integer;
+ end record;
+
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased System.OS_Interface.pthread_mutex_t;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ type Private_Data is record
+ Thread : aliased System.OS_Interface.pthread_t;
+ -- pragma Atomic (Thread);
+ -- Unfortunately, the above fails because Thread is 64 bits.
+
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the
+ -- same value (thr_self value). We do not want to use lock on those
+ -- operations and the only thing we have to make sure is that they
+ -- are updated in atomic fashion.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a NT (native) version of this package
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with System.OS_Interface;
+with System.Win32;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the later one serves only as a semaphore so
+ -- that do not check for ceiling violations.
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+private
+
+ type Lock is record
+ Mutex : aliased System.OS_Interface.CRITICAL_SECTION;
+ Priority : Integer;
+ Owner_Priority : Integer;
+ end record;
+
+ type Condition_Variable is new System.Win32.HANDLE;
+
+ type RTS_Lock is new System.OS_Interface.CRITICAL_SECTION;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased System.OS_Interface.CRITICAL_SECTION;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased Win32.HANDLE;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ type Private_Data is limited record
+ Thread : aliased Win32.HANDLE;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ Thread_Id : aliased Win32.DWORD;
+ -- Used to provide a better tasking support in gdb
+
+ CV : aliased Condition_Variable;
+ -- Condition Variable used to implement Sleep/Wakeup
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a POSIX-like version of this package where no alternate stack
+-- is needed for stack checking.
+
+-- Note: this file can only be used for POSIX compliant systems
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with System.OS_Interface;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the later one serves only as a semaphore so
+ -- that do not check for ceiling violations.
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper declared
+ -- local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+private
+
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+
+ type Lock is record
+ WO : aliased RTS_Lock;
+ RW : aliased System.OS_Interface.pthread_rwlock_t;
+ end record;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased RTS_Lock;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ type Private_Data is limited record
+ Thread : aliased System.OS_Interface.pthread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
+ -- value (thr_self value). We do not want to use lock on those
+ -- operations and the only thing we have to make sure is that they are
+ -- updated in atomic fashion.
+
+ LWP : aliased System.Address;
+ -- The purpose of this field is to provide a better tasking support on
+ -- gdb. The order of the two first fields (Thread and LWP) is important.
+ -- On targets where lwp is not relevant, this is equivalent to Thread.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Should be commented ??? (in all versions of taspri)
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1991-2017, Florida State University --
+-- Copyright (C) 1995-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a POSIX-like version of this package
+
+-- Note: this file can only be used for POSIX compliant systems
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with System.OS_Interface;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the latter serves only as a semaphore so that
+ -- we do not check for ceiling violations.
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper declared
+ -- local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := System.OS_Interface.Alternate_Stack_Size;
+ -- Import value from System.OS_Interface
+
+private
+
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+
+ type Lock is record
+ RW : aliased System.OS_Interface.pthread_rwlock_t;
+ WO : aliased RTS_Lock;
+ end record;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased RTS_Lock;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ type Private_Data is limited record
+ Thread : aliased System.OS_Interface.pthread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
+ -- value (thr_self value). We do not want to use lock on those
+ -- operations and the only thing we have to make sure is that they are
+ -- updated in atomic fashion.
+
+ LWP : aliased System.Address;
+ -- The purpose of this field is to provide a better tasking support on
+ -- gdb. The order of the two first fields (Thread and LWP) is important.
+ -- On targets where lwp is not relevant, this is equivalent to Thread.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+ -- Should be commented ??? (in all versions of taspri)
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a Solaris version of this package
+
+-- This package provides low-level support for most tasking features
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with Ada.Unchecked_Conversion;
+
+with System.OS_Interface;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ type Lock_Ptr is access all Lock;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ type RTS_Lock_Ptr is access all RTS_Lock;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the later one serves only as a semaphore so
+ -- that do not check for ceiling violations.
+
+ function To_Lock_Ptr is
+ new Ada.Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr);
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+private
+
+ type Private_Task_Serial_Number is mod 2 ** Long_Long_Integer'Size;
+ -- Used to give each task a unique serial number
+
+ type Base_Lock is new System.OS_Interface.mutex_t;
+
+ type Owner_Int is new Integer;
+ for Owner_Int'Alignment use Standard'Maximum_Alignment;
+
+ type Owner_ID is access all Owner_Int;
+
+ function To_Owner_ID is
+ new Ada.Unchecked_Conversion (System.Address, Owner_ID);
+
+ type Lock is record
+ L : aliased Base_Lock;
+ Ceiling : System.Any_Priority := System.Any_Priority'First;
+ Saved_Priority : System.Any_Priority := System.Any_Priority'First;
+ Owner : Owner_ID;
+ Next : Lock_Ptr;
+ Level : Private_Task_Serial_Number := 0;
+ Buddy : Owner_ID;
+ Frozen : Boolean := False;
+ end record;
+
+ type RTS_Lock is new Lock;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased System.OS_Interface.mutex_t;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased System.OS_Interface.cond_t;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ -- Note that task support on gdb relies on the fact that the first two
+ -- fields of Private_Data are Thread and LWP.
+
+ type Private_Data is limited record
+ Thread : aliased System.OS_Interface.thread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
+ -- value (thr_self value). We do not want to use lock on those
+ -- operations and the only thing we have to make sure is that they are
+ -- updated in atomic fashion.
+
+ LWP : System.OS_Interface.lwpid_t;
+ -- The LWP id of the thread. Set by self in Enter_Task
+
+ CV : aliased System.OS_Interface.cond_t;
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+
+ Active_Priority : System.Any_Priority := System.Any_Priority'First;
+ -- Simulated active priority, used iff Priority_Ceiling_Support is True
+
+ Locking : Lock_Ptr;
+ Locks : Lock_Ptr;
+ Wakeups : Natural := 0;
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2001-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a VxWorks version of this package
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
+
+with System.OS_Interface;
+
+package System.Task_Primitives is
+ pragma Preelaborate;
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system. The difference between Lock
+ -- and the RTS_Lock is that the later one serves only as a semaphore so
+ -- that do not check for ceiling violations.
+
+ type Suspension_Object is limited private;
+ -- Should be used for the implementation of Ada.Synchronous_Task_Control
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task basis.
+ -- A component of this type is guaranteed to be included in the
+ -- Ada_Task_Control_Block.
+
+ subtype Task_Address is System.Address;
+ Task_Address_Size : constant := Standard'Address_Size;
+ -- Type used for task addresses and its size
+
+ Alternate_Stack_Size : constant := 0;
+ -- No alternate signal stack is used on this platform
+
+private
+
+ type Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit);
+
+ type Lock is record
+ Mutex : System.OS_Interface.SEM_ID;
+ Protocol : Priority_Type;
+
+ Prio_Ceiling : System.OS_Interface.int;
+ -- Priority ceiling of lock
+ end record;
+
+ type RTS_Lock is new Lock;
+
+ type Suspension_Object is record
+ State : Boolean;
+ pragma Atomic (State);
+ -- Boolean that indicates whether the object is open. This field is
+ -- marked Atomic to ensure that we can read its value without locking
+ -- the access to the Suspension_Object.
+
+ Waiting : Boolean;
+ -- Flag showing if there is a task already suspended on this object
+
+ L : aliased System.OS_Interface.SEM_ID;
+ -- Protection for ensuring mutual exclusion on the Suspension_Object
+
+ CV : aliased System.OS_Interface.SEM_ID;
+ -- Condition variable used to queue threads until condition is signaled
+ end record;
+
+ type Private_Data is limited record
+ Thread : aliased System.OS_Interface.t_id := 0;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ LWP : aliased System.OS_Interface.t_id := 0;
+ -- The purpose of this field is to provide a better tasking support on
+ -- gdb. The order of the two first fields (Thread and LWP) is important.
+ -- On targets where lwp is not relevant, this is equivalent to Thread.
+
+ CV : aliased System.OS_Interface.SEM_ID;
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
+ -- <<L61b>>
+ -- 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...
+ -- <<L31b>>
+ -- 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;
+ -- <<L1>>
+ -- ...B...
+ -- goto L3;
+ -- <<L2>>
+ -- ...C...
+ -- goto L3;
+ -- <<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;
+ -- <<L26b>>
+ -- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the parent package of the GNAT restricted tasking run time
+
+package System.Tasking.Restricted is
+end System.Tasking.Restricted;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
+ -- <<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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a POSIX version of this package where foreign threads are
+-- recognized.
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_Id associated with a thread
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ pragma Warnings (Off, Environment_Task);
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_key_create (ATCB_Key'Access, null);
+ pragma Assert (Result = 0);
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return pthread_getspecific (ATCB_Key) /= System.Null_Address;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
+ pragma Assert (Result = 0);
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ -- To make Ada tasks and C threads interoperate better, we have added some
+ -- functionality to Self. Suppose a C main program (with threads) calls an
+ -- Ada procedure and the Ada procedure calls the tasking runtime system.
+ -- Eventually, a call will be made to self. Since the call is not coming
+ -- from an Ada task, there will be no corresponding ATCB.
+
+ -- What we do in Self is to catch references that do not come from
+ -- recognized Ada tasks, and create an ATCB for the calling thread.
+
+ -- The new ATCB will be "detached" from the normal Ada task master
+ -- hierarchy, much like the existing implicitly created signal-server
+ -- tasks.
+
+ function Self return Task_Id is
+ Result : System.Address;
+
+ begin
+ Result := pthread_getspecific (ATCB_Key);
+
+ -- If the key value is Null then it is a non-Ada task
+
+ if Result /= System.Null_Address then
+ return To_Task_Id (Result);
+ else
+ return Register_Foreign_Thread;
+ end if;
+ end Self;
+
+end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a POSIX-like version of this package
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_Id associated with a thread
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ pragma Warnings (Off, Environment_Task);
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_key_create (ATCB_Key'Access, null);
+ pragma Assert (Result = 0);
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return pthread_getspecific (ATCB_Key) /= System.Null_Address;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
+ pragma Assert (Result = 0);
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id is
+ begin
+ return To_Task_Id (pthread_getspecific (ATCB_Key));
+ end Self;
+
+end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a version for Solaris native threads
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ pragma Unreferenced (Environment_Task);
+ Result : Interfaces.C.int;
+ begin
+ Result := thr_keycreate (ATCB_Key'Access, System.Null_Address);
+ pragma Assert (Result = 0);
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ Unknown_Task : aliased System.Address;
+ Result : Interfaces.C.int;
+ begin
+ Result := thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return Unknown_Task /= System.Null_Address;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ Result : Interfaces.C.int;
+ begin
+ Result := thr_setspecific (ATCB_Key, To_Address (Self_Id));
+ pragma Assert (Result = 0);
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ -- To make Ada tasks and C threads interoperate better, we have
+ -- added some functionality to Self. Suppose a C main program
+ -- (with threads) calls an Ada procedure and the Ada procedure
+ -- calls the tasking run-time system. Eventually, a call will be
+ -- made to self. Since the call is not coming from an Ada task,
+ -- there will be no corresponding ATCB.
+
+ -- What we do in Self is to catch references that do not come
+ -- from recognized Ada tasks, and create an ATCB for the calling
+ -- thread.
+
+ -- The new ATCB will be "detached" from the normal Ada task
+ -- master hierarchy, much like the existing implicitly created
+ -- signal-server tasks.
+
+ function Self return Task_Id is
+ Result : Interfaces.C.int;
+ Self_Id : aliased System.Address;
+ begin
+ Result := thr_getspecific (ATCB_Key, Self_Id'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ if Self_Id = System.Null_Address then
+ return Register_Foreign_Thread;
+ else
+ return To_Task_Id (Self_Id);
+ end if;
+ end Self;
+
+end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a version of this package using TLS and where foreign threads are
+-- recognized.
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ATCB : aliased Task_Id := null;
+ pragma Thread_Local_Storage (ATCB);
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_Id) is
+ begin
+ ATCB := Environment_Task;
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return ATCB /= null;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ begin
+ ATCB := Self_Id;
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ -- To make Ada tasks and C threads interoperate better, we have added some
+ -- functionality to Self. Suppose a C main program (with threads) calls an
+ -- Ada procedure and the Ada procedure calls the tasking runtime system.
+ -- Eventually, a call will be made to self. Since the call is not coming
+ -- from an Ada task, there will be no corresponding ATCB.
+
+ -- What we do in Self is to catch references that do not come from
+ -- recognized Ada tasks, and create an ATCB for the calling thread.
+
+ -- The new ATCB will be "detached" from the normal Ada task master
+ -- hierarchy, much like the existing implicitly created signal-server
+ -- tasks.
+
+ function Self return Task_Id is
+ Result : constant Task_Id := ATCB;
+ begin
+ if Result /= null then
+ return Result;
+ else
+ -- If the value is Null then it is a non-Ada task
+
+ return Register_Foreign_Thread;
+ end if;
+ end Self;
+
+end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a VxWorks version of this package using Thread_Local_Storage
+-- support (VxWorks 6.6 and higher). The implementation is based on __threads
+-- support.
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ATCB : aliased Task_Id := null;
+ -- Ada Task_Id associated with a thread
+ pragma Thread_Local_Storage (ATCB);
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return ATCB /= Null_Task;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ begin
+ ATCB := Self_Id;
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id is
+ begin
+ return ATCB;
+ end Self;
+
+end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a VxWorks version of this package where foreign threads are
+-- recognized. The implementation is based on VxWorks taskVarLib.
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ATCB_Key : aliased System.Address := System.Null_Address;
+ -- Key used to find the Ada Task_Id associated with a thread
+
+ ATCB_Key_Addr : System.Address := ATCB_Key'Address;
+ pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr");
+ -- Exported to support the temporary AE653 task registration
+ -- implementation. This mechanism is used to minimize impact on other
+ -- targets.
+
+ Stack_Limit : aliased System.Address;
+
+ pragma Import (C, Stack_Limit, "__gnat_stack_limit");
+
+ type Set_Stack_Limit_Proc_Acc is access procedure;
+ pragma Convention (C, Set_Stack_Limit_Proc_Acc);
+
+ Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
+ pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
+ -- Procedure to be called when a task is created to set stack limit if
+ -- limit checking is used.
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return taskVarGet (taskIdSelf, ATCB_Key'Access) /= ERROR;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_Id) is
+ Result : STATUS;
+
+ begin
+ -- If argument is null, destroy task specific data, to make API
+ -- consistent with other platforms, and thus compatible with the
+ -- shared version of s-tpoaal.adb.
+
+ if Self_Id = null then
+ Result := taskVarDelete (taskIdSelf, ATCB_Key'Access);
+ pragma Assert (Result /= ERROR);
+ return;
+ end if;
+
+ if not Is_Valid_Task then
+ Result := taskVarAdd (Self_Id.Common.LL.Thread, ATCB_Key'Access);
+ pragma Assert (Result = OK);
+
+ if Stack_Check_Limits
+ and then Result /= ERROR
+ and then Set_Stack_Limit_Hook /= null
+ then
+ -- This will be initialized from taskInfoGet() once the task is
+ -- is running.
+
+ Result :=
+ taskVarAdd (Self_Id.Common.LL.Thread, Stack_Limit'Access);
+ pragma Assert (Result /= ERROR);
+ end if;
+ end if;
+
+ Result :=
+ taskVarSet
+ (Self_Id.Common.LL.Thread,
+ ATCB_Key'Access,
+ To_Address (Self_Id));
+ pragma Assert (Result /= ERROR);
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_Id is
+ begin
+ return To_Task_Id (ATCB_Key);
+ end Self;
+
+end Specific;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2008-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides vxworks specific support functions needed
+-- by System.OS_Interface.
+
+-- This is the VxWorks <= 6.5 kernel version of this package
+-- Also works for 6.6 uniprocessor
+
+package body System.VxWorks.Ext is
+
+ ERROR : constant := -1;
+
+ --------------
+ -- Int_Lock --
+ --------------
+
+ function intLock return int;
+ pragma Import (C, intLock, "intLock");
+
+ function Int_Lock return int renames intLock;
+
+ ----------------
+ -- Int_Unlock --
+ ----------------
+
+ function intUnlock (Old : int) return int;
+ pragma Import (C, intUnlock, "intUnlock");
+
+ function Int_Unlock (Old : int) return int renames intUnlock;
+
+ ---------------
+ -- semDelete --
+ ---------------
+
+ function semDelete (Sem : SEM_ID) return int is
+ function Os_Sem_Delete (Sem : SEM_ID) return int;
+ pragma Import (C, Os_Sem_Delete, "semDelete");
+ begin
+ return Os_Sem_Delete (Sem);
+ end semDelete;
+
+ ------------------------
+ -- taskCpuAffinitySet --
+ ------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int is
+ pragma Unreferenced (tid, CPU);
+ begin
+ return ERROR;
+ end taskCpuAffinitySet;
+
+ -------------------------
+ -- taskMaskAffinitySet --
+ -------------------------
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is
+ pragma Unreferenced (tid, CPU_Set);
+ begin
+ return ERROR;
+ end taskMaskAffinitySet;
+
+ --------------
+ -- taskCont --
+ --------------
+
+ function Task_Cont (tid : t_id) return int is
+ function taskCont (tid : t_id) return int;
+ pragma Import (C, taskCont, "taskCont");
+ begin
+ return taskCont (tid);
+ end Task_Cont;
+
+ --------------
+ -- taskStop --
+ --------------
+
+ function Task_Stop (tid : t_id) return int is
+ function taskStop (tid : t_id) return int;
+ pragma Import (C, taskStop, "taskStop");
+ begin
+ return taskStop (tid);
+ end Task_Stop;
+
+end System.VxWorks.Ext;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides vxworks specific support functions needed
+-- by System.OS_Interface.
+
+-- This is the VxWorks 6 kernel version of this package
+
+with Interfaces.C;
+
+package System.VxWorks.Ext is
+ pragma Preelaborate;
+
+ subtype SEM_ID is Long_Integer;
+ -- typedef struct semaphore *SEM_ID;
+
+ type sigset_t is mod 2 ** Long_Long_Integer'Size;
+
+ type t_id is new Long_Integer;
+ subtype int is Interfaces.C.int;
+ subtype unsigned is Interfaces.C.unsigned;
+
+ type Interrupt_Handler is access procedure (parameter : System.Address);
+ pragma Convention (C, Interrupt_Handler);
+
+ type Interrupt_Vector is new System.Address;
+
+ function Int_Lock return int;
+ pragma Convention (C, Int_Lock);
+
+ function Int_Unlock (Old : int) return int;
+ pragma Convention (C, Int_Unlock);
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int;
+ pragma Import (C, Interrupt_Connect, "intConnect");
+
+ function Interrupt_Context return int;
+ pragma Import (C, Interrupt_Context, "intContext");
+
+ function Interrupt_Number_To_Vector
+ (intNum : int) return Interrupt_Vector;
+ pragma Import (C, Interrupt_Number_To_Vector, "__gnat_inum_to_ivec");
+
+ function semDelete (Sem : SEM_ID) return int;
+ pragma Convention (C, semDelete);
+
+ function Task_Cont (tid : t_id) return int;
+ pragma Convention (C, Task_Cont);
+
+ function Task_Stop (tid : t_id) return int;
+ pragma Convention (C, Task_Stop);
+
+ function kill (pid : t_id; sig : int) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return t_id;
+ pragma Import (C, getpid, "taskIdSelf");
+
+ function Set_Time_Slice (ticks : int) return int;
+ pragma Import (C, Set_Time_Slice, "kernelTimeSlice");
+
+ type UINT64 is mod 2 ** Long_Long_Integer'Size;
+
+ function tickGet return UINT64;
+ -- Needed for ravenscar-cert
+ pragma Import (C, tickGet, "tick64Get");
+
+ --------------------------------
+ -- Processor Affinity for SMP --
+ --------------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int;
+ pragma Convention (C, taskCpuAffinitySet);
+ -- For SMP run-times set the CPU affinity.
+ -- For uniprocessor systems return ERROR status.
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int;
+ pragma Convention (C, taskMaskAffinitySet);
+ -- For SMP run-times set the CPU mask affinity.
+ -- For uniprocessor systems return ERROR status.
+
+end System.VxWorks.Ext;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2008-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides VxWorks specific support functions needed
+-- by System.OS_Interface.
+
+-- This is the VxWorks 6 RTP/SMP version of this package
+
+package body System.VxWorks.Ext is
+
+ ERROR : constant := -1;
+
+ --------------
+ -- Int_Lock --
+ --------------
+
+ function Int_Lock return int is
+ begin
+ return ERROR;
+ end Int_Lock;
+
+ ----------------
+ -- Int_Unlock --
+ ----------------
+
+ function Int_Unlock (Old : int) return int is
+ pragma Unreferenced (Old);
+ begin
+ return ERROR;
+ end Int_Unlock;
+
+ -----------------------
+ -- Interrupt_Connect --
+ -----------------------
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int
+ is
+ pragma Unreferenced (Vector, Handler, Parameter);
+ begin
+ return ERROR;
+ end Interrupt_Connect;
+
+ -----------------------
+ -- Interrupt_Context --
+ -----------------------
+
+ function Interrupt_Context return int is
+ begin
+ -- For RTPs, never in an interrupt context
+
+ return 0;
+ end Interrupt_Context;
+
+ --------------------------------
+ -- Interrupt_Number_To_Vector --
+ --------------------------------
+
+ function Interrupt_Number_To_Vector
+ (intNum : int) return Interrupt_Vector
+ is
+ pragma Unreferenced (intNum);
+ begin
+ return 0;
+ end Interrupt_Number_To_Vector;
+
+ ---------------
+ -- semDelete --
+ ---------------
+
+ function semDelete (Sem : SEM_ID) return int is
+ function OS_semDelete (Sem : SEM_ID) return int;
+ pragma Import (C, OS_semDelete, "semDelete");
+ begin
+ return OS_semDelete (Sem);
+ end semDelete;
+
+ --------------------
+ -- Set_Time_Slice --
+ --------------------
+
+ function Set_Time_Slice (ticks : int) return int is
+ pragma Unreferenced (ticks);
+ begin
+ return ERROR;
+ end Set_Time_Slice;
+
+ ------------------------
+ -- taskCpuAffinitySet --
+ ------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int
+ is
+ function Set_Affinity (tid : t_id; CPU : int) return int;
+ pragma Import (C, Set_Affinity, "__gnat_set_affinity");
+ begin
+ return Set_Affinity (tid, CPU);
+ end taskCpuAffinitySet;
+
+ -------------------------
+ -- taskMaskAffinitySet --
+ -------------------------
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is
+ function Set_Affinity (tid : t_id; CPU_Set : unsigned) return int;
+ pragma Import (C, Set_Affinity, "__gnat_set_affinity_mask");
+ begin
+ return Set_Affinity (tid, CPU_Set);
+ end taskMaskAffinitySet;
+
+end System.VxWorks.Ext;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2008-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides VxWorks specific support functions needed
+-- by System.OS_Interface.
+
+-- This is the VxWorks 6 RTP version of this package
+
+package body System.VxWorks.Ext is
+
+ ERROR : constant := -1;
+
+ --------------
+ -- Int_Lock --
+ --------------
+
+ function Int_Lock return int is
+ begin
+ return ERROR;
+ end Int_Lock;
+
+ ----------------
+ -- Int_Unlock --
+ ----------------
+
+ function Int_Unlock (Old : int) return int is
+ pragma Unreferenced (Old);
+ begin
+ return ERROR;
+ end Int_Unlock;
+
+ -----------------------
+ -- Interrupt_Connect --
+ -----------------------
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int
+ is
+ pragma Unreferenced (Vector, Handler, Parameter);
+ begin
+ return ERROR;
+ end Interrupt_Connect;
+
+ -----------------------
+ -- Interrupt_Context --
+ -----------------------
+
+ function Interrupt_Context return int is
+ begin
+ -- For RTPs, never in an interrupt context
+
+ return 0;
+ end Interrupt_Context;
+
+ --------------------------------
+ -- Interrupt_Number_To_Vector --
+ --------------------------------
+
+ function Interrupt_Number_To_Vector
+ (intNum : int) return Interrupt_Vector
+ is
+ pragma Unreferenced (intNum);
+ begin
+ return 0;
+ end Interrupt_Number_To_Vector;
+
+ ---------------
+ -- semDelete --
+ ---------------
+
+ function semDelete (Sem : SEM_ID) return int is
+ function OS_semDelete (Sem : SEM_ID) return int;
+ pragma Import (C, OS_semDelete, "semDelete");
+ begin
+ return OS_semDelete (Sem);
+ end semDelete;
+
+ --------------------
+ -- Set_Time_Slice --
+ --------------------
+
+ function Set_Time_Slice (ticks : int) return int is
+ pragma Unreferenced (ticks);
+ begin
+ return ERROR;
+ end Set_Time_Slice;
+
+ ------------------------
+ -- taskCpuAffinitySet --
+ ------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int is
+ pragma Unreferenced (tid, CPU);
+ begin
+ return ERROR;
+ end taskCpuAffinitySet;
+
+ -------------------------
+ -- taskMaskAffinitySet --
+ -------------------------
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is
+ pragma Unreferenced (tid, CPU_Set);
+ begin
+ return ERROR;
+ end taskMaskAffinitySet;
+
+end System.VxWorks.Ext;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides vxworks specific support functions needed
+-- by System.OS_Interface.
+
+-- This is the VxWorks 6 RTP version of this package
+
+with Interfaces.C;
+
+package System.VxWorks.Ext is
+ pragma Preelaborate;
+
+ subtype SEM_ID is Long_Integer;
+ -- typedef struct semaphore *SEM_ID;
+
+ type sigset_t is mod 2 ** Long_Long_Integer'Size;
+
+ type t_id is new Long_Integer;
+ subtype int is Interfaces.C.int;
+ subtype unsigned is Interfaces.C.unsigned;
+
+ type Interrupt_Handler is access procedure (parameter : System.Address);
+ pragma Convention (C, Interrupt_Handler);
+
+ type Interrupt_Vector is new System.Address;
+
+ function Int_Lock return int;
+ pragma Inline (Int_Lock);
+
+ function Int_Unlock (Old : int) return int;
+ pragma Inline (Int_Unlock);
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int;
+ pragma Convention (C, Interrupt_Connect);
+
+ function Interrupt_Context return int;
+ pragma Convention (C, Interrupt_Context);
+
+ function Interrupt_Number_To_Vector
+ (intNum : int) return Interrupt_Vector;
+ pragma Convention (C, Interrupt_Number_To_Vector);
+
+ function semDelete (Sem : SEM_ID) return int;
+ pragma Convention (C, semDelete);
+
+ function Task_Cont (tid : t_id) return int;
+ pragma Import (C, Task_Cont, "taskResume");
+
+ function Task_Stop (tid : t_id) return int;
+ pragma Import (C, Task_Stop, "taskSuspend");
+
+ function kill (pid : t_id; sig : int) return int;
+ pragma Import (C, kill, "taskKill");
+
+ function getpid return t_id;
+ pragma Import (C, getpid, "getpid");
+
+ function Set_Time_Slice (ticks : int) return int;
+ pragma Inline (Set_Time_Slice);
+
+ --------------------------------
+ -- Processor Affinity for SMP --
+ --------------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int;
+ pragma Convention (C, taskCpuAffinitySet);
+ -- For SMP run-times set the CPU affinity.
+ -- For uniprocessor systems return ERROR status.
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int;
+ pragma Convention (C, taskMaskAffinitySet);
+ -- For SMP run-times set the CPU mask affinity.
+ -- For uniprocessor systems return ERROR status.
+
+end System.VxWorks.Ext;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides VxWorks specific support functions needed
+-- by System.OS_Interface.
+
+-- This is the VxWorks 653 vThreads version of this package
+
+with Interfaces.C;
+
+package System.VxWorks.Ext is
+ pragma Preelaborate;
+
+ subtype SEM_ID is Long_Integer;
+ -- typedef struct semaphore *SEM_ID;
+
+ type sigset_t is mod 2 ** Interfaces.C.long'Size;
+
+ type t_id is new Long_Integer;
+ subtype int is Interfaces.C.int;
+ subtype unsigned is Interfaces.C.unsigned;
+
+ type Interrupt_Handler is access procedure (parameter : System.Address);
+ pragma Convention (C, Interrupt_Handler);
+
+ type Interrupt_Vector is new System.Address;
+ function Int_Lock return int;
+ pragma Inline (Int_Lock);
+
+ function Int_Unlock (Old : int) return int;
+ pragma Inline (Int_Unlock);
+
+ function Interrupt_Connect
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int;
+ pragma Convention (C, Interrupt_Connect);
+
+ function Interrupt_Context return int;
+ pragma Convention (C, Interrupt_Context);
+
+ function Interrupt_Number_To_Vector
+ (intNum : int) return Interrupt_Vector;
+ pragma Convention (C, Interrupt_Number_To_Vector);
+
+ function semDelete (Sem : SEM_ID) return int;
+ pragma Convention (C, semDelete);
+
+ function Task_Cont (tid : t_id) return int;
+ pragma Import (C, Task_Cont, "taskResume");
+
+ function Task_Stop (tid : t_id) return int;
+ pragma Import (C, Task_Stop, "taskSuspend");
+
+ function kill (pid : t_id; sig : int) return int;
+ pragma Import (C, kill, "kill");
+
+ function getpid return t_id;
+ pragma Import (C, getpid, "taskIdSelf");
+
+ function Set_Time_Slice (ticks : int) return int;
+ pragma Import (C, Set_Time_Slice, "kernelTimeSlice");
+
+ type UINT64 is mod 2 ** Long_Long_Integer'Size;
+
+ function tickGet return UINT64;
+ -- "tickGet" not available for cert vThreads:
+ pragma Import (C, tickGet, "tick64Get");
+
+ --------------------------------
+ -- Processor Affinity for SMP --
+ --------------------------------
+
+ function taskCpuAffinitySet (tid : t_id; CPU : int) return int;
+ pragma Convention (C, taskCpuAffinitySet);
+ -- For SMP run-times set the CPU affinity.
+ -- For uniprocessor systems return ERROR status.
+
+ function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int;
+ pragma Convention (C, taskMaskAffinitySet);
+ -- For SMP run-times set the CPU mask affinity.
+ -- For uniprocessor systems return ERROR status.
+
+end System.VxWorks.Ext;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2009-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S . E X T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides vxworks specific support functions needed
+-- by System.OS_Interface.
+
+-- This is the VxWorks 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the ARM VxWorks version of this package
+
+with Interfaces.C;
+
+package System.VxWorks is
+ pragma Preelaborate (System.VxWorks);
+
+ package IC renames Interfaces.C;
+
+ -- Floating point context record. ARM version
+
+ FP_SGPR_NUM_REGS : constant := 32;
+ type Fpr_Sgpr_Array is array (1 .. FP_SGPR_NUM_REGS) of IC.unsigned;
+
+ -- The record definition below matches what arch/arm/fppArmLib.h says
+
+ type FP_CONTEXT is record
+ fpsid : IC.unsigned; -- system ID register
+ fpscr : IC.unsigned; -- status and control register
+ fpexc : IC.unsigned; -- exception register
+ fpinst : IC.unsigned; -- instruction register
+ fpinst2 : IC.unsigned; -- instruction register 2
+ mfvfr0 : IC.unsigned; -- media and VFP feature Register 0
+ mfvfr1 : IC.unsigned; -- media and VFP feature Register 1
+ pad : IC.unsigned;
+ vfp_gpr : Fpr_Sgpr_Array;
+ end record;
+
+ for FP_CONTEXT'Alignment use 4;
+ pragma Convention (C, FP_CONTEXT);
+
+ Num_HW_Interrupts : constant := 256;
+ -- Number of entries in hardware interrupt vector table
+
+end System.VxWorks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the PPC VxWorks version of this package
+
+with Interfaces.C;
+
+package System.VxWorks is
+ pragma Preelaborate;
+
+ package IC renames Interfaces.C;
+
+ -- Floating point context record. PPC version
+
+ FP_NUM_DREGS : constant := 32;
+ type Fpr_Array is array (1 .. FP_NUM_DREGS) of IC.double;
+
+ type FP_CONTEXT is record
+ fpr : Fpr_Array;
+ fpcsr : IC.int;
+ fpcsrCopy : IC.int;
+ end record;
+ pragma Convention (C, FP_CONTEXT);
+
+ Num_HW_Interrupts : constant := 256;
+
+end System.VxWorks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the x86 VxWorks version of this package
+
+package System.VxWorks is
+ pragma Preelaborate;
+
+ -- Floating point context record. x86 version
+
+ -- There are two kinds of FP_CONTEXT for this architecture, corresponding
+ -- to newer and older processors. The type is defined in fppI86lib.h as a
+ -- union. The form used depends on the versions of the save and restore
+ -- routines that are selected by the user (these versions are provided in
+ -- vxwork.ads). Since we do not examine the contents of these objects, it
+ -- is sufficient to declare the type as of the required size: 512 bytes.
+
+ type FP_CONTEXT is array (1 .. 128) of Integer;
+ for FP_CONTEXT'Alignment use 4;
+ for FP_CONTEXT'Size use 512 * Storage_Unit;
+ pragma Convention (C, FP_CONTEXT);
+
+ Num_HW_Interrupts : constant := 256;
+ -- Number of entries in hardware interrupt vector table
+
+end System.VxWorks;
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT 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 *
+ * <http://www.gnu.org/licenses/>. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * Extensive contributions were provided by Ada Core Technologies Inc. *
+ * *
+ ****************************************************************************/
+
+/* This 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 <pthread.h>
+# include <time.h>
+
+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 <mach/mach.h>
+#include <mach/clock.h>
+#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;
+}
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a NO tasking version of this package
-
-package body System.Interrupt_Management.Operations is
-
- -- Turn off warnings since many unused formals
-
- pragma Warnings (Off);
-
- ----------------------------
- -- Thread_Block_Interrupt --
- ----------------------------
-
- procedure Thread_Block_Interrupt
- (Interrupt : Interrupt_ID)
- is
- begin
- null;
- end Thread_Block_Interrupt;
-
- ------------------------------
- -- Thread_Unblock_Interrupt --
- ------------------------------
-
- procedure Thread_Unblock_Interrupt
- (Interrupt : Interrupt_ID)
- is
- begin
- null;
- end Thread_Unblock_Interrupt;
-
- ------------------------
- -- Set_Interrupt_Mask --
- ------------------------
-
- procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
- begin
- null;
- end Set_Interrupt_Mask;
-
- procedure Set_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- OMask : access Interrupt_Mask) is
- begin
- null;
- end Set_Interrupt_Mask;
-
- ------------------------
- -- Get_Interrupt_Mask --
- ------------------------
-
- procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
- begin
- null;
- end Get_Interrupt_Mask;
-
- --------------------
- -- Interrupt_Wait --
- --------------------
-
- function Interrupt_Wait
- (Mask : access Interrupt_Mask)
- return Interrupt_ID
- is
- begin
- return 0;
- end Interrupt_Wait;
-
- ----------------------------
- -- Install_Default_Action --
- ----------------------------
-
- procedure Install_Default_Action (Interrupt : Interrupt_ID) is
- begin
- null;
- end Install_Default_Action;
-
- ---------------------------
- -- Install_Ignore_Action --
- ---------------------------
-
- procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
- begin
- null;
- end Install_Ignore_Action;
-
- -------------------------
- -- Fill_Interrupt_Mask --
- -------------------------
-
- procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
- begin
- null;
- end Fill_Interrupt_Mask;
-
- --------------------------
- -- Empty_Interrupt_Mask --
- --------------------------
-
- procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
- begin
- null;
- end Empty_Interrupt_Mask;
-
- ---------------------------
- -- Add_To_Interrupt_Mask --
- ---------------------------
-
- procedure Add_To_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID)
- is
- begin
- null;
- end Add_To_Interrupt_Mask;
-
- --------------------------------
- -- Delete_From_Interrupt_Mask --
- --------------------------------
-
- procedure Delete_From_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID)
- is
- begin
- null;
- end Delete_From_Interrupt_Mask;
-
- ---------------
- -- Is_Member --
- ---------------
-
- function Is_Member
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID) return Boolean
- is
- begin
- return False;
- end Is_Member;
-
- -------------------------
- -- Copy_Interrupt_Mask --
- -------------------------
-
- procedure Copy_Interrupt_Mask
- (X : out Interrupt_Mask;
- Y : Interrupt_Mask)
- is
- begin
- X := Y;
- end Copy_Interrupt_Mask;
-
- -------------------------
- -- Interrupt_Self_Process --
- -------------------------
-
- procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
- begin
- null;
- end Interrupt_Self_Process;
-
- --------------------------
- -- Setup_Interrupt_Mask --
- --------------------------
-
- procedure Setup_Interrupt_Mask is
- begin
- null;
- end Setup_Interrupt_Mask;
-
-end System.Interrupt_Management.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2010, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a POSIX-like version of this package
-
--- Note: this file can only be used for POSIX compliant systems
-
-with Interfaces.C;
-
-with System.OS_Interface;
-with System.Storage_Elements;
-
-package body System.Interrupt_Management.Operations is
-
- use Interfaces.C;
- use System.OS_Interface;
-
- ---------------------
- -- Local Variables --
- ---------------------
-
- Initial_Action : array (Signal) of aliased struct_sigaction;
-
- Default_Action : aliased struct_sigaction;
- pragma Warnings (Off, Default_Action);
-
- Ignore_Action : aliased struct_sigaction;
-
- ----------------------------
- -- Thread_Block_Interrupt --
- ----------------------------
-
- procedure Thread_Block_Interrupt
- (Interrupt : Interrupt_ID)
- is
- Result : Interfaces.C.int;
- Mask : aliased sigset_t;
- begin
- Result := sigemptyset (Mask'Access);
- pragma Assert (Result = 0);
- Result := sigaddset (Mask'Access, Signal (Interrupt));
- pragma Assert (Result = 0);
- Result := pthread_sigmask (SIG_BLOCK, Mask'Access, null);
- pragma Assert (Result = 0);
- end Thread_Block_Interrupt;
-
- ------------------------------
- -- Thread_Unblock_Interrupt --
- ------------------------------
-
- procedure Thread_Unblock_Interrupt
- (Interrupt : Interrupt_ID)
- is
- Mask : aliased sigset_t;
- Result : Interfaces.C.int;
- begin
- Result := sigemptyset (Mask'Access);
- pragma Assert (Result = 0);
- Result := sigaddset (Mask'Access, Signal (Interrupt));
- pragma Assert (Result = 0);
- Result := pthread_sigmask (SIG_UNBLOCK, Mask'Access, null);
- pragma Assert (Result = 0);
- end Thread_Unblock_Interrupt;
-
- ------------------------
- -- Set_Interrupt_Mask --
- ------------------------
-
- procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_sigmask (SIG_SETMASK, Mask, null);
- pragma Assert (Result = 0);
- end Set_Interrupt_Mask;
-
- procedure Set_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- OMask : access Interrupt_Mask)
- is
- Result : Interfaces.C.int;
- begin
- Result := pthread_sigmask (SIG_SETMASK, Mask, OMask);
- pragma Assert (Result = 0);
- end Set_Interrupt_Mask;
-
- ------------------------
- -- Get_Interrupt_Mask --
- ------------------------
-
- procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_sigmask (SIG_SETMASK, null, Mask);
- pragma Assert (Result = 0);
- end Get_Interrupt_Mask;
-
- --------------------
- -- Interrupt_Wait --
- --------------------
-
- function Interrupt_Wait
- (Mask : access Interrupt_Mask) return Interrupt_ID
- is
- Result : Interfaces.C.int;
- Sig : aliased Signal;
-
- begin
- Result := sigwait (Mask, Sig'Access);
-
- if Result /= 0 then
- return 0;
- end if;
-
- return Interrupt_ID (Sig);
- end Interrupt_Wait;
-
- ----------------------------
- -- Install_Default_Action --
- ----------------------------
-
- procedure Install_Default_Action (Interrupt : Interrupt_ID) is
- Result : Interfaces.C.int;
- begin
- Result := sigaction
- (Signal (Interrupt),
- Initial_Action (Signal (Interrupt))'Access, null);
- pragma Assert (Result = 0);
- end Install_Default_Action;
-
- ---------------------------
- -- Install_Ignore_Action --
- ---------------------------
-
- procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
- Result : Interfaces.C.int;
- begin
- Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
- pragma Assert (Result = 0);
- end Install_Ignore_Action;
-
- -------------------------
- -- Fill_Interrupt_Mask --
- -------------------------
-
- procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
- Result : Interfaces.C.int;
- begin
- Result := sigfillset (Mask);
- pragma Assert (Result = 0);
- end Fill_Interrupt_Mask;
-
- --------------------------
- -- Empty_Interrupt_Mask --
- --------------------------
-
- procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
- Result : Interfaces.C.int;
- begin
- Result := sigemptyset (Mask);
- pragma Assert (Result = 0);
- end Empty_Interrupt_Mask;
-
- ---------------------------
- -- Add_To_Interrupt_Mask --
- ---------------------------
-
- procedure Add_To_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID)
- is
- Result : Interfaces.C.int;
- begin
- Result := sigaddset (Mask, Signal (Interrupt));
- pragma Assert (Result = 0);
- end Add_To_Interrupt_Mask;
-
- --------------------------------
- -- Delete_From_Interrupt_Mask --
- --------------------------------
-
- procedure Delete_From_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID)
- is
- Result : Interfaces.C.int;
- begin
- Result := sigdelset (Mask, Signal (Interrupt));
- pragma Assert (Result = 0);
- end Delete_From_Interrupt_Mask;
-
- ---------------
- -- Is_Member --
- ---------------
-
- function Is_Member
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID) return Boolean
- is
- Result : Interfaces.C.int;
- begin
- Result := sigismember (Mask, Signal (Interrupt));
- pragma Assert (Result = 0 or else Result = 1);
- return Result = 1;
- end Is_Member;
-
- -------------------------
- -- Copy_Interrupt_Mask --
- -------------------------
-
- procedure Copy_Interrupt_Mask
- (X : out Interrupt_Mask;
- Y : Interrupt_Mask) is
- begin
- X := Y;
- end Copy_Interrupt_Mask;
-
- ----------------------------
- -- Interrupt_Self_Process --
- ----------------------------
-
- procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
- Result : Interfaces.C.int;
- begin
- Result := kill (getpid, Signal (Interrupt));
- pragma Assert (Result = 0);
- end Interrupt_Self_Process;
-
- --------------------------
- -- Setup_Interrupt_Mask --
- --------------------------
-
- procedure Setup_Interrupt_Mask is
- begin
- -- Mask task for all signals. The original mask of the Environment task
- -- will be recovered by Interrupt_Manager task during the elaboration
- -- of s-interr.adb.
-
- Set_Interrupt_Mask (All_Tasks_Mask'Access);
- end Setup_Interrupt_Mask;
-
-begin
- declare
- mask : aliased sigset_t;
- allmask : aliased sigset_t;
- Result : Interfaces.C.int;
-
- begin
- Interrupt_Management.Initialize;
-
- for Sig in 1 .. Signal'Last loop
- Result := sigaction
- (Sig, null, Initial_Action (Sig)'Access);
-
- -- ??? [assert 1]
- -- we can't check Result here since sigaction will fail on
- -- SIGKILL, SIGSTOP, and possibly other signals
- -- pragma Assert (Result = 0);
-
- end loop;
-
- -- Setup the masks to be exported
-
- Result := sigemptyset (mask'Access);
- pragma Assert (Result = 0);
-
- Result := sigfillset (allmask'Access);
- pragma Assert (Result = 0);
-
- Default_Action.sa_flags := 0;
- Default_Action.sa_mask := mask;
- Default_Action.sa_handler :=
- Storage_Elements.To_Address
- (Storage_Elements.Integer_Address (SIG_DFL));
-
- Ignore_Action.sa_flags := 0;
- Ignore_Action.sa_mask := mask;
- Ignore_Action.sa_handler :=
- Storage_Elements.To_Address
- (Storage_Elements.Integer_Address (SIG_IGN));
-
- for J in Interrupt_ID loop
- if Keep_Unmasked (J) then
- Result := sigaddset (mask'Access, Signal (J));
- pragma Assert (Result = 0);
- Result := sigdelset (allmask'Access, Signal (J));
- pragma Assert (Result = 0);
- end if;
- end loop;
-
- -- The Keep_Unmasked signals should be unmasked for Environment task
-
- Result := pthread_sigmask (SIG_UNBLOCK, mask'Access, null);
- pragma Assert (Result = 0);
-
- -- Get the signal mask of the Environment Task
-
- Result := pthread_sigmask (SIG_SETMASK, null, mask'Access);
- pragma Assert (Result = 0);
-
- -- Setup the constants exported
-
- Environment_Mask := Interrupt_Mask (mask);
-
- All_Tasks_Mask := Interrupt_Mask (allmask);
- end;
-
-end System.Interrupt_Management.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a VxWorks version of this package. Many operations are null as this
--- package supports the use of Ada interrupt handling facilities for signals,
--- while those facilities are used for hardware interrupts on these targets.
-
-with Ada.Exceptions;
-
-with Interfaces.C;
-
-with System.OS_Interface;
-
-package body System.Interrupt_Management.Operations is
-
- use Ada.Exceptions;
- use Interfaces.C;
- use System.OS_Interface;
-
- ----------------------------
- -- Thread_Block_Interrupt --
- ----------------------------
-
- procedure Thread_Block_Interrupt
- (Interrupt : Interrupt_ID)
- is
- pragma Unreferenced (Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Thread_Block_Interrupt unimplemented");
- end Thread_Block_Interrupt;
-
- ------------------------------
- -- Thread_Unblock_Interrupt --
- ------------------------------
-
- procedure Thread_Unblock_Interrupt
- (Interrupt : Interrupt_ID)
- is
- pragma Unreferenced (Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Thread_Unblock_Interrupt unimplemented");
- end Thread_Unblock_Interrupt;
-
- ------------------------
- -- Set_Interrupt_Mask --
- ------------------------
-
- procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
- pragma Unreferenced (Mask);
- begin
- null;
- end Set_Interrupt_Mask;
-
- procedure Set_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- OMask : access Interrupt_Mask)
- is
- pragma Unreferenced (Mask, OMask);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Set_Interrupt_Mask unimplemented");
- end Set_Interrupt_Mask;
-
- ------------------------
- -- Get_Interrupt_Mask --
- ------------------------
-
- procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
- pragma Unreferenced (Mask);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Get_Interrupt_Mask unimplemented");
- end Get_Interrupt_Mask;
-
- --------------------
- -- Interrupt_Wait --
- --------------------
-
- function Interrupt_Wait
- (Mask : access Interrupt_Mask) return Interrupt_ID
- is
- pragma Unreferenced (Mask);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Interrupt_Wait unimplemented");
- return 0;
- end Interrupt_Wait;
-
- ----------------------------
- -- Install_Default_Action --
- ----------------------------
-
- procedure Install_Default_Action (Interrupt : Interrupt_ID) is
- pragma Unreferenced (Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Install_Default_Action unimplemented");
- end Install_Default_Action;
-
- ---------------------------
- -- Install_Ignore_Action --
- ---------------------------
-
- procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
- pragma Unreferenced (Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Install_Ignore_Action unimplemented");
- end Install_Ignore_Action;
-
- -------------------------
- -- Fill_Interrupt_Mask --
- -------------------------
-
- procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
- pragma Unreferenced (Mask);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Fill_Interrupt_Mask unimplemented");
- end Fill_Interrupt_Mask;
-
- --------------------------
- -- Empty_Interrupt_Mask --
- --------------------------
-
- procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
- pragma Unreferenced (Mask);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Empty_Interrupt_Mask unimplemented");
- end Empty_Interrupt_Mask;
-
- ---------------------------
- -- Add_To_Interrupt_Mask --
- ---------------------------
-
- procedure Add_To_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID)
- is
- pragma Unreferenced (Mask, Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Add_To_Interrupt_Mask unimplemented");
- end Add_To_Interrupt_Mask;
-
- --------------------------------
- -- Delete_From_Interrupt_Mask --
- --------------------------------
-
- procedure Delete_From_Interrupt_Mask
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID)
- is
- pragma Unreferenced (Mask, Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Delete_From_Interrupt_Mask unimplemented");
- end Delete_From_Interrupt_Mask;
-
- ---------------
- -- Is_Member --
- ---------------
-
- function Is_Member
- (Mask : access Interrupt_Mask;
- Interrupt : Interrupt_ID) return Boolean
- is
- pragma Unreferenced (Mask, Interrupt);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Is_Member unimplemented");
- return False;
- end Is_Member;
-
- -------------------------
- -- Copy_Interrupt_Mask --
- -------------------------
-
- procedure Copy_Interrupt_Mask
- (X : out Interrupt_Mask;
- Y : Interrupt_Mask) is
- pragma Unreferenced (X, Y);
- begin
- Raise_Exception
- (Program_Error'Identity,
- "Copy_Interrupt_Mask unimplemented");
- end Copy_Interrupt_Mask;
-
- ----------------------------
- -- Interrupt_Self_Process --
- ----------------------------
-
- procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
- Result : Interfaces.C.int;
- begin
- Result := kill (getpid, Signal (Interrupt));
- pragma Assert (Result = 0);
- end Interrupt_Self_Process;
-
- --------------------------
- -- Setup_Interrupt_Mask --
- --------------------------
-
- procedure Setup_Interrupt_Mask is
- begin
- -- Nothing to be done. Ada interrupt facilities on VxWorks do not use
- -- signals but hardware interrupts. Therefore, interrupt management does
- -- not need anything related to signal masking. Note that this procedure
- -- cannot raise an exception (as some others in this package) because
- -- the generic implementation of the Timer_Server and timing events make
- -- explicit calls to this routine to make ensure proper signal masking
- -- on targets needed that.
-
- null;
- end Setup_Interrupt_Mask;
-
-end System.Interrupt_Management.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is for systems that do not support interrupts (or signals)
-
-package body System.Interrupts is
-
- pragma Warnings (Off); -- kill warnings on unreferenced formals
-
- use System.Tasking;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Unimplemented;
- -- This procedure raises a Program_Error with an appropriate message
- -- indicating that an unimplemented feature has been used.
-
- --------------------
- -- Attach_Handler --
- --------------------
-
- procedure Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Unimplemented;
- end Attach_Handler;
-
- -----------------------------
- -- Bind_Interrupt_To_Entry --
- -----------------------------
-
- procedure Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Int_Ref : System.Address)
- is
- begin
- Unimplemented;
- end Bind_Interrupt_To_Entry;
-
- ---------------------
- -- Block_Interrupt --
- ---------------------
-
- procedure Block_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented;
- end Block_Interrupt;
-
- ---------------------
- -- Current_Handler --
- ---------------------
-
- function Current_Handler
- (Interrupt : Interrupt_ID) return Parameterless_Handler
- is
- begin
- Unimplemented;
- return null;
- end Current_Handler;
-
- --------------------
- -- Detach_Handler --
- --------------------
-
- procedure Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Unimplemented;
- end Detach_Handler;
-
- ------------------------------
- -- Detach_Interrupt_Entries --
- ------------------------------
-
- procedure Detach_Interrupt_Entries (T : Task_Id) is
- begin
- Unimplemented;
- end Detach_Interrupt_Entries;
-
- ----------------------
- -- Exchange_Handler --
- ----------------------
-
- procedure Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Old_Handler := null;
- Unimplemented;
- end Exchange_Handler;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Object : in out Static_Interrupt_Protection) is
- begin
- Unimplemented;
- end Finalize;
-
- -------------------------------------
- -- Has_Interrupt_Or_Attach_Handler --
- -------------------------------------
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection)
- return Boolean
- is
- pragma Warnings (Off, Object);
- begin
- Unimplemented;
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection)
- return Boolean
- is
- pragma Warnings (Off, Object);
- begin
- Unimplemented;
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- ----------------------
- -- Ignore_Interrupt --
- ----------------------
-
- procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented;
- end Ignore_Interrupt;
-
- ----------------------
- -- Install_Handlers --
- ----------------------
-
- procedure Install_Handlers
- (Object : access Static_Interrupt_Protection;
- New_Handlers : New_Handler_Array)
- is
- begin
- Unimplemented;
- end Install_Handlers;
-
- ---------------------------------
- -- Install_Restricted_Handlers --
- ---------------------------------
-
- procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
- Handlers : New_Handler_Array)
- is
- begin
- Unimplemented;
- end Install_Restricted_Handlers;
-
- ----------------
- -- Is_Blocked --
- ----------------
-
- function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented;
- return True;
- end Is_Blocked;
-
- -----------------------
- -- Is_Entry_Attached --
- -----------------------
-
- function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented;
- return True;
- end Is_Entry_Attached;
-
- -------------------------
- -- Is_Handler_Attached --
- -------------------------
-
- function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented;
- return True;
- end Is_Handler_Attached;
-
- ----------------
- -- Is_Ignored --
- ----------------
-
- function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented;
- return True;
- end Is_Ignored;
-
- -----------------
- -- Is_Reserved --
- -----------------
-
- function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented;
- return True;
- end Is_Reserved;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference (Interrupt : Interrupt_ID) return System.Address is
- begin
- Unimplemented;
- return Interrupt'Address;
- end Reference;
-
- --------------------------------
- -- Register_Interrupt_Handler --
- --------------------------------
-
- procedure Register_Interrupt_Handler
- (Handler_Addr : System.Address)
- is
- begin
- Unimplemented;
- end Register_Interrupt_Handler;
-
- -----------------------
- -- Unblock_Interrupt --
- -----------------------
-
- procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented;
- end Unblock_Interrupt;
-
- ------------------
- -- Unblocked_By --
- ------------------
-
- function Unblocked_By (Interrupt : Interrupt_ID)
- return System.Tasking.Task_Id is
- begin
- Unimplemented;
- return null;
- end Unblocked_By;
-
- ------------------------
- -- Unignore_Interrupt --
- ------------------------
-
- procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented;
- end Unignore_Interrupt;
-
- -------------------
- -- Unimplemented; --
- -------------------
-
- procedure Unimplemented is
- begin
- raise Program_Error with "interrupts/signals not implemented";
- end Unimplemented;
-
-end System.Interrupts;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Invariants:
-
--- All user-handlable signals are masked at all times in all tasks/threads
--- except possibly for the Interrupt_Manager task.
-
--- When a user task wants to have the effect of masking/unmasking an signal,
--- it must call Block_Interrupt/Unblock_Interrupt, which will have the effect
--- of unmasking/masking the signal in the Interrupt_Manager task. These
--- comments do not apply to vectored hardware interrupts, which may be masked
--- or unmasked using routined interfaced to the relevant embedded RTOS system
--- calls.
-
--- Once we associate a Signal_Server_Task with an signal, the task never goes
--- away, and we never remove the association. On the other hand, it is more
--- convenient to terminate an associated Interrupt_Server_Task for a vectored
--- hardware interrupt (since we use a binary semaphore for synchronization
--- with the umbrella handler).
-
--- There is no more than one signal per Signal_Server_Task and no more than
--- one Signal_Server_Task per signal. The same relation holds for hardware
--- interrupts and Interrupt_Server_Task's at any given time. That is, only
--- one non-terminated Interrupt_Server_Task exists for a give interrupt at
--- any time.
-
--- Within this package, the lock L is used to protect the various status
--- tables. If there is a Server_Task associated with a signal or interrupt,
--- we use the per-task lock of the Server_Task instead so that we protect the
--- status between Interrupt_Manager and Server_Task. Protection among service
--- requests are ensured via user calls to the Interrupt_Manager entries.
-
--- This is reasonably generic version of this package, supporting vectored
--- hardware interrupts using non-RTOS specific adapter routines which should
--- easily implemented on any RTOS capable of supporting GNAT.
-
-with Ada.Unchecked_Conversion;
-with Ada.Task_Identification;
-
-with Interfaces.C; use Interfaces.C;
-with System.OS_Interface; use System.OS_Interface;
-with System.Interrupt_Management;
-with System.Task_Primitives.Operations;
-with System.Storage_Elements;
-with System.Tasking.Utilities;
-
-with System.Tasking.Rendezvous;
-pragma Elaborate_All (System.Tasking.Rendezvous);
-
-package body System.Interrupts is
-
- use Tasking;
-
- package POP renames System.Task_Primitives.Operations;
-
- function To_Ada is new Ada.Unchecked_Conversion
- (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id);
-
- function To_System is new Ada.Unchecked_Conversion
- (Ada.Task_Identification.Task_Id, Task_Id);
-
- -----------------
- -- Local Tasks --
- -----------------
-
- -- WARNING: System.Tasking.Stages performs calls to this task with low-
- -- level constructs. Do not change this spec without synchronizing it.
-
- task Interrupt_Manager is
- entry Detach_Interrupt_Entries (T : Task_Id);
-
- entry Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False);
-
- entry Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean);
-
- entry Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean);
-
- entry Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Interrupt : Interrupt_ID);
-
- pragma Interrupt_Priority (System.Interrupt_Priority'First);
- end Interrupt_Manager;
-
- task type Interrupt_Server_Task
- (Interrupt : Interrupt_ID;
- Int_Sema : Binary_Semaphore_Id)
- is
- -- Server task for vectored hardware interrupt handling
-
- pragma Interrupt_Priority (System.Interrupt_Priority'First + 2);
- end Interrupt_Server_Task;
-
- type Interrupt_Task_Access is access Interrupt_Server_Task;
-
- -------------------------------
- -- Local Types and Variables --
- -------------------------------
-
- type Entry_Assoc is record
- T : Task_Id;
- E : Task_Entry_Index;
- end record;
-
- type Handler_Assoc is record
- H : Parameterless_Handler;
- Static : Boolean; -- Indicates static binding;
- end record;
-
- User_Handler : array (Interrupt_ID) of Handler_Assoc :=
- (others => (null, Static => False));
- pragma Volatile_Components (User_Handler);
- -- Holds the protected procedure handler (if any) and its Static
- -- information for each interrupt or signal. A handler is static iff it
- -- is specified through the pragma Attach_Handler.
-
- User_Entry : array (Interrupt_ID) of Entry_Assoc :=
- (others => (T => Null_Task, E => Null_Task_Entry));
- pragma Volatile_Components (User_Entry);
- -- Holds the task and entry index (if any) for each interrupt / signal
-
- -- Type and Head, Tail of the list containing Registered Interrupt
- -- Handlers. These definitions are used to register the handlers
- -- specified by the pragma Interrupt_Handler.
-
- type Registered_Handler;
- type R_Link is access all Registered_Handler;
-
- type Registered_Handler is record
- H : System.Address := System.Null_Address;
- Next : R_Link := null;
- end record;
-
- Registered_Handler_Head : R_Link := null;
- Registered_Handler_Tail : R_Link := null;
-
- Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id :=
- (others => System.Tasking.Null_Task);
- pragma Atomic_Components (Server_ID);
- -- Holds the Task_Id of the Server_Task for each interrupt / signal.
- -- Task_Id is needed to accomplish locking per interrupt base. Also
- -- is needed to determine whether to create a new Server_Task.
-
- Semaphore_ID_Map : array
- (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) of
- Binary_Semaphore_Id := (others => 0);
- -- Array of binary semaphores associated with vectored interrupts. Note
- -- that the last bound should be Max_HW_Interrupt, but this will raise
- -- Storage_Error if Num_HW_Interrupts is null so use extra 4 bytes instead.
-
- Interrupt_Access_Hold : Interrupt_Task_Access;
- -- Variable for allocating an Interrupt_Server_Task
-
- Handler_Installed : array (HW_Interrupt) of Boolean := (others => False);
- -- True if Notify_Interrupt was connected to the interrupt. Handlers can
- -- be connected but disconnection is not possible on VxWorks. Therefore
- -- we ensure Notify_Installed is connected at most once.
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID);
- -- Check if Id is a reserved interrupt, and if so raise Program_Error
- -- with an appropriate message, otherwise return.
-
- procedure Finalize_Interrupt_Servers;
- -- Unbind the handlers for hardware interrupt server tasks at program
- -- termination.
-
- function Is_Registered (Handler : Parameterless_Handler) return Boolean;
- -- See if Handler has been "pragma"ed using Interrupt_Handler.
- -- Always consider a null handler as registered.
-
- procedure Notify_Interrupt (Param : System.Address);
- pragma Convention (C, Notify_Interrupt);
- -- Umbrella handler for vectored interrupts (not signals)
-
- procedure Install_Umbrella_Handler
- (Interrupt : HW_Interrupt;
- Handler : System.OS_Interface.Interrupt_Handler);
- -- Install the runtime umbrella handler for a vectored hardware
- -- interrupt
-
- procedure Unimplemented (Feature : String);
- pragma No_Return (Unimplemented);
- -- Used to mark a call to an unimplemented function. Raises Program_Error
- -- with an appropriate message noting that Feature is unimplemented.
-
- --------------------
- -- Attach_Handler --
- --------------------
-
- -- Calling this procedure with New_Handler = null and Static = True
- -- means we want to detach the current handler regardless of the previous
- -- handler's binding status (i.e. do not care if it is a dynamic or static
- -- handler).
-
- -- This option is needed so that during the finalization of a PO, we can
- -- detach handlers attached through pragma Attach_Handler.
-
- procedure Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False) is
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
- end Attach_Handler;
-
- -----------------------------
- -- Bind_Interrupt_To_Entry --
- -----------------------------
-
- -- This procedure raises a Program_Error if it tries to
- -- bind an interrupt to which an Entry or a Procedure is
- -- already bound.
-
- procedure Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Int_Ref : System.Address)
- is
- Interrupt : constant Interrupt_ID :=
- Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
- end Bind_Interrupt_To_Entry;
-
- ---------------------
- -- Block_Interrupt --
- ---------------------
-
- procedure Block_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Block_Interrupt");
- end Block_Interrupt;
-
- ------------------------------
- -- Check_Reserved_Interrupt --
- ------------------------------
-
- procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error with
- "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
- else
- return;
- end if;
- end Check_Reserved_Interrupt;
-
- ---------------------
- -- Current_Handler --
- ---------------------
-
- function Current_Handler
- (Interrupt : Interrupt_ID) return Parameterless_Handler
- is
- begin
- Check_Reserved_Interrupt (Interrupt);
-
- -- ??? Since Parameterless_Handler is not Atomic, the current
- -- implementation is wrong. We need a new service in Interrupt_Manager
- -- to ensure atomicity.
-
- return User_Handler (Interrupt).H;
- end Current_Handler;
-
- --------------------
- -- Detach_Handler --
- --------------------
-
- -- Calling this procedure with Static = True means we want to Detach the
- -- current handler regardless of the previous handler's binding status
- -- (i.e. do not care if it is a dynamic or static handler).
-
- -- This option is needed so that during the finalization of a PO, we can
- -- detach handlers attached through pragma Attach_Handler.
-
- procedure Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Detach_Handler (Interrupt, Static);
- end Detach_Handler;
-
- ------------------------------
- -- Detach_Interrupt_Entries --
- ------------------------------
-
- procedure Detach_Interrupt_Entries (T : Task_Id) is
- begin
- Interrupt_Manager.Detach_Interrupt_Entries (T);
- end Detach_Interrupt_Entries;
-
- ----------------------
- -- Exchange_Handler --
- ----------------------
-
- -- Calling this procedure with New_Handler = null and Static = True
- -- means we want to detach the current handler regardless of the previous
- -- handler's binding status (i.e. we do not care if it is a dynamic or
- -- static handler).
-
- -- This option is needed so that during the finalization of a PO, we can
- -- detach handlers attached through pragma Attach_Handler.
-
- procedure Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Exchange_Handler
- (Old_Handler, New_Handler, Interrupt, Static);
- end Exchange_Handler;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Object : in out Static_Interrupt_Protection) is
- begin
- -- ??? loop to be executed only when we're not doing library level
- -- finalization, since in this case all interrupt / signal tasks are
- -- gone.
-
- if not Interrupt_Manager'Terminated then
- for N in reverse Object.Previous_Handlers'Range loop
- Interrupt_Manager.Attach_Handler
- (New_Handler => Object.Previous_Handlers (N).Handler,
- Interrupt => Object.Previous_Handlers (N).Interrupt,
- Static => Object.Previous_Handlers (N).Static,
- Restoration => True);
- end loop;
- end if;
-
- Tasking.Protected_Objects.Entries.Finalize
- (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
- end Finalize;
-
- --------------------------------
- -- Finalize_Interrupt_Servers --
- --------------------------------
-
- -- Restore default handlers for interrupt servers
-
- -- This is called by the Interrupt_Manager task when it receives the abort
- -- signal during program finalization.
-
- procedure Finalize_Interrupt_Servers is
- HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
- begin
- if HW_Interrupts then
- for Int in HW_Interrupt loop
- if Server_ID (Interrupt_ID (Int)) /= null
- and then
- not Ada.Task_Identification.Is_Terminated
- (To_Ada (Server_ID (Interrupt_ID (Int))))
- then
- Interrupt_Manager.Attach_Handler
- (New_Handler => null,
- Interrupt => Interrupt_ID (Int),
- Static => True,
- Restoration => True);
- end if;
- end loop;
- end if;
- end Finalize_Interrupt_Servers;
-
- -------------------------------------
- -- Has_Interrupt_Or_Attach_Handler --
- -------------------------------------
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection)
- return Boolean
- is
- pragma Unreferenced (Object);
- begin
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection)
- return Boolean
- is
- pragma Unreferenced (Object);
- begin
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- ----------------------
- -- Ignore_Interrupt --
- ----------------------
-
- procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Ignore_Interrupt");
- end Ignore_Interrupt;
-
- ----------------------
- -- Install_Handlers --
- ----------------------
-
- procedure Install_Handlers
- (Object : access Static_Interrupt_Protection;
- New_Handlers : New_Handler_Array)
- is
- begin
- for N in New_Handlers'Range loop
-
- -- We need a lock around this ???
-
- Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
- Object.Previous_Handlers (N).Static := User_Handler
- (New_Handlers (N).Interrupt).Static;
-
- -- We call Exchange_Handler and not directly Interrupt_Manager.
- -- Exchange_Handler so we get the Is_Reserved check.
-
- Exchange_Handler
- (Old_Handler => Object.Previous_Handlers (N).Handler,
- New_Handler => New_Handlers (N).Handler,
- Interrupt => New_Handlers (N).Interrupt,
- Static => True);
- end loop;
- end Install_Handlers;
-
- ---------------------------------
- -- Install_Restricted_Handlers --
- ---------------------------------
-
- procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
- Handlers : New_Handler_Array)
- is
- pragma Unreferenced (Prio);
- begin
- for N in Handlers'Range loop
- Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
- end loop;
- end Install_Restricted_Handlers;
-
- ------------------------------
- -- Install_Umbrella_Handler --
- ------------------------------
-
- procedure Install_Umbrella_Handler
- (Interrupt : HW_Interrupt;
- Handler : System.OS_Interface.Interrupt_Handler)
- is
- Vec : constant Interrupt_Vector :=
- Interrupt_Number_To_Vector (int (Interrupt));
-
- Status : int;
-
- begin
- -- Only install umbrella handler when no Ada handler has already been
- -- installed. Note that the interrupt number is passed as a parameter
- -- when an interrupt occurs, so the umbrella handler has a different
- -- wrapper generated by intConnect for each interrupt number.
-
- if not Handler_Installed (Interrupt) then
- Status :=
- Interrupt_Connect (Vec, Handler, System.Address (Interrupt));
- pragma Assert (Status = 0);
-
- Handler_Installed (Interrupt) := True;
- end if;
- end Install_Umbrella_Handler;
-
- ----------------
- -- Is_Blocked --
- ----------------
-
- function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented ("Is_Blocked");
- return False;
- end Is_Blocked;
-
- -----------------------
- -- Is_Entry_Attached --
- -----------------------
-
- function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- Check_Reserved_Interrupt (Interrupt);
- return User_Entry (Interrupt).T /= Null_Task;
- end Is_Entry_Attached;
-
- -------------------------
- -- Is_Handler_Attached --
- -------------------------
-
- function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- Check_Reserved_Interrupt (Interrupt);
- return User_Handler (Interrupt).H /= null;
- end Is_Handler_Attached;
-
- ----------------
- -- Is_Ignored --
- ----------------
-
- function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented ("Is_Ignored");
- return False;
- end Is_Ignored;
-
- -------------------
- -- Is_Registered --
- -------------------
-
- function Is_Registered (Handler : Parameterless_Handler) return Boolean is
- type Fat_Ptr is record
- Object_Addr : System.Address;
- Handler_Addr : System.Address;
- end record;
-
- function To_Fat_Ptr is new Ada.Unchecked_Conversion
- (Parameterless_Handler, Fat_Ptr);
-
- Ptr : R_Link;
- Fat : Fat_Ptr;
-
- begin
- if Handler = null then
- return True;
- end if;
-
- Fat := To_Fat_Ptr (Handler);
-
- Ptr := Registered_Handler_Head;
- while Ptr /= null loop
- if Ptr.H = Fat.Handler_Addr then
- return True;
- end if;
-
- Ptr := Ptr.Next;
- end loop;
-
- return False;
- end Is_Registered;
-
- -----------------
- -- Is_Reserved --
- -----------------
-
- function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
- use System.Interrupt_Management;
- begin
- return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt));
- end Is_Reserved;
-
- ----------------------
- -- Notify_Interrupt --
- ----------------------
-
- -- Umbrella handler for vectored hardware interrupts (as opposed to signals
- -- and exceptions). As opposed to the signal implementation, this handler
- -- is installed in the vector table when the first Ada handler is attached
- -- to the interrupt. However because VxWorks don't support disconnecting
- -- handlers, this subprogram always test whether or not an Ada handler is
- -- effectively attached.
-
- -- Otherwise, the handler that existed prior to program startup is in the
- -- vector table. This ensures that handlers installed by the BSP are active
- -- unless explicitly replaced in the program text.
-
- -- Each Interrupt_Server_Task has an associated binary semaphore on which
- -- it pends once it's been started. This routine determines The appropriate
- -- semaphore and issues a semGive call, waking the server task. When
- -- a handler is unbound, System.Interrupts.Unbind_Handler issues a
- -- Binary_Semaphore_Flush, and the server task deletes its semaphore
- -- and terminates.
-
- procedure Notify_Interrupt (Param : System.Address) is
- Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
- Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt);
- Status : int;
- begin
- if Id /= 0 then
- Status := Binary_Semaphore_Release (Id);
- pragma Assert (Status = 0);
- end if;
- end Notify_Interrupt;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference (Interrupt : Interrupt_ID) return System.Address is
- begin
- Check_Reserved_Interrupt (Interrupt);
- return Storage_Elements.To_Address
- (Storage_Elements.Integer_Address (Interrupt));
- end Reference;
-
- --------------------------------
- -- Register_Interrupt_Handler --
- --------------------------------
-
- procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
- New_Node_Ptr : R_Link;
-
- begin
- -- This routine registers a handler as usable for dynamic interrupt
- -- handler association. Routines attaching and detaching handlers
- -- dynamically should determine whether the handler is registered.
- -- Program_Error should be raised if it is not registered.
-
- -- Pragma Interrupt_Handler can only appear in a library level PO
- -- definition and instantiation. Therefore, we do not need to implement
- -- an unregister operation. Nor do we need to protect the queue
- -- structure with a lock.
-
- pragma Assert (Handler_Addr /= System.Null_Address);
-
- New_Node_Ptr := new Registered_Handler;
- New_Node_Ptr.H := Handler_Addr;
-
- if Registered_Handler_Head = null then
- Registered_Handler_Head := New_Node_Ptr;
- Registered_Handler_Tail := New_Node_Ptr;
- else
- Registered_Handler_Tail.Next := New_Node_Ptr;
- Registered_Handler_Tail := New_Node_Ptr;
- end if;
- end Register_Interrupt_Handler;
-
- -----------------------
- -- Unblock_Interrupt --
- -----------------------
-
- procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Unblock_Interrupt");
- end Unblock_Interrupt;
-
- ------------------
- -- Unblocked_By --
- ------------------
-
- function Unblocked_By
- (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
- is
- begin
- Unimplemented ("Unblocked_By");
- return Null_Task;
- end Unblocked_By;
-
- ------------------------
- -- Unignore_Interrupt --
- ------------------------
-
- procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Unignore_Interrupt");
- end Unignore_Interrupt;
-
- -------------------
- -- Unimplemented --
- -------------------
-
- procedure Unimplemented (Feature : String) is
- begin
- raise Program_Error with Feature & " not implemented on VxWorks";
- end Unimplemented;
-
- -----------------------
- -- Interrupt_Manager --
- -----------------------
-
- task body Interrupt_Manager is
- -- By making this task independent of any master, when the process goes
- -- away, the Interrupt_Manager will terminate gracefully.
-
- Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
- pragma Unreferenced (Ignore);
-
- --------------------
- -- Local Routines --
- --------------------
-
- procedure Bind_Handler (Interrupt : Interrupt_ID);
- -- This procedure does not do anything if a signal is blocked.
- -- Otherwise, we have to interrupt Server_Task for status change
- -- through a wakeup signal.
-
- procedure Unbind_Handler (Interrupt : Interrupt_ID);
- -- This procedure does not do anything if a signal is blocked.
- -- Otherwise, we have to interrupt Server_Task for status change
- -- through an abort signal.
-
- procedure Unprotected_Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False);
-
- procedure Unprotected_Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean);
-
- ------------------
- -- Bind_Handler --
- ------------------
-
- procedure Bind_Handler (Interrupt : Interrupt_ID) is
- begin
- Install_Umbrella_Handler
- (HW_Interrupt (Interrupt), Notify_Interrupt'Access);
- end Bind_Handler;
-
- --------------------
- -- Unbind_Handler --
- --------------------
-
- procedure Unbind_Handler (Interrupt : Interrupt_ID) is
- Status : int;
-
- begin
- -- Flush server task off semaphore, allowing it to terminate
-
- Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt));
- pragma Assert (Status = 0);
- end Unbind_Handler;
-
- --------------------------------
- -- Unprotected_Detach_Handler --
- --------------------------------
-
- procedure Unprotected_Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean)
- is
- Old_Handler : Parameterless_Handler;
- begin
- if User_Entry (Interrupt).T /= Null_Task then
-
- -- If an interrupt entry is installed raise Program_Error
- -- (propagate it to the caller).
-
- raise Program_Error with
- "an interrupt entry is already installed";
- end if;
-
- -- Note : Static = True will pass the following check. This is the
- -- case when we want to detach a handler regardless of the static
- -- status of the Current_Handler.
-
- if not Static and then User_Handler (Interrupt).Static then
-
- -- Trying to detach a static Interrupt Handler, raise
- -- Program_Error.
-
- raise Program_Error with
- "trying to detach a static Interrupt Handler";
- end if;
-
- Old_Handler := User_Handler (Interrupt).H;
-
- -- The new handler
-
- User_Handler (Interrupt).H := null;
- User_Handler (Interrupt).Static := False;
-
- if Old_Handler /= null then
- Unbind_Handler (Interrupt);
- end if;
- end Unprotected_Detach_Handler;
-
- ----------------------------------
- -- Unprotected_Exchange_Handler --
- ----------------------------------
-
- procedure Unprotected_Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False)
- is
- begin
- if User_Entry (Interrupt).T /= Null_Task then
-
- -- If an interrupt entry is already installed, raise
- -- Program_Error (propagate it to the caller).
-
- raise Program_Error with "an interrupt is already installed";
- end if;
-
- -- Note : A null handler with Static = True will pass the following
- -- check. This is the case when we want to detach a handler
- -- regardless of the Static status of Current_Handler.
-
- -- We don't check anything if Restoration is True, since we may be
- -- detaching a static handler to restore a dynamic one.
-
- if not Restoration and then not Static
- and then (User_Handler (Interrupt).Static
-
- -- Trying to overwrite a static Interrupt Handler with a dynamic
- -- Handler
-
- -- The new handler is not specified as an Interrupt Handler by a
- -- pragma.
-
- or else not Is_Registered (New_Handler))
- then
- raise Program_Error with
- "trying to overwrite a static interrupt handler with a "
- & "dynamic handler";
- end if;
-
- -- Save the old handler
-
- Old_Handler := User_Handler (Interrupt).H;
-
- -- The new handler
-
- User_Handler (Interrupt).H := New_Handler;
-
- if New_Handler = null then
-
- -- The null handler means we are detaching the handler
-
- User_Handler (Interrupt).Static := False;
-
- else
- User_Handler (Interrupt).Static := Static;
- end if;
-
- -- Invoke a corresponding Server_Task if not yet created. Place
- -- Task_Id info in Server_ID array.
-
- if New_Handler /= null
- and then
- (Server_ID (Interrupt) = Null_Task
- or else
- Ada.Task_Identification.Is_Terminated
- (To_Ada (Server_ID (Interrupt))))
- then
- Interrupt_Access_Hold :=
- new Interrupt_Server_Task (Interrupt, Binary_Semaphore_Create);
- Server_ID (Interrupt) :=
- To_System (Interrupt_Access_Hold.all'Identity);
- end if;
-
- if (New_Handler = null) and then Old_Handler /= null then
-
- -- Restore default handler
-
- Unbind_Handler (Interrupt);
-
- elsif Old_Handler = null then
-
- -- Save default handler
-
- Bind_Handler (Interrupt);
- end if;
- end Unprotected_Exchange_Handler;
-
- -- Start of processing for Interrupt_Manager
-
- begin
- loop
- -- A block is needed to absorb Program_Error exception
-
- declare
- Old_Handler : Parameterless_Handler;
-
- begin
- select
- accept Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False)
- do
- Unprotected_Exchange_Handler
- (Old_Handler, New_Handler, Interrupt, Static, Restoration);
- end Attach_Handler;
-
- or
- accept Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean)
- do
- Unprotected_Exchange_Handler
- (Old_Handler, New_Handler, Interrupt, Static);
- end Exchange_Handler;
-
- or
- accept Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean)
- do
- Unprotected_Detach_Handler (Interrupt, Static);
- end Detach_Handler;
-
- or
- accept Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Interrupt : Interrupt_ID)
- do
- -- If there is a binding already (either a procedure or an
- -- entry), raise Program_Error (propagate it to the caller).
-
- if User_Handler (Interrupt).H /= null
- or else User_Entry (Interrupt).T /= Null_Task
- then
- raise Program_Error with
- "a binding for this interrupt is already present";
- end if;
-
- User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
-
- -- Indicate the attachment of interrupt entry in the ATCB.
- -- This is needed so when an interrupt entry task terminates
- -- the binding can be cleaned. The call to unbinding must be
- -- make by the task before it terminates.
-
- T.Interrupt_Entry := True;
-
- -- Invoke a corresponding Server_Task if not yet created.
- -- Place Task_Id info in Server_ID array.
-
- if Server_ID (Interrupt) = Null_Task
- or else
- Ada.Task_Identification.Is_Terminated
- (To_Ada (Server_ID (Interrupt)))
- then
- Interrupt_Access_Hold := new Interrupt_Server_Task
- (Interrupt, Binary_Semaphore_Create);
- Server_ID (Interrupt) :=
- To_System (Interrupt_Access_Hold.all'Identity);
- end if;
-
- Bind_Handler (Interrupt);
- end Bind_Interrupt_To_Entry;
-
- or
- accept Detach_Interrupt_Entries (T : Task_Id) do
- for Int in Interrupt_ID'Range loop
- if not Is_Reserved (Int) then
- if User_Entry (Int).T = T then
- User_Entry (Int) :=
- Entry_Assoc'
- (T => Null_Task, E => Null_Task_Entry);
- Unbind_Handler (Int);
- end if;
- end if;
- end loop;
-
- -- Indicate in ATCB that no interrupt entries are attached
-
- T.Interrupt_Entry := False;
- end Detach_Interrupt_Entries;
- end select;
-
- exception
- -- If there is a Program_Error we just want to propagate it to
- -- the caller and do not want to stop this task.
-
- when Program_Error =>
- null;
-
- when others =>
- pragma Assert (False);
- null;
- end;
- end loop;
-
- exception
- when Standard'Abort_Signal =>
-
- -- Flush interrupt server semaphores, so they can terminate
-
- Finalize_Interrupt_Servers;
- raise;
- end Interrupt_Manager;
-
- ---------------------------
- -- Interrupt_Server_Task --
- ---------------------------
-
- -- Server task for vectored hardware interrupt handling
-
- task body Interrupt_Server_Task is
- Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
-
- Self_Id : constant Task_Id := Self;
- Tmp_Handler : Parameterless_Handler;
- Tmp_ID : Task_Id;
- Tmp_Entry_Index : Task_Entry_Index;
- Status : int;
-
- begin
- Semaphore_ID_Map (Interrupt) := Int_Sema;
-
- loop
- -- Pend on semaphore that will be triggered by the umbrella handler
- -- when the associated interrupt comes in.
-
- Status := Binary_Semaphore_Obtain (Int_Sema);
- pragma Assert (Status = 0);
-
- if User_Handler (Interrupt).H /= null then
-
- -- Protected procedure handler
-
- Tmp_Handler := User_Handler (Interrupt).H;
- Tmp_Handler.all;
-
- elsif User_Entry (Interrupt).T /= Null_Task then
-
- -- Interrupt entry handler
-
- Tmp_ID := User_Entry (Interrupt).T;
- Tmp_Entry_Index := User_Entry (Interrupt).E;
- System.Tasking.Rendezvous.Call_Simple
- (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
-
- else
- -- Semaphore has been flushed by an unbind operation in the
- -- Interrupt_Manager. Terminate the server task.
-
- -- Wait for the Interrupt_Manager to complete its work
-
- POP.Write_Lock (Self_Id);
-
- -- Unassociate the interrupt handler
-
- Semaphore_ID_Map (Interrupt) := 0;
-
- -- Delete the associated semaphore
-
- Status := Binary_Semaphore_Delete (Int_Sema);
-
- pragma Assert (Status = 0);
-
- -- Set status for the Interrupt_Manager
-
- Server_ID (Interrupt) := Null_Task;
- POP.Unlock (Self_Id);
-
- exit;
- end if;
- end loop;
- end Interrupt_Server_Task;
-
-begin
- -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
-
- Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
-end System.Interrupts;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the NT version of this package
-
-with Ada.Task_Identification;
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-with System.Storage_Elements;
-with System.Task_Primitives.Operations;
-with System.Tasking.Utilities;
-with System.Tasking.Rendezvous;
-with System.Tasking.Initialization;
-with System.Interrupt_Management;
-with System.Parameters;
-
-package body System.Interrupts is
-
- use Parameters;
- use Tasking;
- use System.OS_Interface;
- use Interfaces.C;
-
- package STPO renames System.Task_Primitives.Operations;
- package IMNG renames System.Interrupt_Management;
-
- subtype int is Interfaces.C.int;
-
- function To_System is new Ada.Unchecked_Conversion
- (Ada.Task_Identification.Task_Id, Task_Id);
-
- type Handler_Kind is (Unknown, Task_Entry, Protected_Procedure);
-
- type Handler_Desc is record
- Kind : Handler_Kind := Unknown;
- T : Task_Id;
- E : Task_Entry_Index;
- H : Parameterless_Handler;
- Static : Boolean := False;
- end record;
-
- task type Server_Task (Interrupt : Interrupt_ID) is
- pragma Interrupt_Priority (System.Interrupt_Priority'Last);
- end Server_Task;
-
- type Server_Task_Access is access Server_Task;
-
- Handlers : array (Interrupt_ID) of Task_Id;
- Descriptors : array (Interrupt_ID) of Handler_Desc;
- Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0);
-
- pragma Volatile_Components (Interrupt_Count);
-
- procedure Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean);
- -- This internal procedure is needed to finalize protected objects that
- -- contain interrupt handlers.
-
- procedure Signal_Handler (Sig : Interrupt_ID);
- pragma Convention (C, Signal_Handler);
- -- This procedure is used to handle all the signals
-
- -- Type and Head, Tail of the list containing Registered Interrupt
- -- Handlers. These definitions are used to register the handlers
- -- specified by the pragma Interrupt_Handler.
-
- --------------------------
- -- Handler Registration --
- --------------------------
-
- type Registered_Handler;
- type R_Link is access all Registered_Handler;
-
- type Registered_Handler is record
- H : System.Address := System.Null_Address;
- Next : R_Link := null;
- end record;
-
- Registered_Handlers : R_Link := null;
-
- function Is_Registered (Handler : Parameterless_Handler) return Boolean;
- -- See if the Handler has been "pragma"ed using Interrupt_Handler.
- -- Always consider a null handler as registered.
-
- type Handler_Ptr is access procedure (Sig : Interrupt_ID);
- pragma Convention (C, Handler_Ptr);
-
- function TISR is new Ada.Unchecked_Conversion (Handler_Ptr, isr_address);
-
- --------------------
- -- Signal_Handler --
- --------------------
-
- procedure Signal_Handler (Sig : Interrupt_ID) is
- Handler : Task_Id renames Handlers (Sig);
-
- begin
- if Intr_Attach_Reset and then
- intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR
- then
- raise Program_Error;
- end if;
-
- if Handler /= null then
- Interrupt_Count (Sig) := Interrupt_Count (Sig) + 1;
- STPO.Wakeup (Handler, Interrupt_Server_Idle_Sleep);
- end if;
- end Signal_Handler;
-
- -----------------
- -- Is_Reserved --
- -----------------
-
- function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
- begin
- return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
- end Is_Reserved;
-
- -----------------------
- -- Is_Entry_Attached --
- -----------------------
-
- function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error with
- "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
- end if;
-
- return Descriptors (Interrupt).T /= Null_Task;
- end Is_Entry_Attached;
-
- -------------------------
- -- Is_Handler_Attached --
- -------------------------
-
- function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error with
- "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
- else
- return Descriptors (Interrupt).Kind /= Unknown;
- end if;
- end Is_Handler_Attached;
-
- ----------------
- -- Is_Ignored --
- ----------------
-
- function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
- begin
- raise Program_Error;
- return False;
- end Is_Ignored;
-
- ------------------
- -- Unblocked_By --
- ------------------
-
- function Unblocked_By (Interrupt : Interrupt_ID) return Task_Id is
- begin
- raise Program_Error;
- return Null_Task;
- end Unblocked_By;
-
- ----------------------
- -- Ignore_Interrupt --
- ----------------------
-
- procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- raise Program_Error;
- end Ignore_Interrupt;
-
- ------------------------
- -- Unignore_Interrupt --
- ------------------------
-
- procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- raise Program_Error;
- end Unignore_Interrupt;
-
- -------------------------------------
- -- Has_Interrupt_Or_Attach_Handler --
- -------------------------------------
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection) return Boolean
- is
- pragma Unreferenced (Object);
- begin
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Object : in out Static_Interrupt_Protection) is
- begin
- -- ??? loop to be executed only when we're not doing library level
- -- finalization, since in this case all interrupt tasks are gone.
-
- for N in reverse Object.Previous_Handlers'Range loop
- Attach_Handler
- (New_Handler => Object.Previous_Handlers (N).Handler,
- Interrupt => Object.Previous_Handlers (N).Interrupt,
- Static => Object.Previous_Handlers (N).Static,
- Restoration => True);
- end loop;
-
- Tasking.Protected_Objects.Entries.Finalize
- (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
- end Finalize;
-
- -------------------------------------
- -- Has_Interrupt_Or_Attach_Handler --
- -------------------------------------
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection) return Boolean
- is
- pragma Unreferenced (Object);
- begin
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- ----------------------
- -- Install_Handlers --
- ----------------------
-
- procedure Install_Handlers
- (Object : access Static_Interrupt_Protection;
- New_Handlers : New_Handler_Array)
- is
- begin
- for N in New_Handlers'Range loop
-
- -- We need a lock around this ???
-
- Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
- Object.Previous_Handlers (N).Static := Descriptors
- (New_Handlers (N).Interrupt).Static;
-
- -- We call Exchange_Handler and not directly Interrupt_Manager.
- -- Exchange_Handler so we get the Is_Reserved check.
-
- Exchange_Handler
- (Old_Handler => Object.Previous_Handlers (N).Handler,
- New_Handler => New_Handlers (N).Handler,
- Interrupt => New_Handlers (N).Interrupt,
- Static => True);
- end loop;
- end Install_Handlers;
-
- ---------------------------------
- -- Install_Restricted_Handlers --
- ---------------------------------
-
- procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
- Handlers : New_Handler_Array)
- is
- pragma Unreferenced (Prio);
- begin
- for N in Handlers'Range loop
- Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
- end loop;
- end Install_Restricted_Handlers;
-
- ---------------------
- -- Current_Handler --
- ---------------------
-
- function Current_Handler
- (Interrupt : Interrupt_ID) return Parameterless_Handler
- is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error;
- end if;
-
- if Descriptors (Interrupt).Kind = Protected_Procedure then
- return Descriptors (Interrupt).H;
- else
- return null;
- end if;
- end Current_Handler;
-
- --------------------
- -- Attach_Handler --
- --------------------
-
- procedure Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Attach_Handler (New_Handler, Interrupt, Static, False);
- end Attach_Handler;
-
- procedure Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean)
- is
- New_Task : Server_Task_Access;
-
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error;
- end if;
-
- if not Restoration and then not Static
-
- -- Tries to overwrite a static Interrupt Handler with dynamic handle
-
- and then
- (Descriptors (Interrupt).Static
-
- -- New handler not specified as an Interrupt Handler by a pragma
-
- or else not Is_Registered (New_Handler))
- then
- raise Program_Error with
- "trying to overwrite a static interrupt handler with a " &
- "dynamic handler";
- end if;
-
- if Handlers (Interrupt) = null then
- New_Task := new Server_Task (Interrupt);
- Handlers (Interrupt) := To_System (New_Task.all'Identity);
- end if;
-
- if intr_attach (int (Interrupt),
- TISR (Signal_Handler'Access)) = FUNC_ERR
- then
- raise Program_Error;
- end if;
-
- if New_Handler = null then
-
- -- The null handler means we are detaching the handler
-
- Descriptors (Interrupt) :=
- (Kind => Unknown, T => null, E => 0, H => null, Static => False);
-
- else
- Descriptors (Interrupt).Kind := Protected_Procedure;
- Descriptors (Interrupt).H := New_Handler;
- Descriptors (Interrupt).Static := Static;
- end if;
- end Attach_Handler;
-
- ----------------------
- -- Exchange_Handler --
- ----------------------
-
- procedure Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error;
- end if;
-
- if Descriptors (Interrupt).Kind = Task_Entry then
-
- -- In case we have an Interrupt Entry already installed, raise a
- -- program error (propagate it to the caller).
-
- raise Program_Error with "an interrupt is already installed";
-
- else
- Old_Handler := Current_Handler (Interrupt);
- Attach_Handler (New_Handler, Interrupt, Static);
- end if;
- end Exchange_Handler;
-
- --------------------
- -- Detach_Handler --
- --------------------
-
- procedure Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error;
- end if;
-
- if Descriptors (Interrupt).Kind = Task_Entry then
- raise Program_Error with "trying to detach an interrupt entry";
- end if;
-
- if not Static and then Descriptors (Interrupt).Static then
- raise Program_Error with
- "trying to detach a static interrupt handler";
- end if;
-
- Descriptors (Interrupt) :=
- (Kind => Unknown, T => null, E => 0, H => null, Static => False);
-
- if intr_attach (int (Interrupt), null) = FUNC_ERR then
- raise Program_Error;
- end if;
- end Detach_Handler;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference (Interrupt : Interrupt_ID) return System.Address is
- Signal : constant System.Address :=
- System.Storage_Elements.To_Address
- (System.Storage_Elements.Integer_Address (Interrupt));
-
- begin
- if Is_Reserved (Interrupt) then
-
- -- Only usable Interrupts can be used for binding it to an Entry
-
- raise Program_Error;
- end if;
-
- return Signal;
- end Reference;
-
- --------------------------------
- -- Register_Interrupt_Handler --
- --------------------------------
-
- procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
- begin
- Registered_Handlers :=
- new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers);
- end Register_Interrupt_Handler;
-
- -------------------
- -- Is_Registered --
- -------------------
-
- -- See if the Handler has been "pragma"ed using Interrupt_Handler.
- -- Always consider a null handler as registered.
-
- function Is_Registered (Handler : Parameterless_Handler) return Boolean is
- Ptr : R_Link := Registered_Handlers;
-
- type Fat_Ptr is record
- Object_Addr : System.Address;
- Handler_Addr : System.Address;
- end record;
-
- function To_Fat_Ptr is new Ada.Unchecked_Conversion
- (Parameterless_Handler, Fat_Ptr);
-
- Fat : Fat_Ptr;
-
- begin
- if Handler = null then
- return True;
- end if;
-
- Fat := To_Fat_Ptr (Handler);
-
- while Ptr /= null loop
- if Ptr.H = Fat.Handler_Addr then
- return True;
- end if;
-
- Ptr := Ptr.Next;
- end loop;
-
- return False;
- end Is_Registered;
-
- -----------------------------
- -- Bind_Interrupt_To_Entry --
- -----------------------------
-
- procedure Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Int_Ref : System.Address)
- is
- Interrupt : constant Interrupt_ID :=
- Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
-
- New_Task : Server_Task_Access;
-
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error;
- end if;
-
- if Descriptors (Interrupt).Kind /= Unknown then
- raise Program_Error with
- "a binding for this interrupt is already present";
- end if;
-
- if Handlers (Interrupt) = null then
- New_Task := new Server_Task (Interrupt);
- Handlers (Interrupt) := To_System (New_Task.all'Identity);
- end if;
-
- if intr_attach (int (Interrupt),
- TISR (Signal_Handler'Access)) = FUNC_ERR
- then
- raise Program_Error;
- end if;
-
- Descriptors (Interrupt).Kind := Task_Entry;
- Descriptors (Interrupt).T := T;
- Descriptors (Interrupt).E := E;
-
- -- Indicate the attachment of Interrupt Entry in ATCB. This is needed so
- -- that when an Interrupt Entry task terminates the binding can be
- -- cleaned up. The call to unbinding must be make by the task before it
- -- terminates.
-
- T.Interrupt_Entry := True;
- end Bind_Interrupt_To_Entry;
-
- ------------------------------
- -- Detach_Interrupt_Entries --
- ------------------------------
-
- procedure Detach_Interrupt_Entries (T : Task_Id) is
- begin
- for J in Interrupt_ID loop
- if not Is_Reserved (J) then
- if Descriptors (J).Kind = Task_Entry
- and then Descriptors (J).T = T
- then
- Descriptors (J).Kind := Unknown;
-
- if intr_attach (int (J), null) = FUNC_ERR then
- raise Program_Error;
- end if;
- end if;
- end if;
- end loop;
-
- -- Indicate in ATCB that no Interrupt Entries are attached
-
- T.Interrupt_Entry := True;
- end Detach_Interrupt_Entries;
-
- ---------------------
- -- Block_Interrupt --
- ---------------------
-
- procedure Block_Interrupt (Interrupt : Interrupt_ID) is
- begin
- raise Program_Error;
- end Block_Interrupt;
-
- -----------------------
- -- Unblock_Interrupt --
- -----------------------
-
- procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
- begin
- raise Program_Error;
- end Unblock_Interrupt;
-
- ----------------
- -- Is_Blocked --
- ----------------
-
- function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
- begin
- raise Program_Error;
- return False;
- end Is_Blocked;
-
- task body Server_Task is
- Ignore : constant Boolean := Utilities.Make_Independent;
-
- Desc : Handler_Desc renames Descriptors (Interrupt);
- Self_Id : constant Task_Id := STPO.Self;
- Temp : Parameterless_Handler;
-
- begin
- loop
- while Interrupt_Count (Interrupt) > 0 loop
- Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1;
- begin
- case Desc.Kind is
- when Unknown =>
- null;
- when Task_Entry =>
- Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address);
- when Protected_Procedure =>
- Temp := Desc.H;
- Temp.all;
- end case;
- exception
- when others => null;
- end;
- end loop;
-
- Initialization.Defer_Abort (Self_Id);
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
- STPO.Write_Lock (Self_Id);
- Self_Id.Common.State := Interrupt_Server_Idle_Sleep;
- STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep);
- Self_Id.Common.State := Runnable;
- STPO.Unlock (Self_Id);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
-
- Initialization.Undefer_Abort (Self_Id);
-
- -- Undefer abort here to allow a window for this task to be aborted
- -- at the time of system shutdown.
-
- end loop;
- end Server_Task;
-
-end System.Interrupts;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Invariants:
-
--- All user-handlable signals are masked at all times in all tasks/threads
--- except possibly for the Interrupt_Manager task.
-
--- When a user task wants to have the effect of masking/unmasking an signal,
--- it must call Block_Interrupt/Unblock_Interrupt, which will have the effect
--- of unmasking/masking the signal in the Interrupt_Manager task. These
--- comments do not apply to vectored hardware interrupts, which may be masked
--- or unmasked using routined interfaced to the relevant embedded RTOS system
--- calls.
-
--- Once we associate a Signal_Server_Task with an signal, the task never goes
--- away, and we never remove the association. On the other hand, it is more
--- convenient to terminate an associated Interrupt_Server_Task for a vectored
--- hardware interrupt (since we use a binary semaphore for synchronization
--- with the umbrella handler).
-
--- There is no more than one signal per Signal_Server_Task and no more than
--- one Signal_Server_Task per signal. The same relation holds for hardware
--- interrupts and Interrupt_Server_Task's at any given time. That is, only
--- one non-terminated Interrupt_Server_Task exists for a give interrupt at
--- any time.
-
--- Within this package, the lock L is used to protect the various status
--- tables. If there is a Server_Task associated with a signal or interrupt,
--- we use the per-task lock of the Server_Task instead so that we protect the
--- status between Interrupt_Manager and Server_Task. Protection among service
--- requests are ensured via user calls to the Interrupt_Manager entries.
-
--- This is reasonably generic version of this package, supporting vectored
--- hardware interrupts using non-RTOS specific adapter routines which should
--- easily implemented on any RTOS capable of supporting GNAT.
-
-with Ada.Unchecked_Conversion;
-with Ada.Task_Identification;
-
-with Interfaces.C; use Interfaces.C;
-with System.OS_Interface; use System.OS_Interface;
-with System.Interrupt_Management;
-with System.Task_Primitives.Operations;
-with System.Storage_Elements;
-with System.Tasking.Utilities;
-
-with System.Tasking.Rendezvous;
-pragma Elaborate_All (System.Tasking.Rendezvous);
-
-package body System.Interrupts is
-
- use Tasking;
-
- package POP renames System.Task_Primitives.Operations;
-
- function To_Ada is new Ada.Unchecked_Conversion
- (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id);
-
- function To_System is new Ada.Unchecked_Conversion
- (Ada.Task_Identification.Task_Id, Task_Id);
-
- -----------------
- -- Local Tasks --
- -----------------
-
- -- WARNING: System.Tasking.Stages performs calls to this task with low-
- -- level constructs. Do not change this spec without synchronizing it.
-
- task Interrupt_Manager is
- entry Detach_Interrupt_Entries (T : Task_Id);
-
- entry Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False);
-
- entry Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean);
-
- entry Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean);
-
- entry Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Interrupt : Interrupt_ID);
-
- pragma Interrupt_Priority (System.Interrupt_Priority'First);
- end Interrupt_Manager;
-
- task type Interrupt_Server_Task
- (Interrupt : Interrupt_ID;
- Int_Sema : Binary_Semaphore_Id)
- is
- -- Server task for vectored hardware interrupt handling
-
- pragma Interrupt_Priority (System.Interrupt_Priority'First + 2);
- end Interrupt_Server_Task;
-
- type Interrupt_Task_Access is access Interrupt_Server_Task;
-
- -------------------------------
- -- Local Types and Variables --
- -------------------------------
-
- type Entry_Assoc is record
- T : Task_Id;
- E : Task_Entry_Index;
- end record;
-
- type Handler_Assoc is record
- H : Parameterless_Handler;
- Static : Boolean; -- Indicates static binding;
- end record;
-
- User_Handler : array (Interrupt_ID) of Handler_Assoc :=
- (others => (null, Static => False));
- pragma Volatile_Components (User_Handler);
- -- Holds the protected procedure handler (if any) and its Static
- -- information for each interrupt or signal. A handler is static iff it
- -- is specified through the pragma Attach_Handler.
-
- User_Entry : array (Interrupt_ID) of Entry_Assoc :=
- (others => (T => Null_Task, E => Null_Task_Entry));
- pragma Volatile_Components (User_Entry);
- -- Holds the task and entry index (if any) for each interrupt / signal
-
- -- Type and Head, Tail of the list containing Registered Interrupt
- -- Handlers. These definitions are used to register the handlers
- -- specified by the pragma Interrupt_Handler.
-
- type Registered_Handler;
- type R_Link is access all Registered_Handler;
-
- type Registered_Handler is record
- H : System.Address := System.Null_Address;
- Next : R_Link := null;
- end record;
-
- Registered_Handler_Head : R_Link := null;
- Registered_Handler_Tail : R_Link := null;
-
- Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id :=
- (others => System.Tasking.Null_Task);
- pragma Atomic_Components (Server_ID);
- -- Holds the Task_Id of the Server_Task for each interrupt / signal.
- -- Task_Id is needed to accomplish locking per interrupt base. Also
- -- is needed to determine whether to create a new Server_Task.
-
- Semaphore_ID_Map : array
- (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) of
- Binary_Semaphore_Id := (others => 0);
- -- Array of binary semaphores associated with vectored interrupts. Note
- -- that the last bound should be Max_HW_Interrupt, but this will raise
- -- Storage_Error if Num_HW_Interrupts is null so use extra 4 bytes instead.
-
- Interrupt_Access_Hold : Interrupt_Task_Access;
- -- Variable for allocating an Interrupt_Server_Task
-
- Handler_Installed : array (HW_Interrupt) of Boolean := (others => False);
- -- True if Notify_Interrupt was connected to the interrupt. Handlers can
- -- be connected but disconnection is not possible on VxWorks. Therefore
- -- we ensure Notify_Installed is connected at most once.
-
- type Interrupt_Connector is access function
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler;
- Parameter : System.Address := System.Null_Address) return int;
- -- Profile must match VxWorks intConnect()
-
- Interrupt_Connect : Interrupt_Connector :=
- System.OS_Interface.Interrupt_Connect'Access;
- pragma Export (C, Interrupt_Connect, "__gnat_user_int_connect");
- -- Allow user alternatives to the OS implementation of
- -- System.OS_Interface.Interrupt_Connect. This allows the user to
- -- associate a handler with an interrupt source when an alternate routine
- -- is needed to do so. The association is performed in
- -- Interfaces.VxWorks.Interrupt_Connections. Defaults to the standard OS
- -- connection routine.
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID);
- -- Check if Id is a reserved interrupt, and if so raise Program_Error
- -- with an appropriate message, otherwise return.
-
- procedure Finalize_Interrupt_Servers;
- -- Unbind the handlers for hardware interrupt server tasks at program
- -- termination.
-
- function Is_Registered (Handler : Parameterless_Handler) return Boolean;
- -- See if Handler has been "pragma"ed using Interrupt_Handler.
- -- Always consider a null handler as registered.
-
- procedure Notify_Interrupt (Param : System.Address);
- pragma Convention (C, Notify_Interrupt);
- -- Umbrella handler for vectored interrupts (not signals)
-
- procedure Install_Umbrella_Handler
- (Interrupt : HW_Interrupt;
- Handler : System.OS_Interface.Interrupt_Handler);
- -- Install the runtime umbrella handler for a vectored hardware
- -- interrupt
-
- procedure Unimplemented (Feature : String);
- pragma No_Return (Unimplemented);
- -- Used to mark a call to an unimplemented function. Raises Program_Error
- -- with an appropriate message noting that Feature is unimplemented.
-
- --------------------
- -- Attach_Handler --
- --------------------
-
- -- Calling this procedure with New_Handler = null and Static = True
- -- means we want to detach the current handler regardless of the previous
- -- handler's binding status (i.e. do not care if it is a dynamic or static
- -- handler).
-
- -- This option is needed so that during the finalization of a PO, we can
- -- detach handlers attached through pragma Attach_Handler.
-
- procedure Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False) is
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
- end Attach_Handler;
-
- -----------------------------
- -- Bind_Interrupt_To_Entry --
- -----------------------------
-
- -- This procedure raises a Program_Error if it tries to
- -- bind an interrupt to which an Entry or a Procedure is
- -- already bound.
-
- procedure Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Int_Ref : System.Address)
- is
- Interrupt : constant Interrupt_ID :=
- Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
- end Bind_Interrupt_To_Entry;
-
- ---------------------
- -- Block_Interrupt --
- ---------------------
-
- procedure Block_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Block_Interrupt");
- end Block_Interrupt;
-
- ------------------------------
- -- Check_Reserved_Interrupt --
- ------------------------------
-
- procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is
- begin
- if Is_Reserved (Interrupt) then
- raise Program_Error with
- "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
- else
- return;
- end if;
- end Check_Reserved_Interrupt;
-
- ---------------------
- -- Current_Handler --
- ---------------------
-
- function Current_Handler
- (Interrupt : Interrupt_ID) return Parameterless_Handler
- is
- begin
- Check_Reserved_Interrupt (Interrupt);
-
- -- ??? Since Parameterless_Handler is not Atomic, the current
- -- implementation is wrong. We need a new service in Interrupt_Manager
- -- to ensure atomicity.
-
- return User_Handler (Interrupt).H;
- end Current_Handler;
-
- --------------------
- -- Detach_Handler --
- --------------------
-
- -- Calling this procedure with Static = True means we want to Detach the
- -- current handler regardless of the previous handler's binding status
- -- (i.e. do not care if it is a dynamic or static handler).
-
- -- This option is needed so that during the finalization of a PO, we can
- -- detach handlers attached through pragma Attach_Handler.
-
- procedure Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Detach_Handler (Interrupt, Static);
- end Detach_Handler;
-
- ------------------------------
- -- Detach_Interrupt_Entries --
- ------------------------------
-
- procedure Detach_Interrupt_Entries (T : Task_Id) is
- begin
- Interrupt_Manager.Detach_Interrupt_Entries (T);
- end Detach_Interrupt_Entries;
-
- ----------------------
- -- Exchange_Handler --
- ----------------------
-
- -- Calling this procedure with New_Handler = null and Static = True
- -- means we want to detach the current handler regardless of the previous
- -- handler's binding status (i.e. we do not care if it is a dynamic or
- -- static handler).
-
- -- This option is needed so that during the finalization of a PO, we can
- -- detach handlers attached through pragma Attach_Handler.
-
- procedure Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean := False)
- is
- begin
- Check_Reserved_Interrupt (Interrupt);
- Interrupt_Manager.Exchange_Handler
- (Old_Handler, New_Handler, Interrupt, Static);
- end Exchange_Handler;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Object : in out Static_Interrupt_Protection) is
- begin
- -- ??? loop to be executed only when we're not doing library level
- -- finalization, since in this case all interrupt / signal tasks are
- -- gone.
-
- if not Interrupt_Manager'Terminated then
- for N in reverse Object.Previous_Handlers'Range loop
- Interrupt_Manager.Attach_Handler
- (New_Handler => Object.Previous_Handlers (N).Handler,
- Interrupt => Object.Previous_Handlers (N).Interrupt,
- Static => Object.Previous_Handlers (N).Static,
- Restoration => True);
- end loop;
- end if;
-
- Tasking.Protected_Objects.Entries.Finalize
- (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
- end Finalize;
-
- --------------------------------
- -- Finalize_Interrupt_Servers --
- --------------------------------
-
- -- Restore default handlers for interrupt servers
-
- -- This is called by the Interrupt_Manager task when it receives the abort
- -- signal during program finalization.
-
- procedure Finalize_Interrupt_Servers is
- HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
- begin
- if HW_Interrupts then
- for Int in HW_Interrupt loop
- if Server_ID (Interrupt_ID (Int)) /= null
- and then
- not Ada.Task_Identification.Is_Terminated
- (To_Ada (Server_ID (Interrupt_ID (Int))))
- then
- Interrupt_Manager.Attach_Handler
- (New_Handler => null,
- Interrupt => Interrupt_ID (Int),
- Static => True,
- Restoration => True);
- end if;
- end loop;
- end if;
- end Finalize_Interrupt_Servers;
-
- -------------------------------------
- -- Has_Interrupt_Or_Attach_Handler --
- -------------------------------------
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection)
- return Boolean
- is
- pragma Unreferenced (Object);
- begin
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection)
- return Boolean
- is
- pragma Unreferenced (Object);
- begin
- return True;
- end Has_Interrupt_Or_Attach_Handler;
-
- ----------------------
- -- Ignore_Interrupt --
- ----------------------
-
- procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Ignore_Interrupt");
- end Ignore_Interrupt;
-
- ----------------------
- -- Install_Handlers --
- ----------------------
-
- procedure Install_Handlers
- (Object : access Static_Interrupt_Protection;
- New_Handlers : New_Handler_Array)
- is
- begin
- for N in New_Handlers'Range loop
-
- -- We need a lock around this ???
-
- Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
- Object.Previous_Handlers (N).Static := User_Handler
- (New_Handlers (N).Interrupt).Static;
-
- -- We call Exchange_Handler and not directly Interrupt_Manager.
- -- Exchange_Handler so we get the Is_Reserved check.
-
- Exchange_Handler
- (Old_Handler => Object.Previous_Handlers (N).Handler,
- New_Handler => New_Handlers (N).Handler,
- Interrupt => New_Handlers (N).Interrupt,
- Static => True);
- end loop;
- end Install_Handlers;
-
- ---------------------------------
- -- Install_Restricted_Handlers --
- ---------------------------------
-
- procedure Install_Restricted_Handlers
- (Prio : Any_Priority;
- Handlers : New_Handler_Array)
- is
- pragma Unreferenced (Prio);
- begin
- for N in Handlers'Range loop
- Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
- end loop;
- end Install_Restricted_Handlers;
-
- ------------------------------
- -- Install_Umbrella_Handler --
- ------------------------------
-
- procedure Install_Umbrella_Handler
- (Interrupt : HW_Interrupt;
- Handler : System.OS_Interface.Interrupt_Handler)
- is
- Vec : constant Interrupt_Vector :=
- Interrupt_Number_To_Vector (int (Interrupt));
-
- Status : int;
-
- begin
- -- Only install umbrella handler when no Ada handler has already been
- -- installed. Note that the interrupt number is passed as a parameter
- -- when an interrupt occurs, so the umbrella handler has a different
- -- wrapper generated by the connector routine for each interrupt
- -- number.
-
- if not Handler_Installed (Interrupt) then
- Status :=
- Interrupt_Connect.all (Vec, Handler, System.Address (Interrupt));
- pragma Assert (Status = 0);
-
- Handler_Installed (Interrupt) := True;
- end if;
- end Install_Umbrella_Handler;
-
- ----------------
- -- Is_Blocked --
- ----------------
-
- function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented ("Is_Blocked");
- return False;
- end Is_Blocked;
-
- -----------------------
- -- Is_Entry_Attached --
- -----------------------
-
- function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- Check_Reserved_Interrupt (Interrupt);
- return User_Entry (Interrupt).T /= Null_Task;
- end Is_Entry_Attached;
-
- -------------------------
- -- Is_Handler_Attached --
- -------------------------
-
- function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
- begin
- Check_Reserved_Interrupt (Interrupt);
- return User_Handler (Interrupt).H /= null;
- end Is_Handler_Attached;
-
- ----------------
- -- Is_Ignored --
- ----------------
-
- function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
- begin
- Unimplemented ("Is_Ignored");
- return False;
- end Is_Ignored;
-
- -------------------
- -- Is_Registered --
- -------------------
-
- function Is_Registered (Handler : Parameterless_Handler) return Boolean is
- type Fat_Ptr is record
- Object_Addr : System.Address;
- Handler_Addr : System.Address;
- end record;
-
- function To_Fat_Ptr is new Ada.Unchecked_Conversion
- (Parameterless_Handler, Fat_Ptr);
-
- Ptr : R_Link;
- Fat : Fat_Ptr;
-
- begin
- if Handler = null then
- return True;
- end if;
-
- Fat := To_Fat_Ptr (Handler);
-
- Ptr := Registered_Handler_Head;
- while Ptr /= null loop
- if Ptr.H = Fat.Handler_Addr then
- return True;
- end if;
-
- Ptr := Ptr.Next;
- end loop;
-
- return False;
- end Is_Registered;
-
- -----------------
- -- Is_Reserved --
- -----------------
-
- function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
- use System.Interrupt_Management;
- begin
- return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt));
- end Is_Reserved;
-
- ----------------------
- -- Notify_Interrupt --
- ----------------------
-
- -- Umbrella handler for vectored hardware interrupts (as opposed to signals
- -- and exceptions). As opposed to the signal implementation, this handler
- -- is installed in the vector table when the first Ada handler is attached
- -- to the interrupt. However because VxWorks don't support disconnecting
- -- handlers, this subprogram always test whether or not an Ada handler is
- -- effectively attached.
-
- -- Otherwise, the handler that existed prior to program startup is in the
- -- vector table. This ensures that handlers installed by the BSP are active
- -- unless explicitly replaced in the program text.
-
- -- Each Interrupt_Server_Task has an associated binary semaphore on which
- -- it pends once it's been started. This routine determines The appropriate
- -- semaphore and issues a semGive call, waking the server task. When
- -- a handler is unbound, System.Interrupts.Unbind_Handler issues a
- -- Binary_Semaphore_Flush, and the server task deletes its semaphore
- -- and terminates.
-
- procedure Notify_Interrupt (Param : System.Address) is
- Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
- Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt);
- Status : int;
- begin
- if Id /= 0 then
- Status := Binary_Semaphore_Release (Id);
- pragma Assert (Status = 0);
- end if;
- end Notify_Interrupt;
-
- ---------------
- -- Reference --
- ---------------
-
- function Reference (Interrupt : Interrupt_ID) return System.Address is
- begin
- Check_Reserved_Interrupt (Interrupt);
- return Storage_Elements.To_Address
- (Storage_Elements.Integer_Address (Interrupt));
- end Reference;
-
- --------------------------------
- -- Register_Interrupt_Handler --
- --------------------------------
-
- procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
- New_Node_Ptr : R_Link;
-
- begin
- -- This routine registers a handler as usable for dynamic interrupt
- -- handler association. Routines attaching and detaching handlers
- -- dynamically should determine whether the handler is registered.
- -- Program_Error should be raised if it is not registered.
-
- -- Pragma Interrupt_Handler can only appear in a library level PO
- -- definition and instantiation. Therefore, we do not need to implement
- -- an unregister operation. Nor do we need to protect the queue
- -- structure with a lock.
-
- pragma Assert (Handler_Addr /= System.Null_Address);
-
- New_Node_Ptr := new Registered_Handler;
- New_Node_Ptr.H := Handler_Addr;
-
- if Registered_Handler_Head = null then
- Registered_Handler_Head := New_Node_Ptr;
- Registered_Handler_Tail := New_Node_Ptr;
- else
- Registered_Handler_Tail.Next := New_Node_Ptr;
- Registered_Handler_Tail := New_Node_Ptr;
- end if;
- end Register_Interrupt_Handler;
-
- -----------------------
- -- Unblock_Interrupt --
- -----------------------
-
- procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Unblock_Interrupt");
- end Unblock_Interrupt;
-
- ------------------
- -- Unblocked_By --
- ------------------
-
- function Unblocked_By
- (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
- is
- begin
- Unimplemented ("Unblocked_By");
- return Null_Task;
- end Unblocked_By;
-
- ------------------------
- -- Unignore_Interrupt --
- ------------------------
-
- procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
- begin
- Unimplemented ("Unignore_Interrupt");
- end Unignore_Interrupt;
-
- -------------------
- -- Unimplemented --
- -------------------
-
- procedure Unimplemented (Feature : String) is
- begin
- raise Program_Error with Feature & " not implemented on VxWorks";
- end Unimplemented;
-
- -----------------------
- -- Interrupt_Manager --
- -----------------------
-
- task body Interrupt_Manager is
- -- By making this task independent of any master, when the process goes
- -- away, the Interrupt_Manager will terminate gracefully.
-
- Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
- pragma Unreferenced (Ignore);
-
- --------------------
- -- Local Routines --
- --------------------
-
- procedure Bind_Handler (Interrupt : Interrupt_ID);
- -- This procedure does not do anything if a signal is blocked.
- -- Otherwise, we have to interrupt Server_Task for status change
- -- through a wakeup signal.
-
- procedure Unbind_Handler (Interrupt : Interrupt_ID);
- -- This procedure does not do anything if a signal is blocked.
- -- Otherwise, we have to interrupt Server_Task for status change
- -- through an abort signal.
-
- procedure Unprotected_Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False);
-
- procedure Unprotected_Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean);
-
- ------------------
- -- Bind_Handler --
- ------------------
-
- procedure Bind_Handler (Interrupt : Interrupt_ID) is
- begin
- Install_Umbrella_Handler
- (HW_Interrupt (Interrupt), Notify_Interrupt'Access);
- end Bind_Handler;
-
- --------------------
- -- Unbind_Handler --
- --------------------
-
- procedure Unbind_Handler (Interrupt : Interrupt_ID) is
- Status : int;
-
- begin
- -- Flush server task off semaphore, allowing it to terminate
-
- Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt));
- pragma Assert (Status = 0);
- end Unbind_Handler;
-
- --------------------------------
- -- Unprotected_Detach_Handler --
- --------------------------------
-
- procedure Unprotected_Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean)
- is
- Old_Handler : Parameterless_Handler;
- begin
- if User_Entry (Interrupt).T /= Null_Task then
-
- -- If an interrupt entry is installed raise Program_Error
- -- (propagate it to the caller).
-
- raise Program_Error with
- "an interrupt entry is already installed";
- end if;
-
- -- Note : Static = True will pass the following check. This is the
- -- case when we want to detach a handler regardless of the static
- -- status of the Current_Handler.
-
- if not Static and then User_Handler (Interrupt).Static then
-
- -- Trying to detach a static Interrupt Handler, raise
- -- Program_Error.
-
- raise Program_Error with
- "trying to detach a static Interrupt Handler";
- end if;
-
- Old_Handler := User_Handler (Interrupt).H;
-
- -- The new handler
-
- User_Handler (Interrupt).H := null;
- User_Handler (Interrupt).Static := False;
-
- if Old_Handler /= null then
- Unbind_Handler (Interrupt);
- end if;
- end Unprotected_Detach_Handler;
-
- ----------------------------------
- -- Unprotected_Exchange_Handler --
- ----------------------------------
-
- procedure Unprotected_Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False)
- is
- begin
- if User_Entry (Interrupt).T /= Null_Task then
-
- -- If an interrupt entry is already installed, raise
- -- Program_Error (propagate it to the caller).
-
- raise Program_Error with "an interrupt is already installed";
- end if;
-
- -- Note : A null handler with Static = True will pass the following
- -- check. This is the case when we want to detach a handler
- -- regardless of the Static status of Current_Handler.
-
- -- We don't check anything if Restoration is True, since we may be
- -- detaching a static handler to restore a dynamic one.
-
- if not Restoration and then not Static
- and then (User_Handler (Interrupt).Static
-
- -- Trying to overwrite a static Interrupt Handler with a dynamic
- -- Handler
-
- -- The new handler is not specified as an Interrupt Handler by a
- -- pragma.
-
- or else not Is_Registered (New_Handler))
- then
- raise Program_Error with
- "trying to overwrite a static interrupt handler with a "
- & "dynamic handler";
- end if;
-
- -- Save the old handler
-
- Old_Handler := User_Handler (Interrupt).H;
-
- -- The new handler
-
- User_Handler (Interrupt).H := New_Handler;
-
- if New_Handler = null then
-
- -- The null handler means we are detaching the handler
-
- User_Handler (Interrupt).Static := False;
-
- else
- User_Handler (Interrupt).Static := Static;
- end if;
-
- -- Invoke a corresponding Server_Task if not yet created. Place
- -- Task_Id info in Server_ID array.
-
- if New_Handler /= null
- and then
- (Server_ID (Interrupt) = Null_Task
- or else
- Ada.Task_Identification.Is_Terminated
- (To_Ada (Server_ID (Interrupt))))
- then
- Interrupt_Access_Hold :=
- new Interrupt_Server_Task (Interrupt, Binary_Semaphore_Create);
- Server_ID (Interrupt) :=
- To_System (Interrupt_Access_Hold.all'Identity);
- end if;
-
- if (New_Handler = null) and then Old_Handler /= null then
-
- -- Restore default handler
-
- Unbind_Handler (Interrupt);
-
- elsif Old_Handler = null then
-
- -- Save default handler
-
- Bind_Handler (Interrupt);
- end if;
- end Unprotected_Exchange_Handler;
-
- -- Start of processing for Interrupt_Manager
-
- begin
- loop
- -- A block is needed to absorb Program_Error exception
-
- declare
- Old_Handler : Parameterless_Handler;
-
- begin
- select
- accept Attach_Handler
- (New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean;
- Restoration : Boolean := False)
- do
- Unprotected_Exchange_Handler
- (Old_Handler, New_Handler, Interrupt, Static, Restoration);
- end Attach_Handler;
-
- or
- accept Exchange_Handler
- (Old_Handler : out Parameterless_Handler;
- New_Handler : Parameterless_Handler;
- Interrupt : Interrupt_ID;
- Static : Boolean)
- do
- Unprotected_Exchange_Handler
- (Old_Handler, New_Handler, Interrupt, Static);
- end Exchange_Handler;
-
- or
- accept Detach_Handler
- (Interrupt : Interrupt_ID;
- Static : Boolean)
- do
- Unprotected_Detach_Handler (Interrupt, Static);
- end Detach_Handler;
-
- or
- accept Bind_Interrupt_To_Entry
- (T : Task_Id;
- E : Task_Entry_Index;
- Interrupt : Interrupt_ID)
- do
- -- If there is a binding already (either a procedure or an
- -- entry), raise Program_Error (propagate it to the caller).
-
- if User_Handler (Interrupt).H /= null
- or else User_Entry (Interrupt).T /= Null_Task
- then
- raise Program_Error with
- "a binding for this interrupt is already present";
- end if;
-
- User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
-
- -- Indicate the attachment of interrupt entry in the ATCB.
- -- This is needed so when an interrupt entry task terminates
- -- the binding can be cleaned. The call to unbinding must be
- -- make by the task before it terminates.
-
- T.Interrupt_Entry := True;
-
- -- Invoke a corresponding Server_Task if not yet created.
- -- Place Task_Id info in Server_ID array.
-
- if Server_ID (Interrupt) = Null_Task
- or else
- Ada.Task_Identification.Is_Terminated
- (To_Ada (Server_ID (Interrupt)))
- then
- Interrupt_Access_Hold := new Interrupt_Server_Task
- (Interrupt, Binary_Semaphore_Create);
- Server_ID (Interrupt) :=
- To_System (Interrupt_Access_Hold.all'Identity);
- end if;
-
- Bind_Handler (Interrupt);
- end Bind_Interrupt_To_Entry;
-
- or
- accept Detach_Interrupt_Entries (T : Task_Id) do
- for Int in Interrupt_ID'Range loop
- if not Is_Reserved (Int) then
- if User_Entry (Int).T = T then
- User_Entry (Int) :=
- Entry_Assoc'
- (T => Null_Task, E => Null_Task_Entry);
- Unbind_Handler (Int);
- end if;
- end if;
- end loop;
-
- -- Indicate in ATCB that no interrupt entries are attached
-
- T.Interrupt_Entry := False;
- end Detach_Interrupt_Entries;
- end select;
-
- exception
- -- If there is a Program_Error we just want to propagate it to
- -- the caller and do not want to stop this task.
-
- when Program_Error =>
- null;
-
- when others =>
- pragma Assert (False);
- null;
- end;
- end loop;
-
- exception
- when Standard'Abort_Signal =>
-
- -- Flush interrupt server semaphores, so they can terminate
-
- Finalize_Interrupt_Servers;
- raise;
- end Interrupt_Manager;
-
- ---------------------------
- -- Interrupt_Server_Task --
- ---------------------------
-
- -- Server task for vectored hardware interrupt handling
-
- task body Interrupt_Server_Task is
- Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
-
- Self_Id : constant Task_Id := Self;
- Tmp_Handler : Parameterless_Handler;
- Tmp_ID : Task_Id;
- Tmp_Entry_Index : Task_Entry_Index;
- Status : int;
-
- begin
- Semaphore_ID_Map (Interrupt) := Int_Sema;
-
- loop
- -- Pend on semaphore that will be triggered by the umbrella handler
- -- when the associated interrupt comes in.
-
- Status := Binary_Semaphore_Obtain (Int_Sema);
- pragma Assert (Status = 0);
-
- if User_Handler (Interrupt).H /= null then
-
- -- Protected procedure handler
-
- Tmp_Handler := User_Handler (Interrupt).H;
- Tmp_Handler.all;
-
- elsif User_Entry (Interrupt).T /= Null_Task then
-
- -- Interrupt entry handler
-
- Tmp_ID := User_Entry (Interrupt).T;
- Tmp_Entry_Index := User_Entry (Interrupt).E;
- System.Tasking.Rendezvous.Call_Simple
- (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
-
- else
- -- Semaphore has been flushed by an unbind operation in the
- -- Interrupt_Manager. Terminate the server task.
-
- -- Wait for the Interrupt_Manager to complete its work
-
- POP.Write_Lock (Self_Id);
-
- -- Unassociate the interrupt handler
-
- Semaphore_ID_Map (Interrupt) := 0;
-
- -- Delete the associated semaphore
-
- Status := Binary_Semaphore_Delete (Int_Sema);
-
- pragma Assert (Status = 0);
-
- -- Set status for the Interrupt_Manager
-
- Server_ID (Interrupt) := Null_Task;
- POP.Unlock (Self_Id);
-
- exit;
- end if;
- end loop;
- end Interrupt_Server_Task;
-
-begin
- -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
-
- Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
-end System.Interrupts;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T S --
--- --
--- B o d y --
--- --
--- Copyright (C) 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Invariants:
-
--- All user-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
--- --
--- B o d y --
--- --
--- Copyright (C) 2014-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
--- --
--- B o d y --
--- --
--- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a NO tasking version of this package
-
-package body System.Interrupt_Management is
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- null;
- end Initialize;
-
-end System.Interrupt_Management;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-2009, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the NT version of this package
-
-with System.OS_Interface; use System.OS_Interface;
-
-package body System.Interrupt_Management is
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- -- "Reserve" all the interrupts, except those that are explicitly
- -- defined.
-
- for J in Interrupt_ID'Range loop
- Reserve (J) := True;
- end loop;
-
- Reserve (SIGINT) := False;
- Reserve (SIGILL) := False;
- Reserve (SIGABRT) := False;
- Reserve (SIGFPE) := False;
- Reserve (SIGSEGV) := False;
- Reserve (SIGTERM) := False;
- end Initialize;
-
-end System.Interrupt_Management;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the POSIX threads version of this package
-
--- Make a careful study of all signals available under the OS, to see which
--- need to be reserved, kept always unmasked, or kept always unmasked. Be on
--- the lookout for special signals that may be used by the thread library.
-
--- Since this is a multi target file, the signal <-> exception mapping
--- is simple minded. If you need a more precise and target specific
--- signal handling, create a new s-intman.adb that will fit your needs.
-
--- This file assumes that:
-
--- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows:
--- SIGPFE => Constraint_Error
--- SIGILL => Program_Error
--- SIGSEGV => Storage_Error
--- SIGBUS => Storage_Error
-
--- SIGINT exists and will be kept unmasked unless the pragma
--- Unreserve_All_Interrupts is specified anywhere in the application.
-
--- System.OS_Interface contains the following:
--- SIGADAABORT: the signal that will be used to abort tasks.
--- Unmasked: the OS specific set of signals that should be unmasked in
--- all the threads. SIGADAABORT is unmasked by
--- default
--- Reserved: the OS specific set of signals that are reserved.
-
-with System.Task_Primitives;
-
-package body System.Interrupt_Management is
-
- use Interfaces.C;
- use System.OS_Interface;
-
- type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
- Exception_Interrupts : constant Interrupt_List :=
- (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
-
- Unreserve_All_Interrupts : Interfaces.C.int;
- pragma Import
- (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function State (Int : Interrupt_ID) return Character;
- pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in init.c The input argument is the
- -- interrupt number, and the result is one of the following:
-
- User : constant Character := 'u';
- Runtime : constant Character := 'r';
- Default : constant Character := 's';
- -- 'n' this interrupt not set by any Interrupt_State pragma
- -- 'u' Interrupt_State pragma set state to User
- -- 'r' Interrupt_State pragma set state to Runtime
- -- 's' Interrupt_State pragma set state to System (use "default"
- -- system handler)
-
- procedure Notify_Exception
- (signo : Signal;
- siginfo : System.Address;
- ucontext : System.Address);
- -- This function identifies the Ada exception to be raised using the
- -- information when the system received a synchronous signal. Since this
- -- function is machine and OS dependent, different code has to be provided
- -- for different target.
-
- ----------------------
- -- Notify_Exception --
- ----------------------
-
- Signal_Mask : aliased sigset_t;
- -- The set of signals handled by Notify_Exception
-
- procedure Notify_Exception
- (signo : Signal;
- siginfo : System.Address;
- ucontext : System.Address)
- is
- pragma Unreferenced (siginfo);
-
- Result : Interfaces.C.int;
-
- begin
- -- With the __builtin_longjmp, the signal mask is not restored, so we
- -- need to restore it explicitly.
-
- Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
- pragma Assert (Result = 0);
-
- -- Perform the necessary context adjustments prior to a raise
- -- from a signal handler.
-
- Adjust_Context_For_Raise (signo, ucontext);
-
- -- Check that treatment of exception propagation here is consistent with
- -- treatment of the abort signal in System.Task_Primitives.Operations.
-
- case signo is
- when SIGFPE => raise Constraint_Error;
- when SIGILL => raise Program_Error;
- when SIGSEGV => raise Storage_Error;
- when SIGBUS => raise Storage_Error;
- when others => null;
- end case;
- end Notify_Exception;
-
- ----------------
- -- Initialize --
- ----------------
-
- Initialized : Boolean := False;
-
- procedure Initialize is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Result : System.OS_Interface.int;
-
- Use_Alternate_Stack : constant Boolean :=
- System.Task_Primitives.Alternate_Stack_Size /= 0;
- -- Whether to use an alternate signal stack for stack overflows
-
- begin
- if Initialized then
- return;
- end if;
-
- Initialized := True;
-
- -- Need to call pthread_init very early because it is doing signal
- -- initializations.
-
- pthread_init;
-
- Abort_Task_Interrupt := SIGADAABORT;
-
- act.sa_handler := Notify_Exception'Address;
-
- -- Setting SA_SIGINFO asks the kernel to pass more than just the signal
- -- number argument to the handler when it is called. The set of extra
- -- parameters includes a pointer to the interrupted context, which the
- -- ZCX propagation scheme needs.
-
- -- Most man pages for sigaction mention that sa_sigaction should be set
- -- instead of sa_handler when SA_SIGINFO is on. In practice, the two
- -- fields are actually union'ed and located at the same offset.
-
- -- On some targets, we set sa_flags to SA_NODEFER so that during the
- -- handler execution we do not change the Signal_Mask to be masked for
- -- the Signal.
-
- -- This is a temporary fix to the problem that the Signal_Mask is not
- -- restored after the exception (longjmp) from the handler. The right
- -- fix should be made in sigsetjmp so that we save the Signal_Set and
- -- restore it after a longjmp.
-
- -- Since SA_NODEFER is obsolete, instead we reset explicitly the mask
- -- in the exception handler.
-
- Result := sigemptyset (Signal_Mask'Access);
- pragma Assert (Result = 0);
-
- -- Add signals that map to Ada exceptions to the mask
-
- for J in Exception_Interrupts'Range loop
- if State (Exception_Interrupts (J)) /= Default then
- Result :=
- sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
- pragma Assert (Result = 0);
- end if;
- end loop;
-
- act.sa_mask := Signal_Mask;
-
- pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
- pragma Assert (Reserve = (Interrupt_ID'Range => False));
-
- -- Process state of exception signals
-
- for J in Exception_Interrupts'Range loop
- if State (Exception_Interrupts (J)) /= User then
- Keep_Unmasked (Exception_Interrupts (J)) := True;
- Reserve (Exception_Interrupts (J)) := True;
-
- if State (Exception_Interrupts (J)) /= Default then
- act.sa_flags := SA_SIGINFO;
-
- if Use_Alternate_Stack
- and then Exception_Interrupts (J) = SIGSEGV
- then
- act.sa_flags := act.sa_flags + SA_ONSTACK;
- end if;
-
- Result :=
- sigaction
- (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
- end if;
- end if;
- end loop;
-
- if State (Abort_Task_Interrupt) /= User then
- Keep_Unmasked (Abort_Task_Interrupt) := True;
- Reserve (Abort_Task_Interrupt) := True;
- end if;
-
- -- Set SIGINT to unmasked state as long as it is not in "User" state.
- -- Check for Unreserve_All_Interrupts last.
-
- if State (SIGINT) /= User then
- Keep_Unmasked (SIGINT) := True;
- Reserve (SIGINT) := True;
- end if;
-
- -- Check all signals for state that requires keeping them unmasked and
- -- reserved.
-
- for J in Interrupt_ID'Range loop
- if State (J) = Default or else State (J) = Runtime then
- Keep_Unmasked (J) := True;
- Reserve (J) := True;
- end if;
- end loop;
-
- -- Add the set of signals that must always be unmasked for this target
-
- for J in Unmasked'Range loop
- Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
- Reserve (Interrupt_ID (Unmasked (J))) := True;
- end loop;
-
- -- Add target-specific reserved signals
-
- for J in Reserved'Range loop
- Reserve (Interrupt_ID (Reserved (J))) := True;
- end loop;
-
- -- Process pragma Unreserve_All_Interrupts. This overrides any settings
- -- due to pragma Interrupt_State:
-
- if Unreserve_All_Interrupts /= 0 then
- Keep_Unmasked (SIGINT) := False;
- Reserve (SIGINT) := False;
- end if;
-
- -- We do not really have Signal 0. We just use this value to identify
- -- non-existent signals (see s-intnam.ads). Therefore, Signal should not
- -- be used in all signal related operations hence mark it as reserved.
-
- Reserve (0) := True;
- end Initialize;
-
-end System.Interrupt_Management;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a Solaris version of this package
-
--- Make a careful study of all signals available under the OS, to see which
--- need to be reserved, kept always unmasked, or kept always unmasked.
-
--- Be on the lookout for special signals that may be used by the thread
--- library.
-
-package body System.Interrupt_Management is
-
- use Interfaces.C;
- use System.OS_Interface;
-
- type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
-
- Exception_Interrupts : constant Interrupt_List :=
- (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
-
- Unreserve_All_Interrupts : Interfaces.C.int;
- pragma Import
- (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
-
- function State (Int : Interrupt_ID) return Character;
- pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in init.c
- -- The input argument is the interrupt number,
- -- and the result is one of the following:
-
- User : constant Character := 'u';
- Runtime : constant Character := 'r';
- Default : constant Character := 's';
- -- 'n' this interrupt not set by any Interrupt_State pragma
- -- 'u' Interrupt_State pragma set state to User
- -- 'r' Interrupt_State pragma set state to Runtime
- -- 's' Interrupt_State pragma set state to System (use "default"
- -- system handler)
-
- ----------------------
- -- Notify_Exception --
- ----------------------
-
- -- This function identifies the Ada exception to be raised using the
- -- information when the system received a synchronous signal. Since this
- -- function is machine and OS dependent, different code has to be provided
- -- for different target.
-
- procedure Notify_Exception
- (signo : Signal;
- info : access siginfo_t;
- context : access ucontext_t);
-
- ----------------------
- -- Notify_Exception --
- ----------------------
-
- procedure Notify_Exception
- (signo : Signal;
- info : access siginfo_t;
- context : access ucontext_t)
- is
- pragma Unreferenced (info);
-
- begin
- -- Perform the necessary context adjustments prior to a raise from a
- -- signal handler.
-
- Adjust_Context_For_Raise (signo, context.all'Address);
-
- -- Check that treatment of exception propagation here is consistent with
- -- treatment of the abort signal in System.Task_Primitives.Operations.
-
- case signo is
- when SIGFPE => raise Constraint_Error;
- when SIGILL => raise Program_Error;
- when SIGSEGV => raise Storage_Error;
- when SIGBUS => raise Storage_Error;
- when others => null;
- end case;
- end Notify_Exception;
-
- ----------------
- -- Initialize --
- ----------------
-
- Initialized : Boolean := False;
-
- procedure Initialize is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- mask : aliased sigset_t;
- Result : Interfaces.C.int;
-
- begin
- if Initialized then
- return;
- end if;
-
- Initialized := True;
-
- -- Need to call pthread_init very early because it is doing signal
- -- initializations.
-
- pthread_init;
-
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- Abort_Task_Interrupt := SIGABRT;
-
- act.sa_handler := Notify_Exception'Address;
-
- -- Set sa_flags to SA_NODEFER so that during the handler execution
- -- we do not change the Signal_Mask to be masked for the Signal.
- -- This is a temporary fix to the problem that the Signal_Mask is
- -- not restored after the exception (longjmp) from the handler.
- -- The right fix should be made in sigsetjmp so that we save
- -- the Signal_Set and restore it after a longjmp.
-
- -- In that case, this field should be changed back to 0. ??? (Dong-Ik)
-
- act.sa_flags := 16;
-
- Result := sigemptyset (mask'Access);
- pragma Assert (Result = 0);
-
- -- ??? For the same reason explained above, we can't mask these signals
- -- because otherwise we won't be able to catch more than one signal.
-
- act.sa_mask := mask;
-
- pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
- pragma Assert (Reserve = (Interrupt_ID'Range => False));
-
- for J in Exception_Interrupts'Range loop
- if State (Exception_Interrupts (J)) /= User then
- Keep_Unmasked (Exception_Interrupts (J)) := True;
- Reserve (Exception_Interrupts (J)) := True;
-
- if State (Exception_Interrupts (J)) /= Default then
- Result :=
- sigaction
- (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
- end if;
- end if;
- end loop;
-
- if State (Abort_Task_Interrupt) /= User then
- Keep_Unmasked (Abort_Task_Interrupt) := True;
- Reserve (Abort_Task_Interrupt) := True;
- end if;
-
- -- Set SIGINT to unmasked state as long as it's
- -- not in "User" state. Check for Unreserve_All_Interrupts last
-
- if State (SIGINT) /= User then
- Keep_Unmasked (SIGINT) := True;
- Reserve (SIGINT) := True;
- end if;
-
- -- Check all signals for state that requires keeping them
- -- unmasked and reserved
-
- for J in Interrupt_ID'Range loop
- if State (J) = Default or else State (J) = Runtime then
- Keep_Unmasked (J) := True;
- Reserve (J) := True;
- end if;
- end loop;
-
- -- Add the set of signals that must always be unmasked for this target
-
- for J in Unmasked'Range loop
- Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
- Reserve (Interrupt_ID (Unmasked (J))) := True;
- end loop;
-
- -- Add target-specific reserved signals
-
- for J in Reserved'Range loop
- Reserve (Interrupt_ID (Reserved (J))) := True;
- end loop;
-
- -- Process pragma Unreserve_All_Interrupts. This overrides any
- -- settings due to pragma Interrupt_State:
-
- if Unreserve_All_Interrupts /= 0 then
- Keep_Unmasked (SIGINT) := False;
- Reserve (SIGINT) := False;
- end if;
-
- -- We do not have Signal 0 in reality. We just use this value to
- -- identify not existing signals (see s-intnam.ads). Therefore, Signal 0
- -- should not be used in all signal related operations hence mark it as
- -- reserved.
-
- Reserve (0) := True;
- end Initialize;
-
-end System.Interrupt_Management;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the SuSV3 threads version of this package
-
--- Make a careful study of all signals available under the OS, to see which
--- need to be reserved, kept always unmasked, or kept always unmasked. Be on
--- the lookout for special signals that may be used by the thread library.
-
--- Since this is a multi target file, the signal <-> exception mapping
--- is simple minded. If you need a more precise and target specific
--- signal handling, create a new s-intman.adb that will fit your needs.
-
--- This file assumes that:
-
--- SIGINT exists and will be kept unmasked unless the pragma
--- Unreserve_All_Interrupts is specified anywhere in the application.
-
--- System.OS_Interface contains the following:
--- SIGADAABORT: the signal that will be used to abort tasks.
--- Unmasked: the OS specific set of signals that should be unmasked in
--- all the threads. SIGADAABORT is unmasked by
--- default
--- Reserved: the OS specific set of signals that are reserved.
-
-package body System.Interrupt_Management is
-
- use Interfaces.C;
- use System.OS_Interface;
-
- Unreserve_All_Interrupts : Interfaces.C.int;
- pragma Import
- (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function State (Int : Interrupt_ID) return Character;
- pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in init.c The input argument is the
- -- interrupt number, and the result is one of the following:
-
- User : constant Character := 'u';
- Runtime : constant Character := 'r';
- Default : constant Character := 's';
- -- 'n' this interrupt not set by any Interrupt_State pragma
- -- 'u' Interrupt_State pragma set state to User
- -- 'r' Interrupt_State pragma set state to Runtime
- -- 's' Interrupt_State pragma set state to System (use "default"
- -- system handler)
-
- ----------------
- -- Initialize --
- ----------------
-
- Initialized : Boolean := False;
-
- procedure Initialize is
- begin
- if Initialized then
- return;
- end if;
-
- Initialized := True;
-
- -- Need to call pthread_init very early because it is doing signal
- -- initializations.
-
- pthread_init;
-
- Abort_Task_Interrupt := SIGADAABORT;
-
- pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
- pragma Assert (Reserve = (Interrupt_ID'Range => False));
-
- -- Process state of exception signals
-
- for J in Exception_Signals'Range loop
- declare
- Sig : constant Signal := Exception_Signals (J);
- Id : constant Interrupt_ID := Interrupt_ID (Sig);
- begin
- if State (Id) /= User then
- Keep_Unmasked (Id) := True;
- Reserve (Id) := True;
- end if;
- end;
- end loop;
-
- if State (Abort_Task_Interrupt) /= User then
- Keep_Unmasked (Abort_Task_Interrupt) := True;
- Reserve (Abort_Task_Interrupt) := True;
- end if;
-
- -- Set SIGINT to unmasked state as long as it is not in "User" state.
- -- Check for Unreserve_All_Interrupts last.
-
- if State (SIGINT) /= User then
- Keep_Unmasked (SIGINT) := True;
- Reserve (SIGINT) := True;
- end if;
-
- -- Check all signals for state that requires keeping them unmasked and
- -- reserved.
-
- for J in Interrupt_ID'Range loop
- if State (J) = Default or else State (J) = Runtime then
- Keep_Unmasked (J) := True;
- Reserve (J) := True;
- end if;
- end loop;
-
- -- Add the set of signals that must always be unmasked for this target
-
- for J in Unmasked'Range loop
- Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
- Reserve (Interrupt_ID (Unmasked (J))) := True;
- end loop;
-
- -- Add target-specific reserved signals
-
- for J in Reserved'Range loop
- Reserve (Interrupt_ID (Reserved (J))) := True;
- end loop;
-
- -- Process pragma Unreserve_All_Interrupts. This overrides any settings
- -- due to pragma Interrupt_State:
-
- if Unreserve_All_Interrupts /= 0 then
- Keep_Unmasked (SIGINT) := False;
- Reserve (SIGINT) := False;
- end if;
-
- -- We do not really have Signal 0. We just use this value to identify
- -- non-existent signals (see s-intnam.ads). Therefore, Signal should not
- -- be used in all signal related operations hence mark it as reserved.
-
- Reserve (0) := True;
- end Initialize;
-
-end System.Interrupt_Management;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the VxWorks version of this package
-
--- It is simpler than other versions because the Ada interrupt handling
--- mechanisms are used for hardware interrupts rather than signals.
-
-package body System.Interrupt_Management is
-
- use System.OS_Interface;
- use type Interfaces.C.int;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function State (Int : Interrupt_ID) return Character;
- pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in init.c The input argument is the
- -- hardware interrupt number, and the result is one of the following:
-
- Runtime : constant Character := 'r';
- Default : constant Character := 's';
- -- 'n' this interrupt not set by any Interrupt_State pragma
- -- 'u' Interrupt_State pragma set state to User
- -- 'r' Interrupt_State pragma set state to Runtime
- -- 's' Interrupt_State pragma set state to System (use "default"
- -- system handler)
-
- ----------------
- -- Initialize --
- ----------------
-
- Initialized : Boolean := False;
- -- Set to True once Initialize is called, further calls have no effect
-
- procedure Initialize is
-
- begin
- if Initialized then
- return;
- end if;
-
- Initialized := True;
-
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- Abort_Task_Interrupt := SIGABRT;
-
- -- Initialize hardware interrupt handling
-
- pragma Assert (Reserve = (Interrupt_ID'Range => False));
-
- -- Check all interrupts for state that requires keeping them reserved
-
- for J in Interrupt_ID'Range loop
- if State (J) = Default or else State (J) = Runtime then
- Reserve (J) := True;
- end if;
- end loop;
-
- end Initialize;
-
-end System.Interrupt_Management;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the VxWorks version of this package
-
--- This package encapsulates and centralizes information about all
--- uses of interrupts (or signals), including the target-dependent
--- mapping of interrupts (or signals) to exceptions.
-
--- Unlike the original design, System.Interrupt_Management can only
--- be used for tasking systems.
-
--- PLEASE DO NOT put any subprogram declarations with arguments of
--- type Interrupt_ID into the visible part of this package. The type
--- Interrupt_ID is used to derive the type in Ada.Interrupts, and
--- adding more operations to that type would be illegal according
--- to the Ada Reference Manual. This is the reason why the signals
--- sets are implemented using visible arrays rather than functions.
-
-with System.OS_Interface;
-
-with Interfaces.C;
-
-package System.Interrupt_Management is
- pragma Preelaborate;
-
- type Interrupt_Mask is limited private;
-
- type Interrupt_ID is new Interfaces.C.int
- range 0 .. System.OS_Interface.Max_Interrupt;
-
- type Interrupt_Set is array (Interrupt_ID) of Boolean;
-
- subtype Signal_ID is Interrupt_ID range 0 .. System.OS_Interface.NSIG - 1;
-
- type Signal_Set is array (Signal_ID) of Boolean;
-
- -- The following objects serve as constants, but are initialized in the
- -- body to aid portability. This permits us to use more portable names for
- -- interrupts, where distinct names may map to the same interrupt ID
- -- value.
-
- -- For example, suppose SIGRARE is a signal that is not defined on all
- -- systems, but is always reserved when it is defined. If we have the
- -- convention that ID zero is not used for any "real" signals, and SIGRARE
- -- = 0 when SIGRARE is not one of the locally supported signals, we can
- -- write:
- -- Reserved (SIGRARE) := True;
- -- and the initialization code will be portable.
-
- Abort_Task_Interrupt : Signal_ID;
- -- The signal that is used to implement task abort if an interrupt is used
- -- for that purpose. This is one of the reserved signals.
-
- Reserve : Interrupt_Set := (others => False);
- -- Reserve (I) is true iff the interrupt I is one that cannot be permitted
- -- to be attached to a user handler. The possible reasons are many. For
- -- example, it may be mapped to an exception used to implement task abort,
- -- or used to implement time delays.
-
- procedure Initialize_Interrupts;
- pragma Import (C, Initialize_Interrupts, "__gnat_install_handler");
- -- Under VxWorks, there is no signal inheritance between tasks.
- -- This procedure is used to initialize signal-to-exception mapping in
- -- each task.
-
- procedure Initialize;
- -- Initialize the various variables defined in this package. This procedure
- -- must be called before accessing any object from this package and can be
- -- called multiple times (only the first call has any effect).
-
-private
- type Interrupt_Mask is new System.OS_Interface.sigset_t;
- -- In some implementation Interrupt_Mask can be represented as a linked
- -- list.
-
-end System.Interrupt_Management;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . L I N U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 2009-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- --
-------------------------------------------------------------------------------
-
--- This is the alpha version of this package
-
--- This package encapsulates cpu specific differences between implementations
--- of GNU/Linux, in order to share s-osinte-linux.ads.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-
-package System.Linux is
- pragma Preelaborate;
-
- ----------
- -- Time --
- ----------
-
- subtype long is Interfaces.C.long;
- subtype suseconds_t is Interfaces.C.long;
- subtype time_t is Interfaces.C.long;
- subtype clockid_t is Interfaces.C.int;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type timeval is record
- tv_sec : time_t;
- tv_usec : suseconds_t;
- end record;
- pragma Convention (C, timeval);
-
- -----------
- -- Errno --
- -----------
-
- EAGAIN : constant := 35;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- EPERM : constant := 1;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O now possible (4.2 BSD)
- SIGPOLL : constant := 23; -- pollable event occurred
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGPWR : constant := 29; -- power-fail restart
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- SIGUNUSED : constant := 0;
- SIGSTKFLT : constant := 0;
- SIGLOST : constant := 0;
- -- These don't exist for Linux/Alpha. The constants are present
- -- so that we can continue to use a-intnam-linux.ads.
-
- -- struct_sigaction offsets
-
- sa_handler_pos : constant := 0;
- sa_mask_pos : constant := Standard'Address_Size / 8;
- sa_flags_pos : constant := 128 + sa_mask_pos;
-
- SA_SIGINFO : constant := 16#40#;
- SA_ONSTACK : constant := 16#01#;
-
-end System.Linux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . L I N U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- In particular, you can freely distribute your programs built with the --
--- GNAT Pro compiler, including any required library run-time units, using --
--- any licensing terms of your choosing. See the AdaCore Software License --
--- for full details. --
--- --
--- --
-------------------------------------------------------------------------------
-
--- This is the Android version of this package
-
--- This package encapsulates cpu specific differences between implementations
--- of GNU/Linux, in order to share s-osinte-linux.ads.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package
-
-with Interfaces.C;
-
-package System.Linux is
- pragma Preelaborate;
-
- ----------
- -- Time --
- ----------
-
- subtype long is Interfaces.C.long;
- subtype suseconds_t is Interfaces.C.long;
- subtype time_t is Interfaces.C.long;
- subtype clockid_t is Interfaces.C.int;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type timeval is record
- tv_sec : time_t;
- tv_usec : suseconds_t;
- end record;
- pragma Convention (C, timeval);
-
- -----------
- -- Errno --
- -----------
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- EPERM : constant := 1;
- ETIMEDOUT : constant := 110;
-
- -------------
- -- Signals --
- -------------
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 7; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 10; -- user defined signal 1
- SIGUSR2 : constant := 12; -- user defined signal 2
- SIGCLD : constant := 17; -- alias for SIGCHLD
- SIGCHLD : constant := 17; -- child status change
- SIGPWR : constant := 30; -- power-fail restart
- SIGWINCH : constant := 28; -- window size change
- SIGURG : constant := 23; -- urgent condition on IO channel
- SIGPOLL : constant := 29; -- pollable event occurred
- SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
- SIGLOST : constant := 29; -- File lock lost
- SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 20; -- user stop requested from tty
- SIGCONT : constant := 18; -- stopped process has been continued
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
- SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
-
- -- struct_sigaction offsets
-
- sa_handler_pos : constant := 0;
- sa_mask_pos : constant := Standard'Address_Size / 8;
- sa_flags_pos : constant := 4 + sa_mask_pos;
-
- SA_SIGINFO : constant := 16#00000004#;
- SA_ONSTACK : constant := 16#08000000#;
- SA_RESTART : constant := 16#10000000#;
- SA_NODEFER : constant := 16#40000000#;
-
-end System.Linux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . L I N U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 2008-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- --
-------------------------------------------------------------------------------
-
--- This is the hppa version of this package
-
--- This package encapsulates cpu specific differences between implementations
--- of GNU/Linux, in order to share s-osinte-linux.ads.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-
-package System.Linux is
- pragma Preelaborate;
-
- ----------
- -- Time --
- ----------
-
- subtype long is Interfaces.C.long;
- subtype suseconds_t is Interfaces.C.long;
- subtype time_t is Interfaces.C.long;
- subtype clockid_t is Interfaces.C.int;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type timeval is record
- tv_sec : time_t;
- tv_usec : suseconds_t;
- end record;
- pragma Convention (C, timeval);
-
- -----------
- -- Errno --
- -----------
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- EPERM : constant := 1;
- ETIMEDOUT : constant := 238;
-
- -------------
- -- Signals --
- -------------
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
- SIGCLD : constant := 18; -- alias for SIGCHLD
- SIGCHLD : constant := 18; -- child status change
- SIGPWR : constant := 19; -- power-fail restart
- SIGVTALRM : constant := 20; -- virtual timer expired
- SIGPROF : constant := 21; -- profiling timer expired
- SIGPOLL : constant := 22; -- pollable event occurred
- SIGIO : constant := 22; -- I/O now possible (4.2 BSD)
- SIGWINCH : constant := 23; -- window size change
- SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 25; -- user stop requested from tty
- SIGCONT : constant := 26; -- stopped process has been continued
- SIGTTIN : constant := 27; -- background tty read attempted
- SIGTTOU : constant := 28; -- background tty write attempted
- SIGURG : constant := 29; -- urgent condition on IO channel
- SIGLOST : constant := 30; -- File lock lost
- SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
- SIGXCPU : constant := 33; -- CPU time limit exceeded
- SIGXFSZ : constant := 34; -- filesize limit exceeded
- SIGSTKFLT : constant := 36; -- coprocessor stack fault (Linux)
- SIGLTHRRES : constant := 37; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 38; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 39; -- GNU/LinuxThreads debugger signal
-
- -- struct_sigaction offsets
-
- sa_handler_pos : constant := 0;
- sa_flags_pos : constant := Standard'Address_Size / 8;
- sa_mask_pos : constant := sa_flags_pos * 2;
-
- SA_SIGINFO : constant := 16#10#;
- SA_ONSTACK : constant := 16#01#;
-
-end System.Linux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . L I N U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 2009-2017, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- This is the MIPS version of this package
-
--- This package encapsulates cpu specific differences between implementations
--- of GNU/Linux, in order to share s-osinte-linux.ads.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package
-
-with Interfaces.C;
-
-package System.Linux is
- pragma Preelaborate;
-
- ----------
- -- Time --
- ----------
-
- subtype int is Interfaces.C.int;
- subtype long is Interfaces.C.long;
- subtype suseconds_t is Interfaces.C.long;
- subtype time_t is Interfaces.C.long;
- subtype clockid_t is Interfaces.C.int;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type timeval is record
- tv_sec : time_t;
- tv_usec : suseconds_t;
- end record;
- pragma Convention (C, timeval);
-
- -----------
- -- Errno --
- -----------
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- EPERM : constant := 1;
- ETIMEDOUT : constant := 145;
-
- -------------
- -- Signals --
- -------------
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
- SIGCLD : constant := 18; -- alias for SIGCHLD
- SIGCHLD : constant := 18; -- child status change
- SIGPWR : constant := 19; -- power-fail restart
- SIGWINCH : constant := 20; -- window size change
- SIGURG : constant := 21; -- urgent condition on IO channel
- SIGPOLL : constant := 22; -- pollable event occurred
- SIGIO : constant := 22; -- I/O now possible (4.2 BSD)
- SIGSTOP : constant := 23; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 24; -- user stop requested from tty
- SIGCONT : constant := 25; -- stopped process has been continued
- SIGTTIN : constant := 26; -- background tty read attempted
- SIGTTOU : constant := 27; -- background tty write attempted
- SIGVTALRM : constant := 28; -- virtual timer expired
- SIGPROF : constant := 29; -- profiling timer expired
- SIGXCPU : constant := 30; -- CPU time limit exceeded
- SIGXFSZ : constant := 31; -- filesize limit exceeded
-
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
-
- -- These don't exist for Linux/MIPS. The constants are present
- -- so that we can continue to use a-intnam-linux.ads.
- SIGLOST : constant := 0; -- File lock lost
- SIGSTKFLT : constant := 0; -- coprocessor stack fault (Linux)
- SIGUNUSED : constant := 0; -- unused signal (GNU/Linux)
-
- -- struct_sigaction offsets
-
- sa_handler_pos : constant := int'Size / 8;
- sa_mask_pos : constant := int'Size / 8 +
- Standard'Address_Size / 8;
- sa_flags_pos : constant := 0;
-
- SA_SIGINFO : constant := 16#08#;
- SA_ONSTACK : constant := 16#08000000#;
-
-end System.Linux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . L I N U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 2009-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- --
-------------------------------------------------------------------------------
-
--- This is the SPARC version of this package
-
--- This package encapsulates cpu specific differences between implementations
--- of GNU/Linux, in order to share s-osinte-linux.ads.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package
-
-with Interfaces.C;
-
-package System.Linux is
- pragma Preelaborate;
-
- ----------
- -- Time --
- ----------
-
- subtype long is Interfaces.C.long;
- subtype suseconds_t is Interfaces.C.long;
- subtype time_t is Interfaces.C.long;
- subtype clockid_t is Interfaces.C.int;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type timeval is record
- tv_sec : time_t;
- tv_usec : suseconds_t;
- end record;
- pragma Convention (C, timeval);
-
- -----------
- -- Errno --
- -----------
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- EPERM : constant := 1;
- ETIMEDOUT : constant := 110;
-
- -------------
- -- Signals --
- -------------
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGIOT : constant := 6; -- IOT instruction
- SIGEMT : constant := 7; -- EMT
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCHLD : constant := 20; -- child status change
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O now possible (4.2 BSD)
- SIGPOLL : constant := 23; -- pollable event occurred
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGLOST : constant := 29; -- File lock lost
- SIGPWR : constant := 29; -- power-fail restart
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
-
- SIGUNUSED : constant := 0;
- SIGSTKFLT : constant := 0;
- -- These don't exist for Linux/SPARC. The constants are present
- -- so that we can continue to use a-intnam-linux.ads.
-
- -- struct_sigaction offsets
-
- sa_handler_pos : constant := 0;
- sa_mask_pos : constant := Standard'Address_Size / 8;
- sa_flags_pos : constant := 128 + sa_mask_pos;
-
- SA_SIGINFO : constant := 16#200#;
- SA_ONSTACK : constant := 16#001#;
-
-end System.Linux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . L I N U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 2013-2014, Free Software Foundation, Inc. --
---
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- --
-------------------------------------------------------------------------------
-
--- This is the x32 version of this package
-
--- This package encapsulates cpu specific differences between implementations
--- of GNU/Linux, in order to share s-osinte-linux.ads.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package
-
-with Interfaces.C;
-
-package System.Linux is
- pragma Preelaborate;
-
- ----------
- -- Time --
- ----------
-
- type time_t is new Long_Long_Integer;
- subtype clockid_t is Interfaces.C.int;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : Long_Long_Integer;
- end record;
- pragma Convention (C, timespec);
-
- type timeval is record
- tv_sec : time_t;
- tv_usec : Long_Long_Integer;
- end record;
- pragma Convention (C, timeval);
-
- -----------
- -- Errno --
- -----------
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- EPERM : constant := 1;
- ETIMEDOUT : constant := 110;
-
- -------------
- -- Signals --
- -------------
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 7; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 10; -- user defined signal 1
- SIGUSR2 : constant := 12; -- user defined signal 2
- SIGCLD : constant := 17; -- alias for SIGCHLD
- SIGCHLD : constant := 17; -- child status change
- SIGPWR : constant := 30; -- power-fail restart
- SIGWINCH : constant := 28; -- window size change
- SIGURG : constant := 23; -- urgent condition on IO channel
- SIGPOLL : constant := 29; -- pollable event occurred
- SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
- SIGLOST : constant := 29; -- File lock lost
- SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 20; -- user stop requested from tty
- SIGCONT : constant := 18; -- stopped process has been continued
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
- SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
-
- -- struct_sigaction offsets
-
- sa_handler_pos : constant := 0;
- sa_mask_pos : constant := Standard'Address_Size / 8;
- sa_flags_pos : constant := 128 + sa_mask_pos;
-
- SA_SIGINFO : constant := 16#04#;
- SA_ONSTACK : constant := 16#08000000#;
-
-end System.Linux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . L I N U X --
--- --
--- S p e c --
--- --
--- Copyright (C) 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- --
-------------------------------------------------------------------------------
-
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2011-2017, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Body used on targets where the operating system supports setting task
--- affinities.
-
-with System.Tasking.Initialization;
-with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
-
-with Ada.Unchecked_Conversion;
-
-package body System.Multiprocessors.Dispatching_Domains is
-
- package ST renames System.Tasking;
-
- -----------------------
- -- Local subprograms --
- -----------------------
-
- function Convert_Ids is new
- Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, ST.Task_Id);
-
- procedure Unchecked_Set_Affinity
- (Domain : ST.Dispatching_Domain_Access;
- CPU : CPU_Range;
- T : ST.Task_Id);
- -- Internal procedure to move a task to a target domain and CPU. No checks
- -- are performed about the validity of the domain and the CPU because they
- -- are done by the callers of this procedure (either Assign_Task or
- -- Set_CPU).
-
- procedure Freeze_Dispatching_Domains;
- pragma Export
- (Ada, Freeze_Dispatching_Domains, "__gnat_freeze_dispatching_domains");
- -- Signal the time when no new dispatching domains can be created. It
- -- should be called before the environment task calls the main procedure
- -- (and after the elaboration code), so the binder-generated file needs to
- -- import and call this procedure.
-
- -----------------
- -- Assign_Task --
- -----------------
-
- procedure Assign_Task
- (Domain : in out Dispatching_Domain;
- CPU : CPU_Range := Not_A_Specific_CPU;
- T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task)
- is
- Target : constant ST.Task_Id := Convert_Ids (T);
-
- begin
- -- The exception Dispatching_Domain_Error is propagated if T is already
- -- assigned to a Dispatching_Domain other than
- -- System_Dispatching_Domain, or if CPU is not one of the processors of
- -- Domain (and is not Not_A_Specific_CPU).
-
- if Dispatching_Domain (Target.Common.Domain) /= System_Dispatching_Domain
- then
- raise Dispatching_Domain_Error with
- "task already in user-defined dispatching domain";
-
- elsif CPU /= Not_A_Specific_CPU and then CPU not in Domain'Range then
- raise Dispatching_Domain_Error with
- "processor does not belong to dispatching domain";
- end if;
-
- -- Assigning a task to System_Dispatching_Domain that is already
- -- assigned to that domain has no effect.
-
- if Domain = System_Dispatching_Domain then
- return;
-
- else
- -- Set the task affinity once we know it is possible
-
- Unchecked_Set_Affinity
- (ST.Dispatching_Domain_Access (Domain), CPU, Target);
- end if;
- end Assign_Task;
-
- ------------
- -- Create --
- ------------
-
- function Create (First : CPU; Last : CPU_Range) return Dispatching_Domain is
- begin
- return Create ((First .. Last => True));
- end Create;
-
- function Create (Set : CPU_Set) return Dispatching_Domain is
- ST_DD : aliased constant ST.Dispatching_Domain :=
- ST.Dispatching_Domain (Set);
- First : constant CPU := Get_First_CPU (ST_DD'Unrestricted_Access);
- Last : constant CPU_Range := Get_Last_CPU (ST_DD'Unrestricted_Access);
- subtype Rng is CPU_Range range First .. Last;
-
- use type ST.Dispatching_Domain;
- use type ST.Dispatching_Domain_Access;
- use type ST.Task_Id;
-
- T : ST.Task_Id;
-
- New_System_Domain : ST.Dispatching_Domain := ST.System_Domain.all;
-
- ST_DD_Slice : constant ST.Dispatching_Domain := ST_DD (Rng);
-
- begin
- -- The set of processors for creating a dispatching domain must
- -- comply with the following restrictions:
- -- - Not exceeding the range of available processors.
- -- - CPUs from the System_Dispatching_Domain.
- -- - The calling task must be the environment task.
- -- - The call to Create must take place before the call to the main
- -- subprogram.
- -- - Set does not contain a processor with a task assigned to it.
- -- - The allocation cannot leave System_Dispatching_Domain empty.
-
- -- Note that a previous version of the language forbade empty domains.
-
- if Rng'Last > Number_Of_CPUs then
- raise Dispatching_Domain_Error with
- "CPU not supported by the target";
- end if;
-
- declare
- System_Domain_Slice : constant ST.Dispatching_Domain :=
- ST.System_Domain (Rng);
- Actual : constant ST.Dispatching_Domain :=
- ST_DD_Slice and not System_Domain_Slice;
- Expected : constant ST.Dispatching_Domain := (Rng => False);
- begin
- if Actual /= Expected then
- raise Dispatching_Domain_Error with
- "CPU not currently in System_Dispatching_Domain";
- end if;
- end;
-
- if Self /= Environment_Task then
- raise Dispatching_Domain_Error with
- "only the environment task can create dispatching domains";
- end if;
-
- if ST.Dispatching_Domains_Frozen then
- raise Dispatching_Domain_Error with
- "cannot create dispatching domain after call to main procedure";
- end if;
-
- for Proc in Rng loop
- if ST_DD (Proc) and then
- ST.Dispatching_Domain_Tasks (Proc) /= 0
- then
- raise Dispatching_Domain_Error with "CPU has tasks assigned";
- end if;
- end loop;
-
- New_System_Domain (Rng) := New_System_Domain (Rng) and not ST_DD_Slice;
-
- if New_System_Domain = (New_System_Domain'Range => False) then
- raise Dispatching_Domain_Error with
- "would leave System_Dispatching_Domain empty";
- end if;
-
- return Result : constant Dispatching_Domain :=
- new ST.Dispatching_Domain'(ST_DD_Slice)
- do
- -- At this point we need to fix the processors belonging to the
- -- system domain, and change the affinity of every task that has
- -- been created and assigned to the system domain.
-
- ST.Initialization.Defer_Abort (Self);
-
- Lock_RTS;
-
- ST.System_Domain (Rng) := New_System_Domain (Rng);
- pragma Assert (ST.System_Domain.all = New_System_Domain);
-
- -- Iterate the list of tasks belonging to the default system
- -- dispatching domain and set the appropriate affinity.
-
- T := ST.All_Tasks_List;
-
- while T /= null loop
- if T.Common.Domain = ST.System_Domain then
- Set_Task_Affinity (T);
- end if;
-
- T := T.Common.All_Tasks_Link;
- end loop;
-
- Unlock_RTS;
-
- ST.Initialization.Undefer_Abort (Self);
- end return;
- end Create;
-
- -----------------------------
- -- Delay_Until_And_Set_CPU --
- -----------------------------
-
- procedure Delay_Until_And_Set_CPU
- (Delay_Until_Time : Ada.Real_Time.Time;
- CPU : CPU_Range)
- is
- begin
- -- Not supported atomically by the underlying operating systems.
- -- Operating systems use to migrate the task immediately after the call
- -- to set the affinity.
-
- delay until Delay_Until_Time;
- Set_CPU (CPU);
- end Delay_Until_And_Set_CPU;
-
- --------------------------------
- -- Freeze_Dispatching_Domains --
- --------------------------------
-
- procedure Freeze_Dispatching_Domains is
- begin
- -- Signal the end of the elaboration code
-
- ST.Dispatching_Domains_Frozen := True;
- end Freeze_Dispatching_Domains;
-
- -------------
- -- Get_CPU --
- -------------
-
- function Get_CPU
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task) return CPU_Range
- is
- begin
- return Convert_Ids (T).Common.Base_CPU;
- end Get_CPU;
-
- -----------------
- -- Get_CPU_Set --
- -----------------
-
- function Get_CPU_Set (Domain : Dispatching_Domain) return CPU_Set is
- begin
- return CPU_Set (Domain.all);
- end Get_CPU_Set;
-
- ----------------------------
- -- Get_Dispatching_Domain --
- ----------------------------
-
- function Get_Dispatching_Domain
- (T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task) return Dispatching_Domain
- is
- begin
- return Result : constant Dispatching_Domain :=
- Dispatching_Domain (Convert_Ids (T).Common.Domain)
- do
- pragma Assert (Result /= null);
- end return;
- end Get_Dispatching_Domain;
-
- -------------------
- -- Get_First_CPU --
- -------------------
-
- function Get_First_CPU (Domain : Dispatching_Domain) return CPU is
- begin
- for Proc in Domain'Range loop
- if Domain (Proc) then
- return Proc;
- end if;
- end loop;
-
- return CPU'First;
- end Get_First_CPU;
-
- ------------------
- -- Get_Last_CPU --
- ------------------
-
- function Get_Last_CPU (Domain : Dispatching_Domain) return CPU_Range is
- begin
- for Proc in reverse Domain'Range loop
- if Domain (Proc) then
- return Proc;
- end if;
- end loop;
-
- return CPU_Range'First;
- end Get_Last_CPU;
-
- -------------
- -- Set_CPU --
- -------------
-
- procedure Set_CPU
- (CPU : CPU_Range;
- T : Ada.Task_Identification.Task_Id :=
- Ada.Task_Identification.Current_Task)
- is
- Target : constant ST.Task_Id := Convert_Ids (T);
-
- begin
- -- The exception Dispatching_Domain_Error is propagated if CPU is not
- -- one of the processors of the Dispatching_Domain on which T is
- -- assigned (and is not Not_A_Specific_CPU).
-
- if CPU /= Not_A_Specific_CPU and then
- (CPU not in Target.Common.Domain'Range or else
- not Target.Common.Domain (CPU))
- then
- raise Dispatching_Domain_Error with
- "processor does not belong to the task's dispatching domain";
- end if;
-
- Unchecked_Set_Affinity (Target.Common.Domain, CPU, Target);
- end Set_CPU;
-
- ----------------------------
- -- Unchecked_Set_Affinity --
- ----------------------------
-
- procedure Unchecked_Set_Affinity
- (Domain : ST.Dispatching_Domain_Access;
- CPU : CPU_Range;
- T : ST.Task_Id)
- is
- Source_CPU : constant CPU_Range := T.Common.Base_CPU;
-
- use type ST.Dispatching_Domain_Access;
-
- begin
- Write_Lock (T);
-
- -- Move to the new domain
-
- T.Common.Domain := Domain;
-
- -- Attach the CPU to the task
-
- T.Common.Base_CPU := CPU;
-
- -- Change the number of tasks attached to a given task in the system
- -- domain if needed.
-
- if not ST.Dispatching_Domains_Frozen
- and then (Domain = null or else Domain = ST.System_Domain)
- then
- -- Reduce the number of tasks attached to the CPU from which this
- -- task is being moved, if needed.
-
- if Source_CPU /= Not_A_Specific_CPU then
- ST.Dispatching_Domain_Tasks (Source_CPU) :=
- ST.Dispatching_Domain_Tasks (Source_CPU) - 1;
- end if;
-
- -- Increase the number of tasks attached to the CPU to which this
- -- task is being moved, if needed.
-
- if CPU /= Not_A_Specific_CPU then
- ST.Dispatching_Domain_Tasks (CPU) :=
- ST.Dispatching_Domain_Tasks (CPU) + 1;
- end if;
- end if;
-
- -- Change the actual affinity calling the operating system level
-
- Set_Task_Affinity (T);
-
- Unlock (T);
- end Unchecked_Set_Affinity;
-
-end System.Multiprocessors.Dispatching_Domains;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- SYSTEM.MULTIPROCESSORS.DISPATCHING_DOMAINS --
--- --
--- B o d y --
--- --
--- Copyright (C) 2011-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1997-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a AIX (Native) version of this package
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-package body System.OS_Interface is
-
- use Interfaces.C;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- Dispatching_Policy : Character;
- pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
-
- Time_Slice_Val : Integer;
- pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
-
- begin
- -- For the case SCHED_OTHER the only valid priority across all supported
- -- versions of AIX is 1 (note that the scheduling policy can be set
- -- with the pragma Task_Dispatching_Policy or setting the time slice
- -- value). Otherwise, for SCHED_RR and SCHED_FIFO, the system defines
- -- priorities in the range 1 .. 127. This means that we must map
- -- System.Any_Priority in the range 0 .. 126 to 1 .. 127.
-
- if Dispatching_Policy = ' ' and then Time_Slice_Val < 0 then
- return 1;
- else
- return Interfaces.C.int (Prio) + 1;
- end if;
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F is negative due to a round-up, adjust for positive F value
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- -----------------
- -- sched_yield --
- -----------------
-
- -- AIX Thread does not have sched_yield;
-
- function sched_yield return int is
- procedure pthread_yield;
- pragma Import (C, pthread_yield, "sched_yield");
- begin
- pthread_yield;
- return 0;
- end sched_yield;
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- --------------------------
- -- PTHREAD_PRIO_INHERIT --
- --------------------------
-
- AIX_Version : Integer := 0;
- -- AIX version in the form xy for AIX version x.y (0 means not set)
-
- SYS_NMLN : constant := 32;
- -- AIX system constant used to define utsname, see sys/utsname.h
-
- subtype String_NMLN is String (1 .. SYS_NMLN);
-
- type utsname is record
- sysname : String_NMLN;
- nodename : String_NMLN;
- release : String_NMLN;
- version : String_NMLN;
- machine : String_NMLN;
- procserial : String_NMLN;
- end record;
- pragma Convention (C, utsname);
-
- procedure uname (name : out utsname);
- pragma Import (C, uname);
-
- function PTHREAD_PRIO_INHERIT return int is
- name : utsname;
-
- function Val (C : Character) return Integer;
- -- Transform a numeric character ('0' .. '9') to an integer
-
- ---------
- -- Val --
- ---------
-
- function Val (C : Character) return Integer is
- begin
- return Character'Pos (C) - Character'Pos ('0');
- end Val;
-
- -- Start of processing for PTHREAD_PRIO_INHERIT
-
- begin
- if AIX_Version = 0 then
-
- -- Set AIX_Version
-
- uname (name);
- AIX_Version := Val (name.version (1)) * 10 + Val (name.release (1));
- end if;
-
- if AIX_Version < 53 then
-
- -- Under AIX < 5.3, PTHREAD_PRIO_INHERIT is defined as 0 in pthread.h
-
- return 0;
-
- else
- -- Under AIX >= 5.3, PTHREAD_PRIO_INHERIT is defined as 3
-
- return 3;
- end if;
- end PTHREAD_PRIO_INHERIT;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2015, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a AIX (Native THREADS) version of this package
-
--- This package encapsulates all direct interfaces to OS services that are
--- needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-with Interfaces.C.Extensions;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-pthread");
- -- This implies -lpthreads + other things depending on the GCC
- -- configuration, such as the selection of a proper libgcc variant
- -- for table-based exception handling when it is available.
-
- pragma Linker_Options ("-lc_r");
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype long_long is Interfaces.C.Extensions.long_long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIMEDOUT : constant := 78;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 63;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGPWR : constant := 29; -- power-fail restart
- SIGWINCH : constant := 28; -- window size change
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGPOLL : constant := 23; -- pollable event occurred
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGVTALRM : constant := 34; -- virtual timer expired
- SIGPROF : constant := 32; -- profiling timer expired
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGWAITING : constant := 39; -- m:n scheduling
-
- -- The following signals are AIX specific
-
- SIGMSG : constant := 27; -- input data is in the ring buffer
- SIGDANGER : constant := 33; -- system crash imminent
- SIGMIGRATE : constant := 35; -- migrate process
- SIGPRE : constant := 36; -- programming exception
- SIGVIRT : constant := 37; -- AIX virtual time alarm
- SIGALRM1 : constant := 38; -- m:n condition variables
- SIGCPUFAIL : constant := 59; -- Predictive De-configuration of Processors
- SIGKAP : constant := 60; -- keep alive poll from native keyboard
- SIGGRANT : constant := SIGKAP; -- monitor mode granted
- SIGRETRACT : constant := 61; -- monitor mode should be relinquished
- SIGSOUND : constant := 62; -- sound control has completed
- SIGSAK : constant := 63; -- secure attention key
-
- SIGADAABORT : constant := SIGEMT;
- -- Note: on other targets, we usually use SIGABRT, but on AIX, it appears
- -- that SIGABRT can't be used in sigwait(), so we use SIGEMT.
- -- SIGEMT is "Emulator Trap Instruction" from the PDP-11, and does not
- -- have a standardized usage.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set :=
- (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF);
- Reserved : constant Signal_Set :=
- (SIGABRT, SIGKILL, SIGSTOP, SIGALRM1, SIGWAITING, SIGCPUFAIL);
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SA_SIGINFO : constant := 16#0100#;
- SA_ONSTACK : constant := 16#0001#;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := True;
- -- Indicates whether time slicing is supported
-
- type timespec is private;
-
- type clockid_t is new long_long;
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec) return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
- pragma Import (C, clock_getres, "clock_getres");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- type struct_timezone is record
- tz_minuteswest : int;
- tz_dsttime : int;
- end record;
- pragma Convention (C, struct_timezone);
- type struct_timezone_ptr is access all struct_timezone;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 1;
- SCHED_RR : constant := 2;
- SCHED_OTHER : constant := 0;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- pragma Import (C, lwp_self, "thread_self");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- type pthread_t is private;
- subtype Thread_Id is pthread_t;
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- PTHREAD_CREATE_DETACHED : constant := 1;
-
- PTHREAD_SCOPE_PROCESS : constant := 1;
- PTHREAD_SCOPE_SYSTEM : constant := 0;
-
- -- Read/Write lock not supported on AIX. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- subtype pthread_rwlock_t is pthread_mutex_t;
- subtype pthread_rwlockattr_t is pthread_mutexattr_t;
-
- -----------
- -- Stack --
- -----------
-
- type stack_t is record
- ss_sp : System.Address;
- ss_size : size_t;
- ss_flags : int;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- -- This is a dummy definition, never used (Alternate_Stack_Size is null)
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- Returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- function Get_Page_Size return int;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- Returns the size of a page
-
- PROT_NONE : constant := 0;
- PROT_READ : constant := 1;
- PROT_WRITE : constant := 2;
- PROT_EXEC : constant := 4;
- PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
- PROT_ON : constant := PROT_READ;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- -- Though not documented, pthread_init *must* be called before any other
- -- pthread call.
-
- procedure pthread_init;
- pragma Import (C, pthread_init, "pthread_init");
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "sigthreadmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_PROTECT : constant := 2;
-
- function PTHREAD_PRIO_INHERIT return int;
- -- Return value of C macro PTHREAD_PRIO_INHERIT. This function is needed
- -- since the value is different between AIX versions.
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol);
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import (C, pthread_mutexattr_setprioceiling);
-
- type Array_5_Int is array (0 .. 5) of int;
- type struct_sched_param is record
- sched_priority : int;
- sched_policy : int;
- sched_reserved : Array_5_Int;
- end record;
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import (C, pthread_attr_setinheritsched);
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy);
-
- function pthread_attr_setschedparam
- (attr : access pthread_attr_t;
- sched_param : int) return int;
- pragma Import (C, pthread_attr_setschedparam);
-
- function sched_yield return int;
- -- AIX have a nonstandard sched_yield
-
- --------------------------
- -- P1003.1c Section 16 --
- --------------------------
-
- function pthread_attr_init (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import (C, pthread_attr_setdetachstate);
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize);
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address)
- return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
-private
- type sigset_t is record
- losigs : unsigned_long;
- hisigs : unsigned_long;
- end record;
- pragma Convention (C_Pass_By_Copy, sigset_t);
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type pthread_attr_t is new System.Address;
- pragma Convention (C, pthread_attr_t);
- -- typedef struct __pt_attr *pthread_attr_t;
-
- type pthread_condattr_t is new System.Address;
- pragma Convention (C, pthread_condattr_t);
- -- typedef struct __pt_attr *pthread_condattr_t;
-
- type pthread_mutexattr_t is new System.Address;
- pragma Convention (C, pthread_mutexattr_t);
- -- typedef struct __pt_attr *pthread_mutexattr_t;
-
- type pthread_t is new System.Address;
- pragma Convention (C, pthread_t);
- -- typedef void *pthread_t;
-
- type ptq_queue;
- type ptq_queue_ptr is access all ptq_queue;
-
- type ptq_queue is record
- ptq_next : ptq_queue_ptr;
- ptq_prev : ptq_queue_ptr;
- end record;
-
- type Array_3_Int is array (0 .. 3) of int;
- type pthread_mutex_t is record
- link : ptq_queue;
- ptmtx_lock : int;
- ptmtx_flags : long;
- protocol : int;
- prioceiling : int;
- ptmtx_owner : pthread_t;
- mtx_id : int;
- attr : pthread_attr_t;
- mtx_kind : int;
- lock_cpt : int;
- reserved : Array_3_Int;
- end record;
- pragma Convention (C, pthread_mutex_t);
- type pthread_mutex_t_ptr is access pthread_mutex_t;
-
- type pthread_cond_t is record
- link : ptq_queue;
- ptcv_lock : int;
- ptcv_flags : long;
- ptcv_waiters : ptq_queue;
- cv_id : int;
- attr : pthread_attr_t;
- mutex : pthread_mutex_t_ptr;
- cptwait : int;
- reserved : int;
- end record;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_key_t is new unsigned;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1995-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is an Android version of this package.
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-with Interfaces.C; use Interfaces.C;
-
-package body System.OS_Interface is
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1995-2015, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is an Android version of this package which is based on the
--- GNU/Linux version
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-with Interfaces.C;
-with System.Linux;
-with System.OS_Constants;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- subtype int is Interfaces.C.int;
- subtype char is Interfaces.C.char;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := System.Linux.EAGAIN;
- EINTR : constant := System.Linux.EINTR;
- EINVAL : constant := System.Linux.EINVAL;
- ENOMEM : constant := System.Linux.ENOMEM;
- EPERM : constant := System.Linux.EPERM;
- ETIMEDOUT : constant := System.Linux.ETIMEDOUT;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 31;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := System.Linux.SIGHUP;
- SIGINT : constant := System.Linux.SIGINT;
- SIGQUIT : constant := System.Linux.SIGQUIT;
- SIGILL : constant := System.Linux.SIGILL;
- SIGTRAP : constant := System.Linux.SIGTRAP;
- SIGIOT : constant := System.Linux.SIGIOT;
- SIGABRT : constant := System.Linux.SIGABRT;
- SIGFPE : constant := System.Linux.SIGFPE;
- SIGKILL : constant := System.Linux.SIGKILL;
- SIGBUS : constant := System.Linux.SIGBUS;
- SIGSEGV : constant := System.Linux.SIGSEGV;
- SIGPIPE : constant := System.Linux.SIGPIPE;
- SIGALRM : constant := System.Linux.SIGALRM;
- SIGTERM : constant := System.Linux.SIGTERM;
- SIGUSR1 : constant := System.Linux.SIGUSR1;
- SIGUSR2 : constant := System.Linux.SIGUSR2;
- SIGCLD : constant := System.Linux.SIGCLD;
- SIGCHLD : constant := System.Linux.SIGCHLD;
- SIGPWR : constant := System.Linux.SIGPWR;
- SIGWINCH : constant := System.Linux.SIGWINCH;
- SIGURG : constant := System.Linux.SIGURG;
- SIGPOLL : constant := System.Linux.SIGPOLL;
- SIGIO : constant := System.Linux.SIGIO;
- SIGLOST : constant := System.Linux.SIGLOST;
- SIGSTOP : constant := System.Linux.SIGSTOP;
- SIGTSTP : constant := System.Linux.SIGTSTP;
- SIGCONT : constant := System.Linux.SIGCONT;
- SIGTTIN : constant := System.Linux.SIGTTIN;
- SIGTTOU : constant := System.Linux.SIGTTOU;
- SIGVTALRM : constant := System.Linux.SIGVTALRM;
- SIGPROF : constant := System.Linux.SIGPROF;
- SIGXCPU : constant := System.Linux.SIGXCPU;
- SIGXFSZ : constant := System.Linux.SIGXFSZ;
- SIGUNUSED : constant := System.Linux.SIGUNUSED;
- SIGSTKFLT : constant := System.Linux.SIGSTKFLT;
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this to use another signal for task abort. SIGTERM might be a
- -- good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set := (
- SIGTRAP,
- -- To enable debugging on multithreaded applications, mark SIGTRAP to
- -- be kept unmasked.
-
- SIGBUS,
-
- SIGTTIN, SIGTTOU, SIGTSTP,
- -- Keep these three signals unmasked so that background processes and IO
- -- behaves as normal "C" applications
-
- SIGPROF,
- -- To avoid confusing the profiler
-
- SIGKILL, SIGSTOP);
- -- These two signals actually can't be masked (POSIX won't allow it)
-
- Reserved : constant Signal_Set := (SIGVTALRM, SIGUNUSED);
- -- Not clear why these two signals are reserved. Perhaps they are not
- -- supported by this version of GNU/Linux ???
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "_sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "_sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "_sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "_sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "_sigemptyset");
-
- type union_type_3 is new String (1 .. 116);
- type siginfo_t is record
- si_signo : int;
- si_code : int;
- si_errno : int;
- X_data : union_type_3;
- end record;
- pragma Convention (C, siginfo_t);
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : Interfaces.C.unsigned_long;
- sa_restorer : System.Address;
- end record;
- pragma Convention (C, struct_sigaction);
-
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SA_SIGINFO : constant := System.Linux.SA_SIGINFO;
- SA_ONSTACK : constant := System.Linux.SA_ONSTACK;
- SA_NODEFER : constant := System.Linux.SA_NODEFER;
- SA_RESTART : constant := System.Linux.SA_RESTART;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := True;
- -- Indicates whether time slicing is supported
-
- type timespec is private;
-
- type clockid_t is new int;
-
- function clock_gettime
- (clock_id : clockid_t; tp : access timespec) return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
- pragma Import (C, clock_getres, "clock_getres");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- function sysconf (name : int) return long;
- pragma Import (C, sysconf);
-
- SC_CLK_TCK : constant := 2;
- SC_NPROCESSORS_ONLN : constant := 84;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_OTHER : constant := 0;
- SCHED_FIFO : constant := 1;
- SCHED_RR : constant := 2;
-
- function To_Target_Priority
- (Prio : System.Any_Priority)
- return Interfaces.C.int is (Interfaces.C.int (Prio));
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- type pthread_t is new unsigned_long;
- subtype Thread_Id is pthread_t;
-
- function To_pthread_t is
- new Ada.Unchecked_Conversion (unsigned_long, pthread_t);
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- PTHREAD_CREATE_DETACHED : constant := 1;
-
- PTHREAD_SCOPE_PROCESS : constant := 1;
- PTHREAD_SCOPE_SYSTEM : constant := 0;
-
- -- Read/Write lock not supported on Android.
-
- subtype pthread_rwlock_t is pthread_mutex_t;
- subtype pthread_rwlockattr_t is pthread_mutexattr_t;
-
- -----------
- -- Stack --
- -----------
-
- type stack_t is record
- ss_sp : System.Address;
- ss_flags : int;
- ss_size : size_t;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
- -- The alternate signal stack for stack overflows
-
- Alternate_Stack_Size : constant := 16 * 1024;
- -- This must be in keeping with init.c:__gnat_alternate_stack
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t)
- return Address is (Null_Address);
- -- This is a dummy procedure to share some GNULLI files
-
- function Get_Page_Size return int;
- pragma Import (C, Get_Page_Size, "_getpagesize");
- -- Returns the size of a page
-
- PROT_NONE : constant := 0;
- PROT_READ : constant := 1;
- PROT_WRITE : constant := 2;
- PROT_EXEC : constant := 4;
- PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
- PROT_ON : constant := PROT_READ;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init is null;
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "sigprocmask");
- -- pthread_sigmask maybe be broken due to mismatch between sigset_t and
- -- kernel_sigset_t, substitute sigprocmask temporarily. ???
- -- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_PROTECT : constant := 0;
- PTHREAD_PRIO_INHERIT : constant := 1;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int is (0);
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int is (0);
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- end record;
- pragma Convention (C, struct_sched_param);
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- scope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import
- (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy");
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "sched_yield");
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import
- (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- function lwp_self return System.Address;
- pragma Import (C, lwp_self, "__gnat_lwp_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- CPU_SETSIZE : constant := 1_024;
- -- Size of the cpu_set_t mask on most linux systems (SUSE 11 uses 4_096).
- -- This is kept for backward compatibility (System.Task_Info uses it), but
- -- the run-time library does no longer rely on static masks, using
- -- dynamically allocated masks instead.
-
- type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
- for bit_field'Size use CPU_SETSIZE;
- pragma Pack (bit_field);
- pragma Convention (C, bit_field);
-
- type cpu_set_t is record
- bits : bit_field;
- end record;
- pragma Convention (C, cpu_set_t);
-
- type cpu_set_t_ptr is access all cpu_set_t;
- -- In the run-time library we use this pointer because the size of type
- -- cpu_set_t varies depending on the glibc version. Hence, objects of type
- -- cpu_set_t are allocated dynamically using the number of processors
- -- available in the target machine (value obtained at execution time).
-
- function CPU_ALLOC (count : size_t) return cpu_set_t_ptr;
- pragma Import (C, CPU_ALLOC, "__gnat_cpu_alloc");
- -- Wrapper around the CPU_ALLOC C macro
-
- function CPU_ALLOC_SIZE (count : size_t) return size_t;
- pragma Import (C, CPU_ALLOC_SIZE, "__gnat_cpu_alloc_size");
- -- Wrapper around the CPU_ALLOC_SIZE C macro
-
- procedure CPU_FREE (cpuset : cpu_set_t_ptr);
- pragma Import (C, CPU_FREE, "__gnat_cpu_free");
- -- Wrapper around the CPU_FREE C macro
-
- procedure CPU_ZERO (count : size_t; cpuset : cpu_set_t_ptr);
- pragma Import (C, CPU_ZERO, "__gnat_cpu_zero");
- -- Wrapper around the CPU_ZERO_S C macro
-
- procedure CPU_SET (cpu : int; count : size_t; cpuset : cpu_set_t_ptr);
- pragma Import (C, CPU_SET, "__gnat_cpu_set");
- -- Wrapper around the CPU_SET_S C macro
-
- function pthread_setaffinity_np
- (thread : pthread_t;
- cpusetsize : size_t;
- cpuset : cpu_set_t_ptr) return int;
- pragma Import (C, pthread_setaffinity_np, "pthread_setaffinity_np");
- pragma Weak_External (pthread_setaffinity_np);
- -- Use a weak symbol because this function may be available or not,
- -- depending on the version of the system.
-
- function pthread_attr_setaffinity_np
- (attr : access pthread_attr_t;
- cpusetsize : size_t;
- cpuset : cpu_set_t_ptr) return int;
- pragma Import (C, pthread_attr_setaffinity_np,
- "pthread_attr_setaffinity_np");
- pragma Weak_External (pthread_attr_setaffinity_np);
- -- Use a weak symbol because this function may be available or not,
- -- depending on the version of the system.
-
-private
-
- type sigset_t is new Interfaces.C.unsigned_long;
- pragma Convention (C, sigset_t);
- for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
- pragma Warnings (Off);
- for struct_sigaction use record
- sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1;
- sa_mask at Linux.sa_mask_pos range 0 .. sigset_t'Size - 1;
- sa_flags at Linux.sa_flags_pos
- range 0 .. Interfaces.C.unsigned_long'Size - 1;
- end record;
- -- We intentionally leave sa_restorer unspecified and let the compiler
- -- append it after the last field, so disable corresponding warning.
- pragma Warnings (On);
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type unsigned_long_long_t is mod 2 ** 64;
- -- Local type only used to get the alignment of this type below
-
- subtype char_array is Interfaces.C.char_array;
-
- type pthread_attr_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_ATTR_SIZE);
- end record;
- pragma Convention (C, pthread_attr_t);
- for pthread_attr_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
- type pthread_condattr_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_CONDATTR_SIZE);
- end record;
- pragma Convention (C, pthread_condattr_t);
- for pthread_condattr_t'Alignment use Interfaces.C.int'Alignment;
-
- type pthread_mutexattr_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_MUTEXATTR_SIZE);
- end record;
- pragma Convention (C, pthread_mutexattr_t);
- for pthread_mutexattr_t'Alignment use Interfaces.C.int'Alignment;
-
- type pthread_mutex_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE);
- end record;
- pragma Convention (C, pthread_mutex_t);
- for pthread_mutex_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
- type pthread_cond_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_COND_SIZE);
- end record;
- pragma Convention (C, pthread_cond_t);
- for pthread_cond_t'Alignment use unsigned_long_long_t'Alignment;
-
- type pthread_key_t is new unsigned;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1999-2015, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a Darwin Threads version of this package
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
-with Interfaces.C.Extensions;
-
-package body System.OS_Interface is
- use Interfaces.C;
- use Interfaces.C.Extensions;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- -------------------
- -- clock_gettime --
- -------------------
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec) return int
- is
- pragma Unreferenced (clock_id);
-
- -- Darwin Threads don't have clock_gettime, so use gettimeofday
-
- use Interfaces;
-
- type timeval is array (1 .. 3) of C.long;
- -- The timeval array is sized to contain long_long sec and long usec.
- -- If long_long'Size = long'Size then it will be overly large but that
- -- won't effect the implementation since it's not accessed directly.
-
- procedure timeval_to_duration
- (T : not null access timeval;
- sec : not null access C.Extensions.long_long;
- usec : not null access C.long);
- pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
-
- Micro : constant := 10**6;
- sec : aliased C.Extensions.long_long;
- usec : aliased C.long;
- TV : aliased timeval;
- Result : int;
-
- function gettimeofday
- (Tv : access timeval;
- Tz : System.Address := System.Null_Address) return int;
- pragma Import (C, gettimeofday, "gettimeofday");
-
- begin
- Result := gettimeofday (TV'Access, System.Null_Address);
- pragma Assert (Result = 0);
- timeval_to_duration (TV'Access, sec'Access, usec'Access);
- tp.all := To_Timespec (Duration (sec) + Duration (usec) / Micro);
- return Result;
- end clock_gettime;
-
- ------------------
- -- clock_getres --
- ------------------
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int
- is
- pragma Unreferenced (clock_id);
-
- -- Darwin Threads don't have clock_getres.
-
- Nano : constant := 10**9;
- nsec : int := 0;
- Result : int := -1;
-
- function clock_get_res return int;
- pragma Import (C, clock_get_res, "__gnat_clock_get_res");
-
- begin
- nsec := clock_get_res;
- res.all := To_Timespec (Duration (0.0) + Duration (nsec) / Nano);
-
- if nsec > 0 then
- Result := 0;
- end if;
-
- return Result;
- end clock_getres;
-
- -----------------
- -- sched_yield --
- -----------------
-
- function sched_yield return int is
- procedure sched_yield_base (arg : System.Address);
- pragma Import (C, sched_yield_base, "pthread_yield_np");
-
- begin
- sched_yield_base (System.Null_Address);
- return 0;
- end sched_yield;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- ----------------
- -- Stack_Base --
- ----------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Unreferenced (thread);
- begin
- return System.Null_Address;
- end Get_Stack_Base;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2015, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is Darwin pthreads version of this package
-
--- This package includes all direct interfaces to OS services that are needed
--- by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Elaborate_Body. It is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-with System.OS_Constants;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EINTR : constant := 4;
- ENOMEM : constant := 12;
- EINVAL : constant := 22;
- EAGAIN : constant := 35;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 31;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGINFO : constant := 29; -- information request
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set :=
- (SIGTTIN, SIGTTOU, SIGSTOP, SIGTSTP);
-
- Reserved : constant Signal_Set :=
- (SIGKILL, SIGSTOP);
-
- Exception_Signals : constant Signal_Set :=
- (SIGFPE, SIGILL, SIGSEGV, SIGBUS);
- -- These signals (when runtime or system) will be caught and converted
- -- into an Ada exception.
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type siginfo_t is private;
- type ucontext_t is private;
-
- type Signal_Handler is access procedure
- (signo : Signal;
- info : access siginfo_t;
- context : access ucontext_t);
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- SA_SIGINFO : constant := 16#0040#;
- SA_ONSTACK : constant := 16#0001#;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := True;
- -- Indicates whether time slicing is supported
-
- type timespec is private;
-
- type clockid_t is new int;
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec) return int;
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_OTHER : constant := 1;
- SCHED_RR : constant := 2;
- SCHED_FIFO : constant := 4;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- pragma Import (C, lwp_self, "__gnat_lwp_self");
- -- Return the mach thread bound to the current thread. The value is not
- -- used by the run-time library but made available to debuggers.
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- type pthread_t is private;
- subtype Thread_Id is pthread_t;
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- type pthread_mutex_ptr is access all pthread_mutex_t;
- type pthread_cond_ptr is access all pthread_cond_t;
-
- PTHREAD_CREATE_DETACHED : constant := 2;
-
- PTHREAD_SCOPE_PROCESS : constant := 2;
- PTHREAD_SCOPE_SYSTEM : constant := 1;
-
- -- Read/Write lock not supported on Darwin. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- subtype pthread_rwlock_t is pthread_mutex_t;
- subtype pthread_rwlockattr_t is pthread_mutexattr_t;
-
- -----------
- -- Stack --
- -----------
-
- type stack_t is record
- ss_sp : System.Address;
- ss_size : size_t;
- ss_flags : int;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
- -- The alternate signal stack for stack overflows
-
- Alternate_Stack_Size : constant := 32 * 1024;
- -- This must be in keeping with init.c:__gnat_alternate_stack
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target. This
- -- allows us to share s-osinte.adb between all the FSU run time. Note that
- -- this value can only be true if pthread_t has a complete definition that
- -- corresponds exactly to the C header files.
-
- function Get_Stack_Base (thread : pthread_t) return System.Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- function Get_Page_Size return int;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- Returns the size of a page
-
- PROT_NONE : constant := 0;
- PROT_READ : constant := 1;
- PROT_WRITE : constant := 2;
- PROT_EXEC : constant := 4;
- PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
-
- PROT_ON : constant := PROT_NONE;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect
- (addr : System.Address;
- len : size_t;
- prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_INHERIT : constant := 1;
- PTHREAD_PRIO_PROTECT : constant := 2;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprioceiling,
- "pthread_mutexattr_setprioceiling");
-
- type padding is array (int range <>) of Interfaces.C.char;
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- opaque : padding (1 .. 4);
- end record;
- pragma Convention (C, struct_sched_param);
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import
- (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched");
-
- function sched_yield return int;
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import
- (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import
- (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
-private
-
- type sigset_t is new unsigned;
-
- type int32_t is new int;
-
- type pid_t is new int32_t;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- --
- -- Darwin specific signal implementation
- --
- type Pad_Type is array (1 .. 7) of unsigned_long;
- type siginfo_t is record
- si_signo : int; -- signal number
- si_errno : int; -- errno association
- si_code : int; -- signal code
- si_pid : int; -- sending process
- si_uid : unsigned; -- sender's ruid
- si_status : int; -- exit value
- si_addr : System.Address; -- faulting instruction
- si_value : System.Address; -- signal value
- si_band : long; -- band event for SIGPOLL
- pad : Pad_Type; -- RFU
- end record;
- pragma Convention (C, siginfo_t);
-
- type mcontext_t is new System.Address;
-
- type ucontext_t is record
- uc_onstack : int;
- uc_sigmask : sigset_t; -- Signal Mask Used By This Context
- uc_stack : stack_t; -- Stack Used By This Context
- uc_link : System.Address; -- Pointer To Resuming Context
- uc_mcsize : size_t; -- Size of The Machine Context
- uc_mcontext : mcontext_t; -- Machine Specific Context
- end record;
- pragma Convention (C, ucontext_t);
-
- --
- -- Darwin specific pthread implementation
- --
- type pthread_t is new System.Address;
-
- type pthread_attr_t is record
- sig : long;
- opaque : padding (1 .. System.OS_Constants.PTHREAD_ATTR_SIZE);
- end record;
- pragma Convention (C, pthread_attr_t);
-
- type pthread_mutexattr_t is record
- sig : long;
- opaque : padding (1 .. System.OS_Constants.PTHREAD_MUTEXATTR_SIZE);
- end record;
- pragma Convention (C, pthread_mutexattr_t);
-
- type pthread_mutex_t is record
- sig : long;
- opaque : padding (1 .. System.OS_Constants.PTHREAD_MUTEX_SIZE);
- end record;
- pragma Convention (C, pthread_mutex_t);
-
- type pthread_condattr_t is record
- sig : long;
- opaque : padding (1 .. System.OS_Constants.PTHREAD_CONDATTR_SIZE);
- end record;
- pragma Convention (C, pthread_condattr_t);
-
- type pthread_cond_t is record
- sig : long;
- opaque : padding (1 .. System.OS_Constants.PTHREAD_COND_SIZE);
- end record;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_once_t is record
- sig : long;
- opaque : padding (1 .. System.OS_Constants.PTHREAD_ONCE_SIZE);
- end record;
- pragma Convention (C, pthread_once_t);
-
- type pthread_key_t is new unsigned_long;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-2015, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
--- This is the DragonFly THREADS version of this package
-
-with Interfaces.C; use Interfaces.C;
-
-package body System.OS_Interface is
-
- -----------
- -- Errno --
- -----------
-
- function Errno return int is
- type int_ptr is access all int;
-
- function internal_errno return int_ptr;
- pragma Import (C, internal_errno, "__get_errno");
-
- begin
- return (internal_errno.all);
- end Errno;
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Unreferenced (thread);
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(ts_sec => S,
- ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2015, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
--- This is the DragonFly BSD PTHREADS version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-pthread");
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function Errno return int;
- pragma Inline (Errno);
-
- EAGAIN : constant := 35;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 31;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGINFO : constant := 29; -- information request (BSD)
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- -- Interrupts that must be unmasked at all times. DragonFlyBSD
- -- pthreads will not allow an application to mask out any
- -- interrupt needed by the threads library.
- Unmasked : constant Signal_Set :=
- (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP);
-
- -- DragonFlyBSD will uses SIGPROF for timing. Do not allow a
- -- handler to attach to this signal.
- Reserved : constant Signal_Set := (0 .. 0 => SIGPROF);
-
- type sigset_t is private;
-
- function sigaddset
- (set : access sigset_t;
- sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset
- (set : access sigset_t;
- sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember
- (set : access sigset_t;
- sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- -- sigcontext is architecture dependent, so define it private
- type struct_sigcontext is private;
-
- type old_struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, old_struct_sigaction);
-
- type new_struct_sigaction is record
- sa_handler : System.Address;
- sa_flags : int;
- sa_mask : sigset_t;
- end record;
- pragma Convention (C, new_struct_sigaction);
-
- subtype struct_sigaction is new_struct_sigaction;
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- SA_SIGINFO : constant := 16#0040#;
- SA_ONSTACK : constant := 16#0001#;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := True;
- -- Indicates whether time slicing is supported (i.e SCHED_RR is supported)
-
- type timespec is private;
-
- function nanosleep (rqtp, rmtp : access timespec) return int;
- pragma Import (C, nanosleep, "nanosleep");
-
- type clockid_t is new unsigned_long;
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
- pragma Import (C, clock_getres, "clock_getres");
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec)
- return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- type struct_timezone is record
- tz_minuteswest : int;
- tz_dsttime : int;
- end record;
- pragma Convention (C, struct_timezone);
-
- procedure usleep (useconds : unsigned_long);
- pragma Import (C, usleep, "usleep");
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 1;
- SCHED_OTHER : constant := 2;
- SCHED_RR : constant := 3;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- type pthread_t is private;
- subtype Thread_Id is pthread_t;
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- PTHREAD_CREATE_DETACHED : constant := 1;
- PTHREAD_CREATE_JOINABLE : constant := 0;
-
- PTHREAD_SCOPE_PROCESS : constant := 0;
- PTHREAD_SCOPE_SYSTEM : constant := 2;
-
- -- Read/Write lock not supported on DragonFly. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- subtype pthread_rwlock_t is pthread_mutex_t;
- subtype pthread_rwlockattr_t is pthread_mutexattr_t;
-
- -----------
- -- Stack --
- -----------
-
- type stack_t is record
- ss_sp : System.Address;
- ss_size : size_t;
- ss_flags : int;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- -- This is a dummy definition, never used (Alternate_Stack_Size is null)
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target. This
- -- allows us to share s-osinte.adb between all the FSU run time. Note that
- -- this value can only be true if pthread_t has a complete definition that
- -- corresponds exactly to the C header files.
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- function Get_Page_Size return int;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- Returns the size of a page
-
- PROT_NONE : constant := 0;
- PROT_READ : constant := 1;
- PROT_WRITE : constant := 2;
- PROT_EXEC : constant := 4;
- PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
- PROT_ON : constant := PROT_NONE;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- -- FSU_THREADS requires pthread_init, which is nonstandard and this should
- -- be invoked during the elaboration of s-taprop.adb.
-
- -- DragonFlyBSD does not require this so we provide an empty Ada body
-
- procedure pthread_init;
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 2;
- PTHREAD_PRIO_INHERIT : constant := 1;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
-
- function pthread_mutexattr_getprotocol
- (attr : access pthread_mutexattr_t;
- protocol : access int) return int;
- pragma Import
- (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol");
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprioceiling,
- "pthread_mutexattr_setprioceiling");
-
- function pthread_mutexattr_getprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : access int) return int;
- pragma Import
- (C, pthread_mutexattr_getprioceiling,
- "pthread_mutexattr_getprioceiling");
-
- type struct_sched_param is record
- sched_priority : int;
- end record;
- pragma Convention (C, struct_sched_param);
-
- function pthread_getschedparam
- (thread : pthread_t;
- policy : access int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_getschedparam, "pthread_getschedparam");
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_getscope
- (attr : access pthread_attr_t;
- contentionscope : access int) return int;
- pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import
- (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
-
- function pthread_attr_getinheritsched
- (attr : access pthread_attr_t;
- inheritsched : access int) return int;
- pragma Import
- (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy,
- "pthread_attr_setschedpolicy");
-
- function pthread_attr_getschedpolicy
- (attr : access pthread_attr_t;
- policy : access int) return int;
- pragma Import (C, pthread_attr_getschedpolicy,
- "pthread_attr_getschedpolicy");
-
- function pthread_attr_setschedparam
- (attr : access pthread_attr_t;
- sched_param : int) return int;
- pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
-
- function pthread_attr_getschedparam
- (attr : access pthread_attr_t;
- sched_param : access int) return int;
- pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam");
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "pthread_yield");
-
- --------------------------
- -- P1003.1c Section 16 --
- --------------------------
-
- function pthread_attr_init (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import
- (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
-
- function pthread_attr_getdetachstate
- (attr : access pthread_attr_t;
- detachstate : access int) return int;
- pragma Import
- (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate");
-
- function pthread_attr_getstacksize
- (attr : access pthread_attr_t;
- stacksize : access size_t) return int;
- pragma Import
- (C, pthread_attr_getstacksize, "pthread_attr_getstacksize");
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import
- (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- function pthread_detach (thread : pthread_t) return int;
- pragma Import (C, pthread_detach, "pthread_detach");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- ------------------------------------
- -- Non-portable Pthread Functions --
- ------------------------------------
-
- function pthread_set_name_np
- (thread : pthread_t;
- name : System.Address) return int;
- pragma Import (C, pthread_set_name_np, "pthread_set_name_np");
-
-private
-
- type sigset_t is array (1 .. 4) of unsigned;
-
- -- In DragonFlyBSD the component sa_handler turns out to
- -- be one a union type, and the selector is a macro:
- -- #define sa_handler __sigaction_u._handler
- -- #define sa_sigaction __sigaction_u._sigaction
-
- -- Should we add a signal_context type here ???
- -- How could it be done independent of the CPU architecture ???
- -- sigcontext type is opaque, so it is architecturally neutral.
- -- It is always passed as an access type, so define it as an empty record
- -- since the contents are not used anywhere.
-
- type struct_sigcontext is null record;
- pragma Convention (C, struct_sigcontext);
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- ts_sec : time_t;
- ts_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type pthread_t is new System.Address;
- type pthread_attr_t is new System.Address;
- type pthread_mutex_t is new System.Address;
- type pthread_mutexattr_t is new System.Address;
- type pthread_cond_t is new System.Address;
- type pthread_condattr_t is new System.Address;
- type pthread_key_t is new int;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the no tasking version
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 2;
- type Signal is new Integer range 0 .. Max_Interrupt;
-
- type sigset_t is new Integer;
- type Thread_Id is new Integer;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-2015, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
--- This is the FreeBSD THREADS version of this package
-
-with Interfaces.C; use Interfaces.C;
-
-package body System.OS_Interface is
-
- -----------
- -- Errno --
- -----------
-
- function Errno return int is
- type int_ptr is access all int;
-
- function internal_errno return int_ptr;
- pragma Import (C, internal_errno, "__get_errno");
-
- begin
- return (internal_errno.all);
- end Errno;
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Unreferenced (thread);
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(ts_sec => S,
- ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
--- This is the FreeBSD (POSIX Threads) version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-pthread");
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function Errno return int;
- pragma Inline (Errno);
-
- EAGAIN : constant := 35;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 31;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD)
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- -- Interrupts that must be unmasked at all times. FreeBSD
- -- pthreads will not allow an application to mask out any
- -- interrupt needed by the threads library.
- Unmasked : constant Signal_Set :=
- (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP);
-
- -- FreeBSD will uses SIGPROF for timing. Do not allow a
- -- handler to attach to this signal.
- Reserved : constant Signal_Set := (0 .. 0 => SIGPROF);
-
- type sigset_t is private;
-
- function sigaddset
- (set : access sigset_t;
- sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset
- (set : access sigset_t;
- sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember
- (set : access sigset_t;
- sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- -- sigcontext is architecture dependent, so define it private
- type struct_sigcontext is private;
-
- type old_struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, old_struct_sigaction);
-
- type new_struct_sigaction is record
- sa_handler : System.Address;
- sa_flags : int;
- sa_mask : sigset_t;
- end record;
- pragma Convention (C, new_struct_sigaction);
-
- subtype struct_sigaction is new_struct_sigaction;
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- SA_SIGINFO : constant := 16#0040#;
- SA_ONSTACK : constant := 16#0001#;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := True;
- -- Indicates whether time slicing is supported (i.e SCHED_RR is supported)
-
- type timespec is private;
-
- function nanosleep (rqtp, rmtp : access timespec) return int;
- pragma Import (C, nanosleep, "nanosleep");
-
- type clockid_t is new int;
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
- pragma Import (C, clock_getres, "clock_getres");
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec)
- return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- type struct_timezone is record
- tz_minuteswest : int;
- tz_dsttime : int;
- end record;
- pragma Convention (C, struct_timezone);
-
- procedure usleep (useconds : unsigned_long);
- pragma Import (C, usleep, "usleep");
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 1;
- SCHED_OTHER : constant := 2;
- SCHED_RR : constant := 3;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- Self_PID : constant pid_t;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- type pthread_t is private;
- subtype Thread_Id is pthread_t;
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- PTHREAD_CREATE_DETACHED : constant := 1;
- PTHREAD_CREATE_JOINABLE : constant := 0;
-
- PTHREAD_SCOPE_PROCESS : constant := 0;
- PTHREAD_SCOPE_SYSTEM : constant := 2;
-
- -- Read/Write lock not supported on freebsd. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- subtype pthread_rwlock_t is pthread_mutex_t;
- subtype pthread_rwlockattr_t is pthread_mutexattr_t;
-
- -----------
- -- Stack --
- -----------
-
- type stack_t is record
- ss_sp : System.Address;
- ss_size : size_t;
- ss_flags : int;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- -- This is a dummy definition, never used (Alternate_Stack_Size is null)
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- function Get_Page_Size return int;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- Returns the size of a page
-
- PROT_NONE : constant := 0;
- PROT_READ : constant := 1;
- PROT_WRITE : constant := 2;
- PROT_EXEC : constant := 4;
- PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
- PROT_ON : constant := PROT_NONE;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- -- FSU_THREADS requires pthread_init, which is nonstandard and this should
- -- be invoked during the elaboration of s-taprop.adb.
-
- -- FreeBSD does not require this so we provide an empty Ada body
-
- procedure pthread_init;
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 2;
- PTHREAD_PRIO_INHERIT : constant := 1;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
-
- function pthread_mutexattr_getprotocol
- (attr : access pthread_mutexattr_t;
- protocol : access int) return int;
- pragma Import
- (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol");
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprioceiling,
- "pthread_mutexattr_setprioceiling");
-
- function pthread_mutexattr_getprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : access int) return int;
- pragma Import
- (C, pthread_mutexattr_getprioceiling,
- "pthread_mutexattr_getprioceiling");
-
- type struct_sched_param is record
- sched_priority : int;
- end record;
- pragma Convention (C, struct_sched_param);
-
- function pthread_getschedparam
- (thread : pthread_t;
- policy : access int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_getschedparam, "pthread_getschedparam");
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_getscope
- (attr : access pthread_attr_t;
- contentionscope : access int) return int;
- pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import
- (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
-
- function pthread_attr_getinheritsched
- (attr : access pthread_attr_t;
- inheritsched : access int) return int;
- pragma Import
- (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy,
- "pthread_attr_setschedpolicy");
-
- function pthread_attr_getschedpolicy
- (attr : access pthread_attr_t;
- policy : access int) return int;
- pragma Import (C, pthread_attr_getschedpolicy,
- "pthread_attr_getschedpolicy");
-
- function pthread_attr_setschedparam
- (attr : access pthread_attr_t;
- sched_param : int) return int;
- pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
-
- function pthread_attr_getschedparam
- (attr : access pthread_attr_t;
- sched_param : access int) return int;
- pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam");
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "pthread_yield");
-
- --------------------------
- -- P1003.1c Section 16 --
- --------------------------
-
- function pthread_attr_init (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import
- (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
-
- function pthread_attr_getdetachstate
- (attr : access pthread_attr_t;
- detachstate : access int) return int;
- pragma Import
- (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate");
-
- function pthread_attr_getstacksize
- (attr : access pthread_attr_t;
- stacksize : access size_t) return int;
- pragma Import
- (C, pthread_attr_getstacksize, "pthread_attr_getstacksize");
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import
- (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- function pthread_detach (thread : pthread_t) return int;
- pragma Import (C, pthread_detach, "pthread_detach");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- ------------------------------------
- -- Non-portable Pthread Functions --
- ------------------------------------
-
- function pthread_set_name_np
- (thread : pthread_t;
- name : System.Address) return int;
- pragma Import (C, pthread_set_name_np, "pthread_set_name_np");
-
-private
-
- type sigset_t is array (1 .. 4) of unsigned;
-
- -- In FreeBSD the component sa_handler turns out to
- -- be one a union type, and the selector is a macro:
- -- #define sa_handler __sigaction_u._handler
- -- #define sa_sigaction __sigaction_u._sigaction
-
- -- Should we add a signal_context type here ???
- -- How could it be done independent of the CPU architecture ???
- -- sigcontext type is opaque, so it is architecturally neutral.
- -- It is always passed as an access type, so define it as an empty record
- -- since the contents are not used anywhere.
-
- type struct_sigcontext is null record;
- pragma Convention (C, struct_sigcontext);
-
- type pid_t is new int;
- Self_PID : constant pid_t := 0;
-
- type time_t is new long;
-
- type timespec is record
- ts_sec : time_t;
- ts_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type pthread_t is new System.Address;
- type pthread_attr_t is new System.Address;
- type pthread_mutex_t is new System.Address;
- type pthread_mutexattr_t is new System.Address;
- type pthread_cond_t is new System.Address;
- type pthread_condattr_t is new System.Address;
- type pthread_key_t is new int;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2015-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the GNU/Hurd version of this package.
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-package body System.OS_Interface is
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
-
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- --------------------------------------
- -- pthread_mutexattr_setprioceiling --
- --------------------------------------
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int is
- pragma Unreferenced (attr, prioceiling);
- begin
- return 0;
- end pthread_mutexattr_setprioceiling;
-
- --------------------------------------
- -- pthread_mutexattr_getprioceiling --
- --------------------------------------
-
- function pthread_mutexattr_getprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : access int) return int is
- pragma Unreferenced (attr, prioceiling);
- begin
- return 0;
- end pthread_mutexattr_getprioceiling;
-
- ---------------------------
- -- pthread_setschedparam --
- ---------------------------
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int is
- pragma Unreferenced (thread, policy, param);
- begin
- return 0;
- end pthread_setschedparam;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the GNU/Hurd (POSIX Threads) version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package
-
-with Interfaces.C;
-with Unchecked_Conversion;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lpthread");
- pragma Linker_Options ("-lrt");
-
- subtype int is Interfaces.C.int;
- subtype char is Interfaces.C.char;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
- -- From /usr/include/i386-gnu/bits/errno.h
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 1073741859;
- EINTR : constant := 1073741828;
- EINVAL : constant := 1073741846;
- ENOMEM : constant := 1073741836;
- EPERM : constant := 1073741825;
- ETIMEDOUT : constant := 1073741884;
-
- -------------
- -- Signals --
- -------------
- -- From /usr/include/i386-gnu/bits/signum.h
-
- Max_Interrupt : constant := 32;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGPOLL : constant := 23; -- I/O possible (same as SIGIO?)
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD)
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
- SIGLOST : constant := 32; -- Resource lost (Sun); server died (GNU)
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set := (
- SIGTRAP,
- -- To enable debugging on multithreaded applications, mark SIGTRAP to
- -- be kept unmasked.
-
- SIGBUS,
-
- SIGTTIN, SIGTTOU, SIGTSTP,
- -- Keep these three signals unmasked so that background processes
- -- and IO behaves as normal "C" applications
-
- SIGPROF,
- -- To avoid confusing the profiler
-
- SIGKILL, SIGSTOP);
- -- These two signals actually cannot be masked;
- -- POSIX simply won't allow it.
-
- Reserved : constant Signal_Set :=
- -- I am not sure why the following signal is reserved.
- -- I guess they are not supported by this version of GNU/Hurd.
- (0 .. 0 => SIGVTALRM);
-
- type sigset_t is private;
-
- -- From /usr/include/signal.h /usr/include/i386-gnu/bits/sigset.h
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- -- sigcontext is architecture dependent, so define it private
- type struct_sigcontext is private;
-
- -- From /usr/include/i386-gnu/bits/sigaction.h: Note: arg. order differs
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
-
- type struct_sigaction_ptr is access all struct_sigaction;
-
- -- From /usr/include/i386-gnu/bits/sigaction.h
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- -- From /usr/include/i386-gnu/bits/signum.h
- SIG_ERR : constant := 1;
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
- SIG_HOLD : constant := 2;
-
- -- From /usr/include/i386-gnu/bits/sigaction.h
- SA_SIGINFO : constant := 16#0040#;
- SA_ONSTACK : constant := 16#0001#;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := True;
- -- Indicates whether time slicing is supported (i.e SCHED_RR is supported)
-
- type timespec is private;
-
- function nanosleep (rqtp, rmtp : access timespec) return int;
- pragma Import (C, nanosleep, "nanosleep");
-
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 0;
-
- -- From: /usr/include/time.h
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec)
- return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
- pragma Import (C, clock_getres, "clock_getres");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- -- From: /usr/include/unistd.h
- function sysconf (name : int) return long;
- pragma Import (C, sysconf);
-
- -- From /usr/include/i386-gnu/bits/confname.h
- SC_CLK_TCK : constant := 2;
- SC_NPROCESSORS_ONLN : constant := 84;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
- -- From /usr/include/i386-gnu/bits/sched.h
-
- SCHED_OTHER : constant := 0;
- SCHED_FIFO : constant := 1;
- SCHED_RR : constant := 2;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority.
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- -- From: /usr/include/signal.h
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- -- From: /usr/include/unistd.h
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- -- From: /usr/include/pthread/pthread.h
- function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Unchecked_Conversion (System.Address, Thread_Body);
-
- -- From: /usr/include/bits/pthread.h:typedef int __pthread_t;
- -- /usr/include/pthread/pthreadtypes.h:typedef __pthread_t pthread_t;
- type pthread_t is new unsigned_long;
- subtype Thread_Id is pthread_t;
-
- function To_pthread_t is new Unchecked_Conversion
- (unsigned_long, pthread_t);
-
- type pthread_mutex_t is limited private;
- type pthread_rwlock_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_rwlockattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- -- From /usr/include/pthread/pthreadtypes.h
- PTHREAD_CREATE_DETACHED : constant := 1;
- PTHREAD_CREATE_JOINABLE : constant := 0;
-
- PTHREAD_SCOPE_PROCESS : constant := 1;
- PTHREAD_SCOPE_SYSTEM : constant := 0;
-
- -----------
- -- Stack --
- -----------
-
- -- From: /usr/include/i386-gnu/bits/sigstack.h
- type stack_t is record
- ss_sp : System.Address;
- ss_size : size_t;
- ss_flags : int;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- -- This is a dummy definition, never used (Alternate_Stack_Size is null)
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- -- From: /usr/include/i386-gnu/bits/shm.h
- function Get_Page_Size return int;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- Returns the size of a page
-
- -- From /usr/include/i386-gnu/bits/mman.h
- PROT_NONE : constant := 0;
- PROT_READ : constant := 4;
- PROT_WRITE : constant := 2;
- PROT_EXEC : constant := 1;
- PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
- PROT_ON : constant := PROT_NONE;
- PROT_OFF : constant := PROT_ALL;
-
- -- From /usr/include/i386-gnu/bits/mman.h
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
- pragma Inline (pthread_init);
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- -- From: /usr/include/signal.h:
- -- sigwait (__const sigset_t *__restrict __set, int *__restrict __sig)
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- -- From: /usr/include/pthread/pthread.h:
- -- extern int pthread_kill (pthread_t thread, int signo);
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- -- From: /usr/include/i386-gnu/bits/sigthread.h
- -- extern int pthread_sigmask (int __how, __const __sigset_t *__newmask,
- -- __sigset_t *__oldmask) __THROW;
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- -- From: /usr/include/pthread/pthread.h and
- -- /usr/include/pthread/pthreadtypes.h
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_rwlockattr_init
- (attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init");
-
- function pthread_rwlockattr_destroy
- (attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy");
- PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0;
- PTHREAD_RWLOCK_PREFER_WRITER_NP : constant := 1;
- PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 2;
-
- function pthread_rwlockattr_setkind_np
- (attr : access pthread_rwlockattr_t;
- pref : int) return int;
- pragma Import
- (C, pthread_rwlockattr_setkind_np, "pthread_rwlockattr_setkind_np");
-
- function pthread_rwlock_init
- (mutex : access pthread_rwlock_t;
- attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init");
-
- function pthread_rwlock_destroy
- (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy");
-
- function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock");
-
- function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock");
-
- function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
- -- From /usr/include/pthread/pthreadtypes.h
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 2;
- PTHREAD_PRIO_INHERIT : constant := 1;
-
- -- GNU/Hurd does not support Thread Priority Protection or Thread
- -- Priority Inheritance and lacks some pthread_mutexattr_* functions.
- -- Replace them with dummy versions.
- -- From: /usr/include/pthread/pthread.h
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol,
- "pthread_mutexattr_setprotocol");
-
- function pthread_mutexattr_getprotocol
- (attr : access pthread_mutexattr_t;
- protocol : access int) return int;
- pragma Import (C, pthread_mutexattr_getprotocol,
- "pthread_mutexattr_getprotocol");
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
-
- function pthread_mutexattr_getprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : access int) return int;
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- end record;
- pragma Convention (C, struct_sched_param);
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_getscope
- (attr : access pthread_attr_t;
- contentionscope : access int) return int;
- pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import (C, pthread_attr_setinheritsched,
- "pthread_attr_setinheritsched");
-
- function pthread_attr_getinheritsched
- (attr : access pthread_attr_t;
- inheritsched : access int) return int;
- pragma Import (C, pthread_attr_getinheritsched,
- "pthread_attr_getinheritsched");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy, "pthread_setschedpolicy");
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "sched_yield");
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import
- (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- -- From: /usr/include/pthread/pthread.h
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- -- From /usr/include/i386-gnu/bits/sched.h
- CPU_SETSIZE : constant := 1_024;
-
- type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
- for bit_field'Size use CPU_SETSIZE;
- pragma Pack (bit_field);
- pragma Convention (C, bit_field);
-
- type cpu_set_t is record
- bits : bit_field;
- end record;
- pragma Convention (C, cpu_set_t);
-
-private
-
- type sigset_t is array (1 .. 4) of unsigned;
-
- -- In GNU/Hurd the component sa_handler turns out to
- -- be one a union type, and the selector is a macro:
- -- #define sa_handler __sigaction_handler.sa_handler
- -- #define sa_sigaction __sigaction_handler.sa_sigaction
-
- -- Should we add a signal_context type here ?
- -- How could it be done independent of the CPU architecture ?
- -- sigcontext type is opaque, so it is architecturally neutral.
- -- It is always passed as an access type, so define it as an empty record
- -- since the contents are not used anywhere.
- type struct_sigcontext is null record;
- pragma Convention (C, struct_sigcontext);
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- -- From: /usr/include/pthread/pthreadtypes.h:
- -- typedef struct __pthread_attr pthread_attr_t;
- -- /usr/include/i386-gnu/bits/thread-attr.h: struct __pthread_attr...
- -- /usr/include/pthread/pthreadtypes.h: enum __pthread_contentionscope
- -- enum __pthread_detachstate detachstate;
- -- enum __pthread_inheritsched inheritsched;
- -- enum __pthread_contentionscope contentionscope;
- -- Not used: schedpolicy : int;
- type pthread_attr_t is record
- schedparam : struct_sched_param;
- stackaddr : System.Address;
- stacksize : size_t;
- guardsize : size_t;
- detachstate : int;
- inheritsched : int;
- contentionscope : int;
- schedpolicy : int;
- end record;
- pragma Convention (C, pthread_attr_t);
-
- -- From: /usr/include/pthread/pthreadtypes.h:
- -- typedef struct __pthread_condattr pthread_condattr_t;
- -- From: /usr/include/i386-gnu/bits/condition-attr.h:
- -- struct __pthread_condattr {
- -- enum __pthread_process_shared pshared;
- -- __Clockid_T Clock;}
- -- From: /usr/include/pthread/pthreadtypes.h:
- -- enum __pthread_process_shared
- type pthread_condattr_t is record
- pshared : int;
- clock : clockid_t;
- end record;
- pragma Convention (C, pthread_condattr_t);
-
- -- From: /usr/include/pthread/pthreadtypes.h:
- -- typedef struct __pthread_mutexattr pthread_mutexattr_t; and
- -- /usr/include/i386-gnu/bits/mutex-attr.h
- -- struct __pthread_mutexattr {
- -- int prioceiling;
- -- enum __pthread_mutex_protocol protocol;
- -- enum __pthread_process_shared pshared;
- -- enum __pthread_mutex_type mutex_type;};
- type pthread_mutexattr_t is record
- prioceiling : int;
- protocol : int;
- pshared : int;
- mutex_type : int;
- end record;
- pragma Convention (C, pthread_mutexattr_t);
-
- -- From: /usr/include/pthread/pthreadtypes.h
- -- typedef struct __pthread_mutex pthread_mutex_t; and
- -- /usr/include/i386-gnu/bits/mutex.h:
- -- struct __pthread_mutex {
- -- __pthread_spinlock_t __held;
- -- __pthread_spinlock_t __lock;
- -- /* in cthreads, mutex_init does not initialized the third
- -- pointer, as such, we cannot rely on its value for anything. */
- -- char *cthreadscompat1;
- -- struct __pthread *__queue;
- -- struct __pthread_mutexattr *attr;
- -- void *data;
- -- /* up to this point, we are completely compatible with cthreads
- -- and what libc expects. */
- -- void *owner;
- -- unsigned locks;
- -- /* if null then the default attributes apply. */
- -- };
-
- type pthread_mutex_t is record
- held : int;
- lock : int;
- cthreadcompat : System.Address;
- queue : System.Address;
- attr : System.Address;
- data : System.Address;
- owner : System.Address;
- locks : unsigned;
- end record;
- pragma Convention (C, pthread_mutex_t);
- -- pointer needed?
- -- type pthread_mutex_t_ptr is access pthread_mutex_t;
-
- -- From: /usr/include/pthread/pthreadtypes.h:
- -- typedef struct __pthread_cond pthread_cond_t;
- -- typedef struct __pthread_condattr pthread_condattr_t;
- -- /usr/include/i386-gnu/bits/condition.h:struct __pthread_cond{}
- -- pthread_condattr_t: see above!
- -- /usr/include/i386-gnu/bits/condition.h:
- -- struct __pthread_condimpl *__impl;
-
- type pthread_cond_t is record
- lock : int;
- queue : System.Address;
- condattr : System.Address;
- impl : System.Address;
- data : System.Address;
- end record;
- pragma Convention (C, pthread_cond_t);
-
- -- From: /usr/include/pthread/pthreadtypes.h:
- -- typedef __pthread_key pthread_key_t; and
- -- /usr/include/i386-gnu/bits/thread-specific.h:
- -- typedef int __pthread_key;
-
- type pthread_key_t is new int;
-
- -- From: /usr/include/i386-gnu/bits/rwlock-attr.h:
- -- struct __pthread_rwlockattr {
- -- enum __pthread_process_shared pshared; };
-
- type pthread_rwlockattr_t is record
- pshared : int;
- end record;
- pragma Convention (C, pthread_rwlockattr_t);
-
- -- From: /usr/include/i386-gnu/bits/rwlock.h:
- -- struct __pthread_rwlock {
- -- __pthread_spinlock_t __held;
- -- __pthread_spinlock_t __lock;
- -- int readers;
- -- struct __pthread *readerqueue;
- -- struct __pthread *writerqueue;
- -- struct __pthread_rwlockattr *__attr;
- -- void *__data; };
-
- type pthread_rwlock_t is record
- held : int;
- lock : int;
- readers : int;
- readerqueue : System.Address;
- writerqueue : System.Address;
- attr : pthread_rwlockattr_t;
- data : int;
- end record;
- pragma Convention (C, pthread_rwlock_t);
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2010, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a DCE version of this package.
--- Currently HP-UX and SNI use this file
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-with Interfaces.C; use Interfaces.C;
-
-package body System.OS_Interface is
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int
- is
- Result : int;
-
- begin
- Result := sigwait (set);
-
- if Result = -1 then
- sig.all := 0;
- return errno;
- end if;
-
- sig.all := Signal (Result);
- return 0;
- end sigwait;
-
- -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int is
- pragma Unreferenced (thread, sig);
- begin
- return 0;
- end pthread_kill;
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- -- For all following functions, DCE Threads has a non standard behavior.
- -- It sets errno but the standard Posix requires it to be returned.
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int
- is
- function pthread_mutexattr_create
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create");
-
- begin
- if pthread_mutexattr_create (attr) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutexattr_init;
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int
- is
- function pthread_mutexattr_delete
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete");
-
- begin
- if pthread_mutexattr_delete (attr) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutexattr_destroy;
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int
- is
- function pthread_mutex_init_base
- (mutex : access pthread_mutex_t;
- attr : pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init");
-
- begin
- if pthread_mutex_init_base (mutex, attr.all) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutex_init;
-
- function pthread_mutex_destroy
- (mutex : access pthread_mutex_t) return int
- is
- function pthread_mutex_destroy_base
- (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy");
-
- begin
- if pthread_mutex_destroy_base (mutex) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutex_destroy;
-
- function pthread_mutex_lock
- (mutex : access pthread_mutex_t) return int
- is
- function pthread_mutex_lock_base
- (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock");
-
- begin
- if pthread_mutex_lock_base (mutex) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutex_lock;
-
- function pthread_mutex_unlock
- (mutex : access pthread_mutex_t) return int
- is
- function pthread_mutex_unlock_base
- (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock");
-
- begin
- if pthread_mutex_unlock_base (mutex) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_mutex_unlock;
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int
- is
- function pthread_condattr_create
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_create, "pthread_condattr_create");
-
- begin
- if pthread_condattr_create (attr) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_condattr_init;
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int
- is
- function pthread_condattr_delete
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete");
-
- begin
- if pthread_condattr_delete (attr) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_condattr_destroy;
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int
- is
- function pthread_cond_init_base
- (cond : access pthread_cond_t;
- attr : pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init_base, "pthread_cond_init");
-
- begin
- if pthread_cond_init_base (cond, attr.all) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_cond_init;
-
- function pthread_cond_destroy
- (cond : access pthread_cond_t) return int
- is
- function pthread_cond_destroy_base
- (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy");
-
- begin
- if pthread_cond_destroy_base (cond) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_cond_destroy;
-
- function pthread_cond_signal
- (cond : access pthread_cond_t) return int
- is
- function pthread_cond_signal_base
- (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal");
-
- begin
- if pthread_cond_signal_base (cond) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_cond_signal;
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int
- is
- function pthread_cond_wait_base
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait");
-
- begin
- if pthread_cond_wait_base (cond, mutex) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_cond_wait;
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int
- is
- function pthread_cond_timedwait_base
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
-
- begin
- if pthread_cond_timedwait_base (cond, mutex, abstime) /= 0 then
- return (if errno = EAGAIN then ETIMEDOUT else errno);
- else
- return 0;
- end if;
- end pthread_cond_timedwait;
-
- ----------------------------
- -- POSIX.1c Section 13 --
- ----------------------------
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int
- is
- function pthread_setscheduler
- (thread : pthread_t;
- policy : int;
- priority : int) return int;
- pragma Import (C, pthread_setscheduler, "pthread_setscheduler");
-
- begin
- if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then
- return errno;
- else
- return 0;
- end if;
- end pthread_setschedparam;
-
- function sched_yield return int is
- procedure pthread_yield;
- pragma Import (C, pthread_yield, "pthread_yield");
- begin
- pthread_yield;
- return 0;
- end sched_yield;
-
- -----------------------------
- -- P1003.1c - Section 16 --
- -----------------------------
-
- function pthread_attr_init
- (attributes : access pthread_attr_t) return int
- is
- function pthread_attr_create
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_create, "pthread_attr_create");
-
- begin
- if pthread_attr_create (attributes) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_attr_init;
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int
- is
- function pthread_attr_delete
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_delete, "pthread_attr_delete");
-
- begin
- if pthread_attr_delete (attributes) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_attr_destroy;
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int
- is
- function pthread_attr_setstacksize_base
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize_base,
- "pthread_attr_setstacksize");
-
- begin
- if pthread_attr_setstacksize_base (attr, stacksize) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_attr_setstacksize;
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int
- is
- function pthread_create_base
- (thread : access pthread_t;
- attributes : pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create_base, "pthread_create");
-
- begin
- if pthread_create_base
- (thread, attributes.all, start_routine, arg) /= 0
- then
- return errno;
- else
- return 0;
- end if;
- end pthread_create;
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int
- is
- function pthread_setspecific_base
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific_base, "pthread_setspecific");
-
- begin
- if pthread_setspecific_base (key, value) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_setspecific;
-
- function pthread_getspecific (key : pthread_key_t) return System.Address is
- function pthread_getspecific_base
- (key : pthread_key_t;
- value : access System.Address) return int;
- pragma Import (C, pthread_getspecific_base, "pthread_getspecific");
- Addr : aliased System.Address;
-
- begin
- if pthread_getspecific_base (key, Addr'Access) /= 0 then
- return System.Null_Address;
- else
- return Addr;
- end if;
- end pthread_getspecific;
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int
- is
- function pthread_keycreate
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_keycreate, "pthread_keycreate");
-
- begin
- if pthread_keycreate (key, destructor) /= 0 then
- return errno;
- else
- return 0;
- end if;
- end pthread_key_create;
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- function intr_attach (sig : int; handler : isr_address) return long is
- function c_signal (sig : int; handler : isr_address) return long;
- pragma Import (C, c_signal, "signal");
- begin
- return c_signal (sig, handler);
- end intr_attach;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2012, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the HP-UX version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lcma");
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIME : constant := 52;
- ETIMEDOUT : constant := 238;
-
- FUNC_ERR : constant := -1;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 44;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
- SIGCLD : constant := 18; -- alias for SIGCHLD
- SIGCHLD : constant := 18; -- child status change
- SIGPWR : constant := 19; -- power-fail restart
- SIGVTALRM : constant := 20; -- virtual timer alarm
- SIGPROF : constant := 21; -- profiling timer alarm
- SIGIO : constant := 22; -- asynchronous I/O
- SIGPOLL : constant := 22; -- pollable event occurred
- SIGWINCH : constant := 23; -- window size change
- SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 25; -- user stop requested from tty
- SIGCONT : constant := 26; -- stopped process has been continued
- SIGTTIN : constant := 27; -- background tty read attempted
- SIGTTOU : constant := 28; -- background tty write attempted
- SIGURG : constant := 29; -- urgent condition on IO channel
- SIGLOST : constant := 30; -- remote lock lost (NFS)
- SIGDIL : constant := 32; -- DIL signal
- SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit)
- SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit)
-
- SIGADAABORT : constant := SIGABRT;
- -- Note: on other targets, we usually use SIGABRT, but on HP/UX, it
- -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set :=
- (SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP);
-
- Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
-
- type sigset_t is private;
-
- type isr_address is access procedure (sig : int);
- pragma Convention (C, isr_address);
-
- function intr_attach (sig : int; handler : isr_address) return long;
-
- Intr_Attach_Reset : constant Boolean := True;
- -- True if intr_attach is reset after an interrupt handler is called
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type Signal_Handler is access procedure (signo : Signal);
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SA_RESTART : constant := 16#40#;
- SA_SIGINFO : constant := 16#10#;
- SA_ONSTACK : constant := 16#01#;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
- SIG_ERR : constant := -1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- type timespec is private;
-
- function nanosleep (rqtp, rmtp : access timespec) return int;
- pragma Import (C, nanosleep);
-
- type clockid_t is new int;
-
- function Clock_Gettime
- (Clock_Id : clockid_t; Tp : access timespec) return int;
- pragma Import (C, Clock_Gettime);
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 0;
- SCHED_RR : constant := 1;
- SCHED_OTHER : constant := 2;
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- type pthread_t is private;
- subtype Thread_Id is pthread_t;
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- -- Read/Write lock not supported on HPUX. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- subtype pthread_rwlock_t is pthread_mutex_t;
- subtype pthread_rwlockattr_t is pthread_mutexattr_t;
-
- -----------
- -- Stack --
- -----------
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- This is a dummy procedure to share some GNULLI files
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
- pragma Inline (pthread_init);
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t) return int;
- pragma Import (C, sigwait, "cma_sigwait");
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Inline (sigwait);
- -- DCE_THREADS has a nonstandard sigwait
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Inline (pthread_kill);
- -- DCE_THREADS doesn't have pthread_kill
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- -- DCE THREADS does not have pthread_sigmask. Instead, it uses sigprocmask
- -- to do the signal handling when the thread library is sucked in.
- pragma Import (C, pthread_sigmask, "sigprocmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- -- DCE_THREADS has a nonstandard pthread_mutexattr_init
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- -- DCE_THREADS has a nonstandard pthread_mutexattr_destroy
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- -- DCE_THREADS has a nonstandard pthread_mutex_init
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- -- DCE_THREADS has a nonstandard pthread_mutex_destroy
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Inline (pthread_mutex_lock);
- -- DCE_THREADS has nonstandard pthread_mutex_lock
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Inline (pthread_mutex_unlock);
- -- DCE_THREADS has nonstandard pthread_mutex_lock
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- -- DCE_THREADS has nonstandard pthread_condattr_init
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- -- DCE_THREADS has nonstandard pthread_condattr_destroy
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- -- DCE_THREADS has nonstandard pthread_cond_init
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- -- DCE_THREADS has nonstandard pthread_cond_destroy
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Inline (pthread_cond_signal);
- -- DCE_THREADS has nonstandard pthread_cond_signal
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Inline (pthread_cond_wait);
- -- DCE_THREADS has a nonstandard pthread_cond_wait
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Inline (pthread_cond_timedwait);
- -- DCE_THREADS has a nonstandard pthread_cond_timedwait
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- end record;
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Inline (pthread_setschedparam);
- -- DCE_THREADS has a nonstandard pthread_setschedparam
-
- function sched_yield return int;
- pragma Inline (sched_yield);
- -- DCE_THREADS has a nonstandard sched_yield
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init (attributes : access pthread_attr_t) return int;
- pragma Inline (pthread_attr_init);
- -- DCE_THREADS has a nonstandard pthread_attr_init
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Inline (pthread_attr_destroy);
- -- DCE_THREADS has a nonstandard pthread_attr_destroy
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Inline (pthread_attr_setstacksize);
- -- DCE_THREADS has a nonstandard pthread_attr_setstacksize
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Inline (pthread_create);
- -- DCE_THREADS has a nonstandard pthread_create
-
- procedure pthread_detach (thread : access pthread_t);
- pragma Import (C, pthread_detach);
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Inline (pthread_setspecific);
- -- DCE_THREADS has a nonstandard pthread_setspecific
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Inline (pthread_getspecific);
- -- DCE_THREADS has a nonstandard pthread_getspecific
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Inline (pthread_key_create);
- -- DCE_THREADS has a nonstandard pthread_key_create
-
-private
-
- type array_type_1 is array (Integer range 0 .. 7) of unsigned_long;
- type sigset_t is record
- X_X_sigbits : array_type_1;
- end record;
- pragma Convention (C, sigset_t);
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- CLOCK_REALTIME : constant clockid_t := 1;
-
- type cma_t_address is new System.Address;
-
- type cma_t_handle is record
- field1 : cma_t_address;
- field2 : Short_Integer;
- field3 : Short_Integer;
- end record;
- for cma_t_handle'Size use 64;
-
- type pthread_attr_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_attr_t);
-
- type pthread_condattr_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_condattr_t);
-
- type pthread_mutexattr_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_mutexattr_t);
-
- type pthread_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_t);
-
- type pthread_mutex_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_mutex_t);
-
- type pthread_cond_t is new cma_t_handle;
- pragma Convention (C_Pass_By_Copy, pthread_cond_t);
-
- type pthread_key_t is new int;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2015, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a HPUX 11.0 (Native THREADS) version of this package
-
--- This package encapsulates all direct interfaces to OS services that are
--- needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lpthread");
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIMEDOUT : constant := 238;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 44;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
- SIGCLD : constant := 18; -- alias for SIGCHLD
- SIGCHLD : constant := 18; -- child status change
- SIGPWR : constant := 19; -- power-fail restart
- SIGVTALRM : constant := 20; -- virtual timer alarm
- SIGPROF : constant := 21; -- profiling timer alarm
- SIGIO : constant := 22; -- asynchronous I/O
- SIGPOLL : constant := 22; -- pollable event occurred
- SIGWINCH : constant := 23; -- window size change
- SIGSTOP : constant := 24; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 25; -- user stop requested from tty
- SIGCONT : constant := 26; -- stopped process has been continued
- SIGTTIN : constant := 27; -- background tty read attempted
- SIGTTOU : constant := 28; -- background tty write attempted
- SIGURG : constant := 29; -- urgent condition on IO channel
- SIGLOST : constant := 30; -- remote lock lost (NFS)
- SIGDIL : constant := 32; -- DIL signal
- SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit)
- SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit)
- SIGCANCEL : constant := 35; -- used for pthread cancellation.
- SIGGFAULT : constant := 36; -- Graphics framebuffer fault
-
- SIGADAABORT : constant := SIGABRT;
- -- Note: on other targets, we usually use SIGABRT, but on HPUX, it
- -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM.
- -- Do we use SIGTERM or SIGABRT???
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set :=
- (SIGABRT, SIGPIPE, SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF,
- SIGALRM, SIGVTALRM, SIGIO, SIGCHLD);
-
- Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SA_SIGINFO : constant := 16#10#;
- SA_ONSTACK : constant := 16#01#;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := True;
- -- Indicates whether time slicing is supported
-
- type timespec is private;
-
- type clockid_t is new int;
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec) return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
- pragma Import (C, clock_getres, "clock_getres");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- type struct_timezone is record
- tz_minuteswest : int;
- tz_dsttime : int;
- end record;
- pragma Convention (C, struct_timezone);
- type struct_timezone_ptr is access all struct_timezone;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 0;
- SCHED_RR : constant := 1;
- SCHED_OTHER : constant := 2;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- pragma Import (C, lwp_self, "_lwp_self");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- type pthread_t is private;
- subtype Thread_Id is pthread_t;
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- PTHREAD_CREATE_DETACHED : constant := 16#de#;
-
- PTHREAD_SCOPE_PROCESS : constant := 2;
- PTHREAD_SCOPE_SYSTEM : constant := 1;
-
- -- Read/Write lock not supported on HPUX. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- subtype pthread_rwlock_t is pthread_mutex_t;
- subtype pthread_rwlockattr_t is pthread_mutexattr_t;
-
- -----------
- -- Stack --
- -----------
-
- type stack_t is record
- ss_sp : System.Address;
- ss_flags : int;
- ss_size : size_t;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
- -- The alternate signal stack for stack overflows
-
- Alternate_Stack_Size : constant := 128 * 1024;
- -- This must be in keeping with init.c:__gnat_alternate_stack
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- Returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- function Get_Page_Size return int;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- Returns the size of a page
-
- PROT_NONE : constant := 0;
- PROT_READ : constant := 1;
- PROT_WRITE : constant := 2;
- PROT_EXEC : constant := 4;
- PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
- PROT_ON : constant := PROT_READ;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
- pragma Inline (pthread_init);
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 16#100#;
- PTHREAD_PRIO_PROTECT : constant := 16#200#;
- PTHREAD_PRIO_INHERIT : constant := 16#400#;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol);
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import (C, pthread_mutexattr_setprioceiling);
-
- type Array_7_Int is array (0 .. 6) of int;
- type struct_sched_param is record
- sched_priority : int;
- sched_reserved : Array_7_Int;
- end record;
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param)
- return int;
- pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import (C, pthread_attr_setinheritsched);
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy);
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "sched_yield");
-
- --------------------------
- -- P1003.1c Section 16 --
- --------------------------
-
- function pthread_attr_init
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "__pthread_attr_init_system");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import (C, pthread_attr_setdetachstate);
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "__pthread_create_system");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
-private
-
- type unsigned_int_array_8 is array (0 .. 7) of unsigned;
- type sigset_t is record
- sigset : unsigned_int_array_8;
- end record;
- pragma Convention (C_Pass_By_Copy, sigset_t);
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type pthread_attr_t is new int;
- type pthread_condattr_t is new int;
- type pthread_mutexattr_t is new int;
- type pthread_t is new int;
-
- type short_array is array (Natural range <>) of short;
- type int_array is array (Natural range <>) of int;
-
- type pthread_mutex_t is record
- m_short : short_array (0 .. 1);
- m_int : int;
- m_int1 : int_array (0 .. 3);
- m_pad : int;
-
- m_ptr : int;
- -- actually m_ptr is a void*, and on 32 bit ABI, m_pad is added so that
- -- this field takes 64 bits. On 64 bit ABI, m_pad is gone, and m_ptr is
- -- a 64 bit void*. Assume int'Size = 32.
-
- m_int2 : int_array (0 .. 1);
- m_int3 : int_array (0 .. 3);
- m_short2 : short_array (0 .. 1);
- m_int4 : int_array (0 .. 4);
- m_int5 : int_array (0 .. 1);
- end record;
- for pthread_mutex_t'Alignment use System.Address'Alignment;
- pragma Convention (C, pthread_mutex_t);
-
- type pthread_cond_t is record
- c_short : short_array (0 .. 1);
- c_int : int;
- c_int1 : int_array (0 .. 3);
- m_pad : int;
- m_ptr : int; -- see comment in pthread_mutex_t
- c_int2 : int_array (0 .. 1);
- c_int3 : int_array (0 .. 1);
- c_int4 : int_array (0 .. 1);
- end record;
- for pthread_cond_t'Alignment use System.Address'Alignment;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_key_t is new int;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the GNU/kFreeBSD (POSIX Threads) version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package
-
-with Interfaces.C;
-with Unchecked_Conversion;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lpthread");
-
- subtype int is Interfaces.C.int;
- subtype char is Interfaces.C.char;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 35;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- EPERM : constant := 1;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 128;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGWINCH : constant := 28; -- window size change
- SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD)
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
- SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
- SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
- SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set := (
- SIGTRAP,
- -- To enable debugging on multithreaded applications, mark SIGTRAP to
- -- be kept unmasked.
-
- SIGBUS,
-
- SIGTTIN, SIGTTOU, SIGTSTP,
- -- Keep these three signals unmasked so that background processes
- -- and IO behaves as normal "C" applications
-
- SIGPROF,
- -- To avoid confusing the profiler
-
- SIGKILL, SIGSTOP,
- -- These two signals actually cannot be masked;
- -- POSIX simply won't allow it.
-
- SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG);
- -- These three signals are used by GNU/LinuxThreads starting from
- -- glibc 2.1 (future 2.2).
-
- Reserved : constant Signal_Set :=
- -- I am not sure why the following signal is reserved.
- -- I guess they are not supported by this version of GNU/kFreeBSD.
- (0 .. 0 => SIGVTALRM);
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- -- sigcontext is architecture dependent, so define it private
- type struct_sigcontext is private;
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_flags : int;
- sa_mask : sigset_t;
- end record;
- pragma Convention (C, struct_sigaction);
-
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- SA_SIGINFO : constant := 16#0040#;
- SA_ONSTACK : constant := 16#0001#;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := True;
- -- Indicates whether time slicing is supported (i.e SCHED_RR is supported)
-
- type timespec is private;
-
- function nanosleep (rqtp, rmtp : access timespec) return int;
- pragma Import (C, nanosleep, "nanosleep");
-
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec)
- return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
- pragma Import (C, clock_getres, "clock_getres");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- function sysconf (name : int) return long;
- pragma Import (C, sysconf);
-
- SC_CLK_TCK : constant := 2;
- SC_NPROCESSORS_ONLN : constant := 84;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 1;
- SCHED_OTHER : constant := 2;
- SCHED_RR : constant := 3;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority.
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Unchecked_Conversion (System.Address, Thread_Body);
-
- type pthread_t is new unsigned_long;
- subtype Thread_Id is pthread_t;
-
- function To_pthread_t is new Unchecked_Conversion
- (unsigned_long, pthread_t);
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- PTHREAD_CREATE_DETACHED : constant := 1;
- PTHREAD_CREATE_JOINABLE : constant := 0;
-
- PTHREAD_SCOPE_PROCESS : constant := 0;
- PTHREAD_SCOPE_SYSTEM : constant := 2;
-
- -- Read/Write lock not supported on kfreebsd. To add support both types
- -- pthread_rwlock_t and pthread_rwlockattr_t must properly be defined
- -- with the associated routines pthread_rwlock_[init/destroy] and
- -- pthread_rwlock_[rdlock/wrlock/unlock].
-
- subtype pthread_rwlock_t is pthread_mutex_t;
- subtype pthread_rwlockattr_t is pthread_mutexattr_t;
-
- -----------
- -- Stack --
- -----------
-
- type stack_t is record
- ss_sp : System.Address;
- ss_size : size_t;
- ss_flags : int;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- -- This is a dummy definition, never used (Alternate_Stack_Size is null)
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread. Only call this function
- -- when Stack_Base_Available is True.
-
- function Get_Page_Size return int;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- Returns the size of a page
-
- PROT_NONE : constant := 0;
- PROT_READ : constant := 1;
- PROT_WRITE : constant := 2;
- PROT_EXEC : constant := 4;
- PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
- PROT_ON : constant := PROT_NONE;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
- pragma Inline (pthread_init);
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 2;
- PTHREAD_PRIO_INHERIT : constant := 1;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol");
-
- function pthread_mutexattr_getprotocol
- (attr : access pthread_mutexattr_t;
- protocol : access int) return int;
- pragma Import
- (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol");
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprioceiling,
- "pthread_mutexattr_setprioceiling");
-
- function pthread_mutexattr_getprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : access int) return int;
- pragma Import
- (C, pthread_mutexattr_getprioceiling,
- "pthread_mutexattr_getprioceiling");
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- end record;
- pragma Convention (C, struct_sched_param);
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_getscope
- (attr : access pthread_attr_t;
- contentionscope : access int) return int;
- pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import
- (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched");
-
- function pthread_attr_getinheritsched
- (attr : access pthread_attr_t;
- inheritsched : access int) return int;
- pragma Import
- (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import
- (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy");
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "sched_yield");
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import
- (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- CPU_SETSIZE : constant := 1_024;
-
- type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
- for bit_field'Size use CPU_SETSIZE;
- pragma Pack (bit_field);
- pragma Convention (C, bit_field);
-
- type cpu_set_t is record
- bits : bit_field;
- end record;
- pragma Convention (C, cpu_set_t);
-
- function pthread_setaffinity_np
- (thread : pthread_t;
- cpusetsize : size_t;
- cpuset : access cpu_set_t) return int;
- pragma Import (C, pthread_setaffinity_np, "__gnat_pthread_setaffinity_np");
-
-private
-
- type sigset_t is array (1 .. 4) of unsigned;
-
- -- In FreeBSD the component sa_handler turns out to
- -- be one a union type, and the selector is a macro:
- -- #define sa_handler __sigaction_u._handler
- -- #define sa_sigaction __sigaction_u._sigaction
-
- -- Should we add a signal_context type here ?
- -- How could it be done independent of the CPU architecture ?
- -- sigcontext type is opaque, so it is architecturally neutral.
- -- It is always passed as an access type, so define it as an empty record
- -- since the contents are not used anywhere.
- type struct_sigcontext is null record;
- pragma Convention (C, struct_sigcontext);
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 0;
-
- type pthread_attr_t is record
- detachstate : int;
- schedpolicy : int;
- schedparam : struct_sched_param;
- inheritsched : int;
- scope : int;
- guardsize : size_t;
- stackaddr_set : int;
- stackaddr : System.Address;
- stacksize : size_t;
- end record;
- pragma Convention (C, pthread_attr_t);
-
- type pthread_condattr_t is record
- dummy : int;
- end record;
- pragma Convention (C, pthread_condattr_t);
-
- type pthread_mutexattr_t is record
- mutexkind : int;
- end record;
- pragma Convention (C, pthread_mutexattr_t);
-
- type struct_pthread_fast_lock is record
- status : long;
- spinlock : int;
- end record;
- pragma Convention (C, struct_pthread_fast_lock);
-
- type pthread_mutex_t is record
- m_reserved : int;
- m_count : int;
- m_owner : System.Address;
- m_kind : int;
- m_lock : struct_pthread_fast_lock;
- end record;
- pragma Convention (C, pthread_mutex_t);
-
- type pthread_cond_t is array (0 .. 47) of unsigned_char;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_key_t is new unsigned;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a GNU/Linux (GNU/LinuxThreads) version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-with Interfaces.C;
-with System.Linux;
-with System.OS_Constants;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lpthread");
- pragma Linker_Options ("-lrt");
- -- Needed for clock_getres with glibc versions prior to 2.17
-
- subtype int is Interfaces.C.int;
- subtype char is Interfaces.C.char;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := System.Linux.EAGAIN;
- EINTR : constant := System.Linux.EINTR;
- EINVAL : constant := System.Linux.EINVAL;
- ENOMEM : constant := System.Linux.ENOMEM;
- EPERM : constant := System.Linux.EPERM;
- ETIMEDOUT : constant := System.Linux.ETIMEDOUT;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 63;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := System.Linux.SIGHUP;
- SIGINT : constant := System.Linux.SIGINT;
- SIGQUIT : constant := System.Linux.SIGQUIT;
- SIGILL : constant := System.Linux.SIGILL;
- SIGTRAP : constant := System.Linux.SIGTRAP;
- SIGIOT : constant := System.Linux.SIGIOT;
- SIGABRT : constant := System.Linux.SIGABRT;
- SIGFPE : constant := System.Linux.SIGFPE;
- SIGKILL : constant := System.Linux.SIGKILL;
- SIGBUS : constant := System.Linux.SIGBUS;
- SIGSEGV : constant := System.Linux.SIGSEGV;
- SIGPIPE : constant := System.Linux.SIGPIPE;
- SIGALRM : constant := System.Linux.SIGALRM;
- SIGTERM : constant := System.Linux.SIGTERM;
- SIGUSR1 : constant := System.Linux.SIGUSR1;
- SIGUSR2 : constant := System.Linux.SIGUSR2;
- SIGCLD : constant := System.Linux.SIGCLD;
- SIGCHLD : constant := System.Linux.SIGCHLD;
- SIGPWR : constant := System.Linux.SIGPWR;
- SIGWINCH : constant := System.Linux.SIGWINCH;
- SIGURG : constant := System.Linux.SIGURG;
- SIGPOLL : constant := System.Linux.SIGPOLL;
- SIGIO : constant := System.Linux.SIGIO;
- SIGLOST : constant := System.Linux.SIGLOST;
- SIGSTOP : constant := System.Linux.SIGSTOP;
- SIGTSTP : constant := System.Linux.SIGTSTP;
- SIGCONT : constant := System.Linux.SIGCONT;
- SIGTTIN : constant := System.Linux.SIGTTIN;
- SIGTTOU : constant := System.Linux.SIGTTOU;
- SIGVTALRM : constant := System.Linux.SIGVTALRM;
- SIGPROF : constant := System.Linux.SIGPROF;
- SIGXCPU : constant := System.Linux.SIGXCPU;
- SIGXFSZ : constant := System.Linux.SIGXFSZ;
- SIGUNUSED : constant := System.Linux.SIGUNUSED;
- SIGSTKFLT : constant := System.Linux.SIGSTKFLT;
- SIGLTHRRES : constant := System.Linux.SIGLTHRRES;
- SIGLTHRCAN : constant := System.Linux.SIGLTHRCAN;
- SIGLTHRDBG : constant := System.Linux.SIGLTHRDBG;
-
- SIGADAABORT : constant := SIGABRT;
- -- Change this to use another signal for task abort. SIGTERM might be a
- -- good one.
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set := (
- SIGTRAP,
- -- To enable debugging on multithreaded applications, mark SIGTRAP to
- -- be kept unmasked.
-
- SIGBUS,
-
- SIGTTIN, SIGTTOU, SIGTSTP,
- -- Keep these three signals unmasked so that background processes and IO
- -- behaves as normal "C" applications
-
- SIGPROF,
- -- To avoid confusing the profiler
-
- SIGKILL, SIGSTOP,
- -- These two signals actually can't be masked (POSIX won't allow it)
-
- SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG);
- -- These three signals are used by GNU/LinuxThreads starting from glibc
- -- 2.1 (future 2.2).
-
- Reserved : constant Signal_Set := (SIGVTALRM, SIGUNUSED);
- -- Not clear why these two signals are reserved. Perhaps they are not
- -- supported by this version of GNU/Linux ???
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type union_type_3 is new String (1 .. 116);
- type siginfo_t is record
- si_signo : int;
- si_code : int;
- si_errno : int;
- X_data : union_type_3;
- end record;
- pragma Convention (C, siginfo_t);
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- sa_restorer : System.Address;
- end record;
- pragma Convention (C, struct_sigaction);
-
- type struct_sigaction_ptr is access all struct_sigaction;
-
- type Machine_State is record
- eip : unsigned_long;
- ebx : unsigned_long;
- esp : unsigned_long;
- ebp : unsigned_long;
- esi : unsigned_long;
- edi : unsigned_long;
- end record;
- type Machine_State_Ptr is access all Machine_State;
-
- SA_SIGINFO : constant := System.Linux.SA_SIGINFO;
- SA_ONSTACK : constant := System.Linux.SA_ONSTACK;
-
- SIG_BLOCK : constant := 0;
- SIG_UNBLOCK : constant := 1;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- subtype time_t is System.Linux.time_t;
- subtype timespec is System.Linux.timespec;
- subtype timeval is System.Linux.timeval;
- subtype clockid_t is System.Linux.clockid_t;
-
- function clock_gettime
- (clock_id : clockid_t; tp : access timespec) return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
- pragma Import (C, clock_getres, "clock_getres");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- function sysconf (name : int) return long;
- pragma Import (C, sysconf);
-
- SC_CLK_TCK : constant := 2;
- SC_NPROCESSORS_ONLN : constant := 84;
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_OTHER : constant := 0;
- SCHED_FIFO : constant := 1;
- SCHED_RR : constant := 2;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- PR_SET_NAME : constant := 15;
- PR_GET_NAME : constant := 16;
-
- function prctl
- (option : int;
- arg2, arg3, arg4, arg5 : unsigned_long := 0) return int;
- pragma Import (C, prctl);
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- type pthread_t is new unsigned_long;
- subtype Thread_Id is pthread_t;
-
- function To_pthread_t is
- new Ada.Unchecked_Conversion (unsigned_long, pthread_t);
-
- type pthread_mutex_t is limited private;
- type pthread_rwlock_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_rwlockattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- PTHREAD_CREATE_DETACHED : constant := 1;
-
- -----------
- -- Stack --
- -----------
-
- type stack_t is record
- ss_sp : System.Address;
- ss_flags : int;
- ss_size : size_t;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
- pragma Import (C, sigaltstack, "sigaltstack");
-
- Alternate_Stack : aliased System.Address;
- pragma Import (C, Alternate_Stack, "__gnat_alternate_stack");
- -- The alternate signal stack for stack overflows
-
- Alternate_Stack_Size : constant := 16 * 1024;
- -- This must be in keeping with init.c:__gnat_alternate_stack
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- This is a dummy procedure to share some GNULLI files
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
- pragma Inline (pthread_init);
- -- This is a dummy procedure to share some GNULLI files
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_rwlockattr_init
- (attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init");
-
- function pthread_rwlockattr_destroy
- (attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy");
-
- PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0;
- PTHREAD_RWLOCK_PREFER_WRITER_NP : constant := 1;
- PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 2;
-
- function pthread_rwlockattr_setkind_np
- (attr : access pthread_rwlockattr_t;
- pref : int) return int;
- pragma Import
- (C, pthread_rwlockattr_setkind_np, "pthread_rwlockattr_setkind_np");
-
- function pthread_rwlock_init
- (mutex : access pthread_rwlock_t;
- attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init");
-
- function pthread_rwlock_destroy
- (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy");
-
- function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock");
-
- function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock");
-
- function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_INHERIT : constant := 1;
- PTHREAD_PRIO_PROTECT : constant := 2;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol);
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import (C, pthread_mutexattr_setprioceiling);
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- end record;
- pragma Convention (C, struct_sched_param);
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import
- (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy");
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "sched_yield");
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import
- (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate");
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- function lwp_self return System.Address;
- pragma Import (C, lwp_self, "__gnat_lwp_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- ----------------
- -- Extensions --
- ----------------
-
- CPU_SETSIZE : constant := 1_024;
- -- Size of the cpu_set_t mask on most linux systems (SUSE 11 uses 4_096).
- -- This is kept for backward compatibility (System.Task_Info uses it), but
- -- the run-time library does no longer rely on static masks, using
- -- dynamically allocated masks instead.
-
- type bit_field is array (1 .. CPU_SETSIZE) of Boolean;
- for bit_field'Size use CPU_SETSIZE;
- pragma Pack (bit_field);
- pragma Convention (C, bit_field);
-
- type cpu_set_t is record
- bits : bit_field;
- end record;
- pragma Convention (C, cpu_set_t);
-
- type cpu_set_t_ptr is access all cpu_set_t;
- -- In the run-time library we use this pointer because the size of type
- -- cpu_set_t varies depending on the glibc version. Hence, objects of type
- -- cpu_set_t are allocated dynamically using the number of processors
- -- available in the target machine (value obtained at execution time).
-
- function CPU_ALLOC (count : size_t) return cpu_set_t_ptr;
- pragma Import (C, CPU_ALLOC, "__gnat_cpu_alloc");
- -- Wrapper around the CPU_ALLOC C macro
-
- function CPU_ALLOC_SIZE (count : size_t) return size_t;
- pragma Import (C, CPU_ALLOC_SIZE, "__gnat_cpu_alloc_size");
- -- Wrapper around the CPU_ALLOC_SIZE C macro
-
- procedure CPU_FREE (cpuset : cpu_set_t_ptr);
- pragma Import (C, CPU_FREE, "__gnat_cpu_free");
- -- Wrapper around the CPU_FREE C macro
-
- procedure CPU_ZERO (count : size_t; cpuset : cpu_set_t_ptr);
- pragma Import (C, CPU_ZERO, "__gnat_cpu_zero");
- -- Wrapper around the CPU_ZERO_S C macro
-
- procedure CPU_SET (cpu : int; count : size_t; cpuset : cpu_set_t_ptr);
- pragma Import (C, CPU_SET, "__gnat_cpu_set");
- -- Wrapper around the CPU_SET_S C macro
-
- function pthread_setaffinity_np
- (thread : pthread_t;
- cpusetsize : size_t;
- cpuset : cpu_set_t_ptr) return int;
- pragma Import (C, pthread_setaffinity_np, "pthread_setaffinity_np");
- pragma Weak_External (pthread_setaffinity_np);
- -- Use a weak symbol because this function may be available or not,
- -- depending on the version of the system.
-
- function pthread_attr_setaffinity_np
- (attr : access pthread_attr_t;
- cpusetsize : size_t;
- cpuset : cpu_set_t_ptr) return int;
- pragma Import (C, pthread_attr_setaffinity_np,
- "pthread_attr_setaffinity_np");
- pragma Weak_External (pthread_attr_setaffinity_np);
- -- Use a weak symbol because this function may be available or not,
- -- depending on the version of the system.
-
-private
-
- type sigset_t is
- array (0 .. OS_Constants.SIZEOF_sigset - 1) of unsigned_char;
- pragma Convention (C, sigset_t);
- for sigset_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
- pragma Warnings (Off);
- for struct_sigaction use record
- sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1;
- sa_mask at Linux.sa_mask_pos range 0 .. 1023;
- sa_flags at Linux.sa_flags_pos range 0 .. int'Size - 1;
- end record;
- -- We intentionally leave sa_restorer unspecified and let the compiler
- -- append it after the last field, so disable corresponding warning.
- pragma Warnings (On);
-
- type pid_t is new int;
-
- subtype char_array is Interfaces.C.char_array;
-
- type pthread_attr_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_ATTR_SIZE);
- end record;
- pragma Convention (C, pthread_attr_t);
- for pthread_attr_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
- type pthread_condattr_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_CONDATTR_SIZE);
- end record;
- pragma Convention (C, pthread_condattr_t);
- for pthread_condattr_t'Alignment use Interfaces.C.int'Alignment;
-
- type pthread_mutexattr_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_MUTEXATTR_SIZE);
- end record;
- pragma Convention (C, pthread_mutexattr_t);
- for pthread_mutexattr_t'Alignment use Interfaces.C.int'Alignment;
-
- type pthread_mutex_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_MUTEX_SIZE);
- end record;
- pragma Convention (C, pthread_mutex_t);
- for pthread_mutex_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
- type pthread_rwlockattr_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCKATTR_SIZE);
- end record;
- pragma Convention (C, pthread_rwlockattr_t);
- for pthread_rwlockattr_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
- type pthread_rwlock_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCK_SIZE);
- end record;
- pragma Convention (C, pthread_rwlock_t);
- for pthread_rwlock_t'Alignment use Interfaces.C.unsigned_long'Alignment;
-
- type pthread_cond_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_COND_SIZE);
- end record;
- pragma Convention (C, pthread_cond_t);
- for pthread_cond_t'Alignment use Interfaces.Unsigned_64'Alignment;
-
- type pthread_key_t is new unsigned;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a NT (native) version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl). For non tasking
--- oriented services consider declaring them into system-win32.
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-with Interfaces.C.Strings;
-with System.Win32;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-mthreads");
-
- subtype int is Interfaces.C.int;
- subtype long is Interfaces.C.long;
-
- subtype LARGE_INTEGER is System.Win32.LARGE_INTEGER;
-
- -------------------
- -- General Types --
- -------------------
-
- subtype PSZ is Interfaces.C.Strings.chars_ptr;
-
- Null_Void : constant Win32.PVOID := System.Null_Address;
-
- -------------------------
- -- Handles for objects --
- -------------------------
-
- subtype Thread_Id is Win32.HANDLE;
-
- -----------
- -- Errno --
- -----------
-
- NO_ERROR : constant := 0;
- FUNC_ERR : constant := -1;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 31;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGINT : constant := 2; -- interrupt (Ctrl-C)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGFPE : constant := 8; -- floating point exception
- SIGSEGV : constant := 11; -- segmentation violation
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGBREAK : constant := 21; -- break (Ctrl-Break)
- SIGABRT : constant := 22; -- used by abort, replace SIGIOT in the future
-
- type sigset_t is private;
-
- type isr_address is access procedure (sig : int);
- pragma Convention (C, isr_address);
-
- function intr_attach (sig : int; handler : isr_address) return long;
- pragma Import (C, intr_attach, "signal");
-
- Intr_Attach_Reset : constant Boolean := True;
- -- True if intr_attach is reset after an interrupt handler is called
-
- procedure kill (sig : Signal);
- pragma Import (C, kill, "raise");
-
- ------------
- -- Clock --
- ------------
-
- procedure QueryPerformanceFrequency
- (lpPerformanceFreq : access LARGE_INTEGER);
- pragma Import
- (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency");
-
- -- According to the spec, on XP and later than function cannot fail,
- -- so we ignore the return value and import it as a procedure.
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- procedure SwitchToThread;
- pragma Import (Stdcall, SwitchToThread, "SwitchToThread");
-
- function GetThreadTimes
- (hThread : Win32.HANDLE;
- lpCreationTime : access Long_Long_Integer;
- lpExitTime : access Long_Long_Integer;
- lpKernelTime : access Long_Long_Integer;
- lpUserTime : access Long_Long_Integer) return Win32.BOOL;
- pragma Import (Stdcall, GetThreadTimes, "GetThreadTimes");
-
- -----------------------
- -- Critical sections --
- -----------------------
-
- type CRITICAL_SECTION is private;
-
- -------------------------------------------------------------
- -- Thread Creation, Activation, Suspension And Termination --
- -------------------------------------------------------------
-
- type PTHREAD_START_ROUTINE is access function
- (pThreadParameter : Win32.PVOID) return Win32.DWORD;
- pragma Convention (Stdcall, PTHREAD_START_ROUTINE);
-
- function To_PTHREAD_START_ROUTINE is new
- Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);
-
- function CreateThread
- (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
- dwStackSize : Win32.DWORD;
- pStartAddress : PTHREAD_START_ROUTINE;
- pParameter : Win32.PVOID;
- dwCreationFlags : Win32.DWORD;
- pThreadId : access Win32.DWORD) return Win32.HANDLE;
- pragma Import (Stdcall, CreateThread, "CreateThread");
-
- function BeginThreadEx
- (pThreadAttributes : access Win32.SECURITY_ATTRIBUTES;
- dwStackSize : Win32.DWORD;
- pStartAddress : PTHREAD_START_ROUTINE;
- pParameter : Win32.PVOID;
- dwCreationFlags : Win32.DWORD;
- pThreadId : not null access Win32.DWORD) return Win32.HANDLE;
- pragma Import (C, BeginThreadEx, "_beginthreadex");
-
- Debug_Process : constant := 16#00000001#;
- Debug_Only_This_Process : constant := 16#00000002#;
- Create_Suspended : constant := 16#00000004#;
- Detached_Process : constant := 16#00000008#;
- Create_New_Console : constant := 16#00000010#;
-
- Create_New_Process_Group : constant := 16#00000200#;
-
- Create_No_window : constant := 16#08000000#;
-
- Profile_User : constant := 16#10000000#;
- Profile_Kernel : constant := 16#20000000#;
- Profile_Server : constant := 16#40000000#;
-
- Stack_Size_Param_Is_A_Reservation : constant := 16#00010000#;
-
- function GetExitCodeThread
- (hThread : Win32.HANDLE;
- pExitCode : not null access Win32.DWORD) return Win32.BOOL;
- pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread");
-
- function ResumeThread (hThread : Win32.HANDLE) return Win32.DWORD;
- pragma Import (Stdcall, ResumeThread, "ResumeThread");
-
- function SuspendThread (hThread : Win32.HANDLE) return Win32.DWORD;
- pragma Import (Stdcall, SuspendThread, "SuspendThread");
-
- procedure ExitThread (dwExitCode : Win32.DWORD);
- pragma Import (Stdcall, ExitThread, "ExitThread");
-
- procedure EndThreadEx (dwExitCode : Win32.DWORD);
- pragma Import (C, EndThreadEx, "_endthreadex");
-
- function TerminateThread
- (hThread : Win32.HANDLE;
- dwExitCode : Win32.DWORD) return Win32.BOOL;
- pragma Import (Stdcall, TerminateThread, "TerminateThread");
-
- function GetCurrentThread return Win32.HANDLE;
- pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread");
-
- function GetCurrentProcess return Win32.HANDLE;
- pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess");
-
- function GetCurrentThreadId return Win32.DWORD;
- pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId");
-
- function TlsAlloc return Win32.DWORD;
- pragma Import (Stdcall, TlsAlloc, "TlsAlloc");
-
- function TlsGetValue (dwTlsIndex : Win32.DWORD) return Win32.PVOID;
- pragma Import (Stdcall, TlsGetValue, "TlsGetValue");
-
- function TlsSetValue
- (dwTlsIndex : Win32.DWORD; pTlsValue : Win32.PVOID) return Win32.BOOL;
- pragma Import (Stdcall, TlsSetValue, "TlsSetValue");
-
- function TlsFree (dwTlsIndex : Win32.DWORD) return Win32.BOOL;
- pragma Import (Stdcall, TlsFree, "TlsFree");
-
- TLS_Nothing : constant := Win32.DWORD'Last;
-
- procedure ExitProcess (uExitCode : Interfaces.C.unsigned);
- pragma Import (Stdcall, ExitProcess, "ExitProcess");
-
- function WaitForSingleObject
- (hHandle : Win32.HANDLE;
- dwMilliseconds : Win32.DWORD) return Win32.DWORD;
- pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject");
-
- function WaitForSingleObjectEx
- (hHandle : Win32.HANDLE;
- dwMilliseconds : Win32.DWORD;
- fAlertable : Win32.BOOL) return Win32.DWORD;
- pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx");
-
- Wait_Infinite : constant := Win32.DWORD'Last;
- WAIT_TIMEOUT : constant := 16#0000_0102#;
- WAIT_FAILED : constant := 16#FFFF_FFFF#;
-
- ------------------------------------
- -- Semaphores, Events and Mutexes --
- ------------------------------------
-
- function CreateSemaphore
- (pSemaphoreAttributes : access Win32.SECURITY_ATTRIBUTES;
- lInitialCount : Interfaces.C.long;
- lMaximumCount : Interfaces.C.long;
- pName : PSZ) return Win32.HANDLE;
- pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA");
-
- function OpenSemaphore
- (dwDesiredAccess : Win32.DWORD;
- bInheritHandle : Win32.BOOL;
- pName : PSZ) return Win32.HANDLE;
- pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA");
-
- function ReleaseSemaphore
- (hSemaphore : Win32.HANDLE;
- lReleaseCount : Interfaces.C.long;
- pPreviousCount : access Win32.LONG) return Win32.BOOL;
- pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore");
-
- function CreateEvent
- (pEventAttributes : access Win32.SECURITY_ATTRIBUTES;
- bManualReset : Win32.BOOL;
- bInitialState : Win32.BOOL;
- pName : PSZ) return Win32.HANDLE;
- pragma Import (Stdcall, CreateEvent, "CreateEventA");
-
- function OpenEvent
- (dwDesiredAccess : Win32.DWORD;
- bInheritHandle : Win32.BOOL;
- pName : PSZ) return Win32.HANDLE;
- pragma Import (Stdcall, OpenEvent, "OpenEventA");
-
- function SetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
- pragma Import (Stdcall, SetEvent, "SetEvent");
-
- function ResetEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
- pragma Import (Stdcall, ResetEvent, "ResetEvent");
-
- function PulseEvent (hEvent : Win32.HANDLE) return Win32.BOOL;
- pragma Import (Stdcall, PulseEvent, "PulseEvent");
-
- function CreateMutex
- (pMutexAttributes : access Win32.SECURITY_ATTRIBUTES;
- bInitialOwner : Win32.BOOL;
- pName : PSZ) return Win32.HANDLE;
- pragma Import (Stdcall, CreateMutex, "CreateMutexA");
-
- function OpenMutex
- (dwDesiredAccess : Win32.DWORD;
- bInheritHandle : Win32.BOOL;
- pName : PSZ) return Win32.HANDLE;
- pragma Import (Stdcall, OpenMutex, "OpenMutexA");
-
- function ReleaseMutex (hMutex : Win32.HANDLE) return Win32.BOOL;
- pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex");
-
- ---------------------------------------------------
- -- Accessing properties of Threads and Processes --
- ---------------------------------------------------
-
- -----------------
- -- Priorities --
- -----------------
-
- function SetThreadPriority
- (hThread : Win32.HANDLE;
- nPriority : Interfaces.C.int) return Win32.BOOL;
- pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority");
-
- function GetThreadPriority (hThread : Win32.HANDLE) return Interfaces.C.int;
- pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority");
-
- function SetPriorityClass
- (hProcess : Win32.HANDLE;
- dwPriorityClass : Win32.DWORD) return Win32.BOOL;
- pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass");
-
- procedure SetThreadPriorityBoost
- (hThread : Win32.HANDLE;
- DisablePriorityBoost : Win32.BOOL);
- pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost");
-
- Normal_Priority_Class : constant := 16#00000020#;
- Idle_Priority_Class : constant := 16#00000040#;
- High_Priority_Class : constant := 16#00000080#;
- Realtime_Priority_Class : constant := 16#00000100#;
-
- Thread_Priority_Idle : constant := -15;
- Thread_Priority_Lowest : constant := -2;
- Thread_Priority_Below_Normal : constant := -1;
- Thread_Priority_Normal : constant := 0;
- Thread_Priority_Above_Normal : constant := 1;
- Thread_Priority_Highest : constant := 2;
- Thread_Priority_Time_Critical : constant := 15;
- Thread_Priority_Error_Return : constant := Interfaces.C.long'Last;
-
-private
-
- type sigset_t is new Interfaces.C.unsigned_long;
-
- type CRITICAL_SECTION is record
- DebugInfo : System.Address;
-
- LockCount : Long_Integer;
- RecursionCount : Long_Integer;
- OwningThread : Win32.HANDLE;
- -- The above three fields control entering and exiting the critical
- -- section for the resource.
-
- LockSemaphore : Win32.HANDLE;
- SpinCount : Win32.DWORD;
- end record;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is for POSIX-like operating systems
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-with Interfaces.C; use Interfaces.C;
-package body System.OS_Interface is
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
-
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-2009 Florida State University --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
--- --
--- The GNARL files that were developed for RTEMS are maintained by On-Line --
--- Applications Research Corporation (http://www.oarcorp.com) in coopera- --
--- tion with Ada Core Technologies Inc. and Florida State University. --
--- --
-------------------------------------------------------------------------------
-
--- This is the RTEMS version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
-with Interfaces.C; use Interfaces.C;
-package body System.OS_Interface is
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to round-up, adjust for positive F value
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
-
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- -----------------
- -- sigaltstack --
- -----------------
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int is
- pragma Unreferenced (ss);
- pragma Unreferenced (oss);
- begin
- return 0;
- end sigaltstack;
-
- -----------------------------------
- -- pthread_rwlockattr_setkind_np --
- -----------------------------------
-
- function pthread_rwlockattr_setkind_np
- (attr : access pthread_rwlockattr_t;
- pref : int) return int is
- pragma Unreferenced (attr);
- pragma Unreferenced (pref);
- begin
- return 0;
- end pthread_rwlockattr_setkind_np;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1997-2016 Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
--- The GNARL files that were developed for RTEMS are maintained by On-Line --
--- Applications Research Corporation (http://www.oarcorp.com) in coopera- --
--- tion with Ada Core Technologies Inc. and Florida State University. --
--- --
-------------------------------------------------------------------------------
-
--- This is the RTEMS version of this package.
---
--- RTEMS target names are of the form CPU-rtems.
--- This implementation is designed to work on ALL RTEMS targets.
--- The RTEMS implementation is primarily based upon the POSIX threads
--- API but there are also bindings to GNAT/RTEMS support routines
--- to insulate this code from C API specific details and, in some
--- cases, obtain target architecture and BSP specific information
--- that is unavailable at the time this package is built.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
--- PLEASE DO NOT add any with-clauses to this package
--- or remove the pragma Preelaborate.
--- It is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-with System.OS_Constants;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- -- This interface assumes that "unsigned" is a 32-bit entity. This
- -- will correspond to RTEMS object ids.
-
- subtype rtems_id is Interfaces.C.unsigned;
-
- subtype int is Interfaces.C.int;
- subtype char is Interfaces.C.char;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := System.OS_Constants.EAGAIN;
- EINTR : constant := System.OS_Constants.EINTR;
- EINVAL : constant := System.OS_Constants.EINVAL;
- ENOMEM : constant := System.OS_Constants.ENOMEM;
- ETIMEDOUT : constant := System.OS_Constants.ETIMEDOUT;
-
- -------------
- -- Signals --
- -------------
-
- Num_HW_Interrupts : constant := 256;
-
- Max_HW_Interrupt : constant := Num_HW_Interrupts - 1;
- type HW_Interrupt is new int range 0 .. Max_HW_Interrupt;
-
- Max_Interrupt : constant := Max_HW_Interrupt;
-
- type Signal is new int range 0 .. Max_Interrupt;
-
- SIGXCPU : constant := 0; -- XCPU
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
-
- SIGADAABORT : constant := SIGABRT;
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set := (SIGTRAP, SIGALRM, SIGEMT);
- Reserved : constant Signal_Set := (1 .. 1 => SIGKILL);
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type struct_sigaction is record
- sa_flags : int;
- sa_mask : sigset_t;
- sa_handler : System.Address;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SA_SIGINFO : constant := 16#02#;
-
- SA_ONSTACK : constant := 16#00#;
- -- SA_ONSTACK is not defined on RTEMS, but it is referred to in the POSIX
- -- implementation of System.Interrupt_Management. Therefore we define a
- -- dummy value of zero here so that setting this flag is a nop.
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := True;
- -- Indicates whether time slicing is supported (i.e SCHED_RR is supported)
-
- type timespec is private;
-
- type clockid_t is new int;
-
- CLOCK_REALTIME : constant clockid_t;
- CLOCK_MONOTONIC : constant clockid_t;
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec) return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function clock_getres
- (clock_id : clockid_t;
- res : access timespec) return int;
- pragma Import (C, clock_getres, "clock_getres");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 1;
- SCHED_RR : constant := 2;
- SCHED_OTHER : constant := 0;
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- type pthread_t is private;
- subtype Thread_Id is pthread_t;
-
- type pthread_mutex_t is limited private;
- type pthread_rwlock_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_rwlockattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- No_Key : constant pthread_key_t;
-
- PTHREAD_CREATE_DETACHED : constant := 0;
-
- PTHREAD_SCOPE_PROCESS : constant := 0;
- PTHREAD_SCOPE_SYSTEM : constant := 1;
-
- -----------
- -- Stack --
- -----------
-
- type stack_t is record
- ss_sp : System.Address;
- ss_flags : int;
- ss_size : size_t;
- end record;
- pragma Convention (C, stack_t);
-
- function sigaltstack
- (ss : not null access stack_t;
- oss : access stack_t) return int;
-
- Alternate_Stack : aliased System.Address;
- -- This is a dummy definition, never used (Alternate_Stack_Size is null)
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates whether the stack base is available on this target.
- -- This allows us to share s-osinte.adb between all the FSU/RTEMS
- -- run time.
- -- Note that this value can only be true if pthread_t has a complete
- -- definition that corresponds exactly to the C header files.
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread.
- -- Only call this function when Stack_Base_Available is True.
-
- -- These two functions are only needed to share s-taprop.adb with
- -- FSU threads.
-
- function Get_Page_Size return int;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- Returns the size of a page
-
- PROT_ON : constant := 0;
- PROT_OFF : constant := 0;
-
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- -----------------------------------------
- -- Nonstandard Thread Initialization --
- -----------------------------------------
-
- procedure pthread_init;
- -- FSU_THREADS requires pthread_init, which is nonstandard
- -- and this should be invoked during the elaboration of s-taprop.adb
- --
- -- RTEMS does not require this so we provide an empty Ada body.
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait
- (set : access sigset_t;
- sig : access Signal) return int;
- pragma Import (C, sigwait, "sigwait");
-
- function pthread_kill
- (thread : pthread_t;
- sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "pthread_sigmask");
-
- ----------------------------
- -- POSIX.1c Section 11 --
- ----------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
-
- function pthread_rwlockattr_init
- (attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlockattr_init, "pthread_rwlockattr_init");
-
- function pthread_rwlockattr_destroy
- (attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlockattr_destroy, "pthread_rwlockattr_destroy");
-
- PTHREAD_RWLOCK_PREFER_READER_NP : constant := 0;
- PTHREAD_RWLOCK_PREFER_WRITER_NP : constant := 1;
- PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP : constant := 2;
-
- function pthread_rwlockattr_setkind_np
- (attr : access pthread_rwlockattr_t;
- pref : int) return int;
-
- function pthread_rwlock_init
- (mutex : access pthread_rwlock_t;
- attr : access pthread_rwlockattr_t) return int;
- pragma Import (C, pthread_rwlock_init, "pthread_rwlock_init");
-
- function pthread_rwlock_destroy
- (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_destroy, "pthread_rwlock_destroy");
-
- function pthread_rwlock_rdlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_rdlock, "pthread_rwlock_rdlock");
-
- function pthread_rwlock_wrlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_wrlock, "pthread_rwlock_wrlock");
-
- function pthread_rwlock_unlock (mutex : access pthread_rwlock_t) return int;
- pragma Import (C, pthread_rwlock_unlock, "pthread_rwlock_unlock");
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 2;
- PTHREAD_PRIO_INHERIT : constant := 1;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol);
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprioceiling,
- "pthread_mutexattr_setprioceiling");
-
- type struct_sched_param is record
- sched_priority : int;
- ss_low_priority : int;
- ss_replenish_period : timespec;
- ss_initial_budget : timespec;
- sched_ss_max_repl : int;
- end record;
- pragma Convention (C, struct_sched_param);
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import (C, pthread_attr_setinheritsched);
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy);
-
- function pthread_attr_setschedparam
- (attr : access pthread_attr_t;
- sched_param : int) return int;
- pragma Import (C, pthread_attr_setschedparam);
-
- function sched_yield return int;
- pragma Import (C, sched_yield, "sched_yield");
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- pragma Import (C, pthread_attr_setdetachstate);
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- pragma Import (C, pthread_getspecific, "pthread_getspecific");
-
- type destructor_pointer is access procedure (arg : System.Address);
- pragma Convention (C, destructor_pointer);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
- ------------------------------------------------------------
- -- Binary Semaphore Wrapper to Support Interrupt Tasks --
- ------------------------------------------------------------
-
- type Binary_Semaphore_Id is new rtems_id;
-
- function Binary_Semaphore_Create return Binary_Semaphore_Id;
- pragma Import (
- C,
- Binary_Semaphore_Create,
- "__gnat_binary_semaphore_create");
-
- function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int;
- pragma Import (
- C,
- Binary_Semaphore_Delete,
- "__gnat_binary_semaphore_delete");
-
- function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int;
- pragma Import (
- C,
- Binary_Semaphore_Obtain,
- "__gnat_binary_semaphore_obtain");
-
- function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int;
- pragma Import (
- C,
- Binary_Semaphore_Release,
- "__gnat_binary_semaphore_release");
-
- function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int;
- pragma Import (
- C,
- Binary_Semaphore_Flush,
- "__gnat_binary_semaphore_flush");
-
- ------------------------------------------------------------
- -- Hardware Interrupt Wrappers to Support Interrupt Tasks --
- ------------------------------------------------------------
-
- type Interrupt_Handler is access procedure (parameter : System.Address);
- pragma Convention (C, Interrupt_Handler);
- type Interrupt_Vector is new System.Address;
-
- function Interrupt_Connect
- (vector : Interrupt_Vector;
- handler : Interrupt_Handler;
- parameter : System.Address := System.Null_Address) return int;
- pragma Import (C, Interrupt_Connect, "__gnat_interrupt_connect");
- -- Use this to set up an user handler. The routine installs a
- -- a user handler which is invoked after RTEMS has saved enough
- -- context for a high-level language routine to be safely invoked.
-
- function Interrupt_Vector_Get
- (Vector : Interrupt_Vector) return Interrupt_Handler;
- pragma Import (C, Interrupt_Vector_Get, "__gnat_interrupt_get");
- -- Use this to get the existing handler for later restoral.
-
- procedure Interrupt_Vector_Set
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler);
- pragma Import (C, Interrupt_Vector_Set, "__gnat_interrupt_set");
- -- Use this to restore a handler obtained using Interrupt_Vector_Get.
-
- function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector;
- -- Convert a logical interrupt number to the hardware interrupt vector
- -- number used to connect the interrupt.
- pragma Import (
- C,
- Interrupt_Number_To_Vector,
- "__gnat_interrupt_number_to_vector"
- );
-
-private
-
- type sigset_t is new int;
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- CLOCK_REALTIME : constant clockid_t := System.OS_Constants.CLOCK_REALTIME;
- CLOCK_MONOTONIC : constant clockid_t := System.OS_Constants.CLOCK_MONOTONIC;
-
- subtype char_array is Interfaces.C.char_array;
-
- type pthread_attr_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_ATTR_SIZE);
- end record;
- pragma Convention (C, pthread_attr_t);
- for pthread_attr_t'Alignment use Interfaces.C.double'Alignment;
-
- type pthread_condattr_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_CONDATTR_SIZE);
- end record;
- pragma Convention (C, pthread_condattr_t);
- for pthread_condattr_t'Alignment use Interfaces.C.double'Alignment;
-
- type pthread_mutexattr_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_MUTEXATTR_SIZE);
- end record;
- pragma Convention (C, pthread_mutexattr_t);
- for pthread_mutexattr_t'Alignment use Interfaces.C.double'Alignment;
-
- type pthread_rwlockattr_t is record
- Data : char_array (1 .. OS_Constants.PTHREAD_RWLOCKATTR_SIZE);
- end record;
- pragma Convention (C, pthread_rwlockattr_t);
- for pthread_rwlockattr_t'Alignment use Interfaces.C.double'Alignment;
-
- type pthread_t is new rtems_id;
-
- type pthread_mutex_t is new rtems_id;
-
- type pthread_rwlock_t is new rtems_id;
-
- type pthread_cond_t is new rtems_id;
-
- type pthread_key_t is new rtems_id;
-
- No_Key : constant pthread_key_t := 0;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2010, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a Solaris version of this package
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
-with Interfaces.C; use Interfaces.C;
-
-package body System.OS_Interface is
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a Solaris (native) version of this package
-
--- This package includes all direct interfaces to OS services
--- that are needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-
-with Ada.Unchecked_Conversion;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lposix4");
- pragma Linker_Options ("-lthread");
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIME : constant := 62;
- ETIMEDOUT : constant := 145;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 45;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 16; -- user defined signal 1
- SIGUSR2 : constant := 17; -- user defined signal 2
- SIGCLD : constant := 18; -- alias for SIGCHLD
- SIGCHLD : constant := 18; -- child status change
- SIGPWR : constant := 19; -- power-fail restart
- SIGWINCH : constant := 20; -- window size change
- SIGURG : constant := 21; -- urgent condition on IO channel
- SIGPOLL : constant := 22; -- pollable event occurred
- SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias)
- SIGSTOP : constant := 23; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 24; -- user stop requested from tty
- SIGCONT : constant := 25; -- stopped process has been continued
- SIGTTIN : constant := 26; -- background tty read attempted
- SIGTTOU : constant := 27; -- background tty write attempted
- SIGVTALRM : constant := 28; -- virtual timer expired
- SIGPROF : constant := 29; -- profiling timer expired
- SIGXCPU : constant := 30; -- CPU time limit exceeded
- SIGXFSZ : constant := 31; -- filesize limit exceeded
- SIGWAITING : constant := 32; -- process's lwps blocked (Solaris)
- SIGLWP : constant := 33; -- used by thread library (Solaris)
- SIGFREEZE : constant := 34; -- used by CPR (Solaris)
- SIGTHAW : constant := 35; -- used by CPR (Solaris)
- SIGCANCEL : constant := 36; -- thread cancellation signal (libthread)
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF);
-
- -- Following signals should not be disturbed.
- -- See c-posix-signals.c in FLORIST.
-
- Reserved : constant Signal_Set :=
- (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL, SIGTRAP, SIGSEGV);
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type union_type_3 is new String (1 .. 116);
- type siginfo_t is record
- si_signo : int;
- si_code : int;
- si_errno : int;
- X_data : union_type_3;
- end record;
- pragma Convention (C, siginfo_t);
-
- -- The types mcontext_t and gregset_t are part of the ucontext_t
- -- information, which is specific to Solaris2.4 for SPARC
- -- The ucontext_t info seems to be used by the handler
- -- for SIGSEGV to decide whether it is a Storage_Error (stack overflow) or
- -- a Constraint_Error (bad pointer). The original code that did this
- -- is suspect, so it is not clear whether we really need this part of
- -- the signal context information, or perhaps something else.
- -- More analysis is needed, after which these declarations may need to
- -- be changed.
-
- type greg_t is new int;
-
- type gregset_t is array (0 .. 18) of greg_t;
-
- type union_type_2 is new String (1 .. 128);
- type record_type_1 is record
- fpu_fr : union_type_2;
- fpu_q : System.Address;
- fpu_fsr : unsigned;
- fpu_qcnt : unsigned_char;
- fpu_q_entrysize : unsigned_char;
- fpu_en : unsigned_char;
- end record;
- pragma Convention (C, record_type_1);
-
- type array_type_7 is array (Integer range 0 .. 20) of long;
- type mcontext_t is record
- gregs : gregset_t;
- gwins : System.Address;
- fpregs : record_type_1;
- filler : array_type_7;
- end record;
- pragma Convention (C, mcontext_t);
-
- type record_type_2 is record
- ss_sp : System.Address;
- ss_size : int;
- ss_flags : int;
- end record;
- pragma Convention (C, record_type_2);
-
- type array_type_8 is array (Integer range 0 .. 22) of long;
- type ucontext_t is record
- uc_flags : unsigned_long;
- uc_link : System.Address;
- uc_sigmask : sigset_t;
- uc_stack : record_type_2;
- uc_mcontext : mcontext_t;
- uc_filler : array_type_8;
- end record;
- pragma Convention (C, ucontext_t);
-
- type Signal_Handler is access procedure
- (signo : Signal;
- info : access siginfo_t;
- context : access ucontext_t);
-
- type union_type_1 is new plain_char;
- type array_type_2 is array (Integer range 0 .. 1) of int;
- type struct_sigaction is record
- sa_flags : int;
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_resv : array_type_2;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- type timespec is private;
-
- type clockid_t is new int;
-
- function clock_gettime
- (clock_id : clockid_t; tp : access timespec) return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function clock_getres
- (clock_id : clockid_t; res : access timespec) return int;
- pragma Import (C, clock_getres, "clock_getres");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- pragma Convention (C, Thread_Body);
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- THR_DETACHED : constant := 64;
- THR_BOUND : constant := 1;
- THR_NEW_LWP : constant := 2;
- USYNC_THREAD : constant := 0;
-
- type thread_t is new unsigned;
- subtype Thread_Id is thread_t;
- -- These types should be commented ???
-
- function To_thread_t is new Ada.Unchecked_Conversion (Integer, thread_t);
-
- type mutex_t is limited private;
-
- type cond_t is limited private;
-
- type thread_key_t is private;
-
- function thr_create
- (stack_base : System.Address;
- stack_size : size_t;
- start_routine : Thread_Body;
- arg : System.Address;
- flags : int;
- new_thread : access thread_t) return int;
- pragma Import (C, thr_create, "thr_create");
-
- function thr_min_stack return size_t;
- pragma Import (C, thr_min_stack, "thr_min_stack");
-
- function thr_self return thread_t;
- pragma Import (C, thr_self, "thr_self");
-
- function mutex_init
- (mutex : access mutex_t;
- mtype : int;
- arg : System.Address) return int;
- pragma Import (C, mutex_init, "mutex_init");
-
- function mutex_destroy (mutex : access mutex_t) return int;
- pragma Import (C, mutex_destroy, "mutex_destroy");
-
- function mutex_lock (mutex : access mutex_t) return int;
- pragma Import (C, mutex_lock, "mutex_lock");
-
- function mutex_unlock (mutex : access mutex_t) return int;
- pragma Import (C, mutex_unlock, "mutex_unlock");
-
- function cond_init
- (cond : access cond_t;
- ctype : int;
- arg : int) return int;
- pragma Import (C, cond_init, "cond_init");
-
- function cond_wait
- (cond : access cond_t; mutex : access mutex_t) return int;
- pragma Import (C, cond_wait, "cond_wait");
-
- function cond_timedwait
- (cond : access cond_t;
- mutex : access mutex_t;
- abstime : access timespec) return int;
- pragma Import (C, cond_timedwait, "cond_timedwait");
-
- function cond_signal (cond : access cond_t) return int;
- pragma Import (C, cond_signal, "cond_signal");
-
- function cond_destroy (cond : access cond_t) return int;
- pragma Import (C, cond_destroy, "cond_destroy");
-
- function thr_setspecific
- (key : thread_key_t; value : System.Address) return int;
- pragma Import (C, thr_setspecific, "thr_setspecific");
-
- function thr_getspecific
- (key : thread_key_t;
- value : access System.Address) return int;
- pragma Import (C, thr_getspecific, "thr_getspecific");
-
- function thr_keycreate
- (key : access thread_key_t; destructor : System.Address) return int;
- pragma Import (C, thr_keycreate, "thr_keycreate");
-
- function thr_setprio (thread : thread_t; priority : int) return int;
- pragma Import (C, thr_setprio, "thr_setprio");
-
- procedure thr_exit (status : System.Address);
- pragma Import (C, thr_exit, "thr_exit");
-
- function thr_setconcurrency (new_level : int) return int;
- pragma Import (C, thr_setconcurrency, "thr_setconcurrency");
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- pragma Import (C, sigwait, "__posix_sigwait");
-
- function thr_kill (thread : thread_t; sig : Signal) return int;
- pragma Import (C, thr_kill, "thr_kill");
-
- function thr_sigsetmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, thr_sigsetmask, "thr_sigsetmask");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "thr_sigsetmask");
-
- function thr_suspend (target_thread : thread_t) return int;
- pragma Import (C, thr_suspend, "thr_suspend");
-
- function thr_continue (target_thread : thread_t) return int;
- pragma Import (C, thr_continue, "thr_continue");
-
- procedure thr_yield;
- pragma Import (C, thr_yield, "thr_yield");
-
- ---------
- -- LWP --
- ---------
-
- P_PID : constant := 0;
- P_LWPID : constant := 8;
-
- PC_GETCID : constant := 0;
- PC_GETCLINFO : constant := 1;
- PC_SETPARMS : constant := 2;
- PC_GETPARMS : constant := 3;
- PC_ADMIN : constant := 4;
-
- PC_CLNULL : constant := -1;
-
- RT_NOCHANGE : constant := -1;
- RT_TQINF : constant := -2;
- RT_TQDEF : constant := -3;
-
- PC_CLNMSZ : constant := 16;
-
- PC_VERSION : constant := 1;
-
- type lwpid_t is new int;
-
- type pri_t is new short;
-
- type id_t is new long;
-
- P_MYID : constant := -1;
- -- The specified LWP or process is the current one
-
- type struct_pcinfo is record
- pc_cid : id_t;
- pc_clname : String (1 .. PC_CLNMSZ);
- rt_maxpri : short;
- end record;
- pragma Convention (C, struct_pcinfo);
-
- type struct_pcparms is record
- pc_cid : id_t;
- rt_pri : pri_t;
- rt_tqsecs : long;
- rt_tqnsecs : long;
- end record;
- pragma Convention (C, struct_pcparms);
-
- function priocntl
- (ver : int;
- id_type : int;
- id : lwpid_t;
- cmd : int;
- arg : System.Address) return Interfaces.C.long;
- pragma Import (C, priocntl, "__priocntl");
-
- function lwp_self return lwpid_t;
- pragma Import (C, lwp_self, "_lwp_self");
-
- type processorid_t is new int;
- type processorid_t_ptr is access all processorid_t;
-
- -- Constants for function processor_bind
-
- PBIND_QUERY : constant processorid_t := -2;
- -- The processor bindings are not changed
-
- PBIND_NONE : constant processorid_t := -1;
- -- The processor bindings of the specified LWPs are cleared
-
- -- Flags for function p_online
-
- PR_OFFLINE : constant int := 1;
- -- Processor is offline, as quiet as possible
-
- PR_ONLINE : constant int := 2;
- -- Processor online
-
- PR_STATUS : constant int := 3;
- -- Value passed to p_online to request status
-
- function p_online (processorid : processorid_t; flag : int) return int;
- pragma Import (C, p_online, "p_online");
-
- function processor_bind
- (id_type : int;
- id : id_t;
- proc_id : processorid_t;
- obind : processorid_t_ptr) return int;
- pragma Import (C, processor_bind, "processor_bind");
-
- type psetid_t is new int;
-
- function pset_create (pset : access psetid_t) return int;
- pragma Import (C, pset_create, "pset_create");
-
- function pset_assign
- (pset : psetid_t;
- proc_id : processorid_t;
- opset : access psetid_t) return int;
- pragma Import (C, pset_assign, "pset_assign");
-
- function pset_bind
- (pset : psetid_t;
- id_type : int;
- id : id_t;
- opset : access psetid_t) return int;
- pragma Import (C, pset_bind, "pset_bind");
-
- procedure pthread_init;
- -- Dummy procedure to share s-intman.adb with other Solaris targets
-
-private
-
- type array_type_1 is array (0 .. 3) of unsigned_long;
- type sigset_t is record
- X_X_sigbits : array_type_1;
- end record;
- pragma Convention (C, sigset_t);
-
- type pid_t is new long;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type array_type_9 is array (0 .. 3) of unsigned_char;
- type record_type_3 is record
- flag : array_type_9;
- Xtype : unsigned_long;
- end record;
- pragma Convention (C, record_type_3);
-
- type mutex_t is record
- flags : record_type_3;
- lock : String (1 .. 8);
- data : String (1 .. 8);
- end record;
- pragma Convention (C, mutex_t);
-
- type cond_t is record
- flag : array_type_9;
- Xtype : unsigned_long;
- data : String (1 .. 8);
- end record;
- pragma Convention (C, cond_t);
-
- type thread_key_t is new unsigned;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1997-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the VxWorks version
-
--- This package encapsulates all direct interfaces to OS services that are
--- needed by children of System.
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-package body System.OS_Interface is
-
- use type Interfaces.C.int;
-
- Low_Priority : constant := 255;
- -- VxWorks native (default) lowest scheduling priority
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
- end To_Duration;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F is negative due to a round-up, adjust for positive F value
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(ts_sec => S,
- ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- -------------------------
- -- To_VxWorks_Priority --
- -------------------------
-
- function To_VxWorks_Priority (Priority : int) return int is
- begin
- return Low_Priority - Priority;
- end To_VxWorks_Priority;
-
- --------------------
- -- To_Clock_Ticks --
- --------------------
-
- -- ??? - For now, we'll always get the system clock rate since it is
- -- allowed to be changed during run-time in VxWorks. A better method would
- -- be to provide an operation to set it that so we can always know its
- -- value.
-
- -- Another thing we should probably allow for is a resultant tick count
- -- greater than int'Last. This should probably be a procedure with two
- -- output parameters, one in the range 0 .. int'Last, and another
- -- representing the overflow count.
-
- function To_Clock_Ticks (D : Duration) return int is
- Ticks : Long_Long_Integer;
- Rate_Duration : Duration;
- Ticks_Duration : Duration;
-
- begin
- if D < 0.0 then
- return ERROR;
- end if;
-
- -- Ensure that the duration can be converted to ticks
- -- at the current clock tick rate without overflowing.
-
- Rate_Duration := Duration (sysClkRateGet);
-
- if D > (Duration'Last / Rate_Duration) then
- Ticks := Long_Long_Integer (int'Last);
- else
- Ticks_Duration := D * Rate_Duration;
- Ticks := Long_Long_Integer (Ticks_Duration);
-
- if Ticks_Duration > Duration (Ticks) then
- Ticks := Ticks + 1;
- end if;
-
- if Ticks > Long_Long_Integer (int'Last) then
- Ticks := Long_Long_Integer (int'Last);
- end if;
- end if;
-
- return int (Ticks);
- end To_Clock_Ticks;
-
- -----------------------------
- -- Binary_Semaphore_Create --
- -----------------------------
-
- function Binary_Semaphore_Create return Binary_Semaphore_Id is
- begin
- return Binary_Semaphore_Id (semBCreate (SEM_Q_FIFO, SEM_EMPTY));
- end Binary_Semaphore_Create;
-
- -----------------------------
- -- Binary_Semaphore_Delete --
- -----------------------------
-
- function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int is
- begin
- return semDelete (SEM_ID (ID));
- end Binary_Semaphore_Delete;
-
- -----------------------------
- -- Binary_Semaphore_Obtain --
- -----------------------------
-
- function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int is
- begin
- return semTake (SEM_ID (ID), WAIT_FOREVER);
- end Binary_Semaphore_Obtain;
-
- ------------------------------
- -- Binary_Semaphore_Release --
- ------------------------------
-
- function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int is
- begin
- return semGive (SEM_ID (ID));
- end Binary_Semaphore_Release;
-
- ----------------------------
- -- Binary_Semaphore_Flush --
- ----------------------------
-
- function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int is
- begin
- return semFlush (SEM_ID (ID));
- end Binary_Semaphore_Flush;
-
- ----------
- -- kill --
- ----------
-
- function kill (pid : t_id; sig : Signal) return int is
- begin
- return System.VxWorks.Ext.kill (pid, int (sig));
- end kill;
-
- -----------------------
- -- Interrupt_Connect --
- -----------------------
-
- function Interrupt_Connect
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler;
- Parameter : System.Address := System.Null_Address) return int is
- begin
- return
- System.VxWorks.Ext.Interrupt_Connect
- (System.VxWorks.Ext.Interrupt_Vector (Vector),
- System.VxWorks.Ext.Interrupt_Handler (Handler),
- Parameter);
- end Interrupt_Connect;
-
- -----------------------
- -- Interrupt_Context --
- -----------------------
-
- function Interrupt_Context return int is
- begin
- return System.VxWorks.Ext.Interrupt_Context;
- end Interrupt_Context;
-
- --------------------------------
- -- Interrupt_Number_To_Vector --
- --------------------------------
-
- function Interrupt_Number_To_Vector
- (intNum : int) return Interrupt_Vector
- is
- begin
- return Interrupt_Vector
- (System.VxWorks.Ext.Interrupt_Number_To_Vector (intNum));
- end Interrupt_Number_To_Vector;
-
- -----------------
- -- Current_CPU --
- -----------------
-
- function Current_CPU return Multiprocessors.CPU is
- begin
- -- ??? Should use vxworks multiprocessor interface
-
- return Multiprocessors.CPU'First;
- end Current_CPU;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the VxWorks version of this package
-
--- This package encapsulates all direct interfaces to OS services that are
--- needed by the tasking run-time (libgnarl).
-
--- PLEASE DO NOT add any with-clauses to this package or remove the pragma
--- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-with System.VxWorks;
-with System.VxWorks.Ext;
-with System.Multiprocessors;
-
-package System.OS_Interface is
- pragma Preelaborate;
-
- subtype int is Interfaces.C.int;
- subtype unsigned is Interfaces.C.unsigned;
- subtype short is Short_Integer;
- type unsigned_int is mod 2 ** int'Size;
- type long is new Long_Integer;
- type unsigned_long is mod 2 ** long'Size;
- type long_long is new Long_Long_Integer;
- type unsigned_long_long is mod 2 ** long_long'Size;
- type size_t is mod 2 ** Standard'Address_Size;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "errnoGet");
-
- EINTR : constant := 4;
- EAGAIN : constant := 35;
- ENOMEM : constant := 12;
- EINVAL : constant := 22;
- ETIMEDOUT : constant := 60;
-
- FUNC_ERR : constant := -1;
-
- ----------------------------
- -- Signals and interrupts --
- ----------------------------
-
- NSIG : constant := 64;
- -- Number of signals on the target OS
- type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
-
- Max_HW_Interrupt : constant := System.VxWorks.Num_HW_Interrupts - 1;
- type HW_Interrupt is new int range 0 .. Max_HW_Interrupt;
-
- Max_Interrupt : constant := Max_HW_Interrupt;
- subtype Interrupt_Range is Natural range 0 .. Max_HW_Interrupt;
- -- For s-interr
-
- -- Signals common to Vxworks 5.x and 6.x
-
- SIGILL : constant := 4; -- illegal instruction (not reset when caught)
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGFPE : constant := 8; -- floating point exception
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
-
- -- Signals specific to VxWorks 6.x
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt
- SIGQUIT : constant := 3; -- quit
- SIGTRAP : constant := 5; -- trace trap (not reset when caught)
- SIGEMT : constant := 7; -- EMT instruction
- SIGKILL : constant := 9; -- kill
- SIGFMT : constant := 12; -- STACK FORMAT ERROR (not posix)
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGCNCL : constant := 16; -- pthreads cancellation signal
- SIGSTOP : constant := 17; -- sendable stop signal not from tty
- SIGTSTP : constant := 18; -- stop signal from tty
- SIGCONT : constant := 19; -- continue a stopped process
- SIGCHLD : constant := 20; -- to parent on child stop or exit
- SIGTTIN : constant := 21; -- to readers pgrp upon background tty read
- SIGTTOU : constant := 22; -- like TTIN for output
-
- SIGRES1 : constant := 23; -- reserved signal number (Not POSIX)
- SIGRES2 : constant := 24; -- reserved signal number (Not POSIX)
- SIGRES3 : constant := 25; -- reserved signal number (Not POSIX)
- SIGRES4 : constant := 26; -- reserved signal number (Not POSIX)
- SIGRES5 : constant := 27; -- reserved signal number (Not POSIX)
- SIGRES6 : constant := 28; -- reserved signal number (Not POSIX)
- SIGRES7 : constant := 29; -- reserved signal number (Not POSIX)
-
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
-
- SIGPOLL : constant := 32; -- pollable event
- SIGPROF : constant := 33; -- profiling timer expired
- SIGSYS : constant := 34; -- bad system call
- SIGURG : constant := 35; -- high bandwidth data is available at socket
- SIGVTALRM : constant := 36; -- virtual timer expired
- SIGXCPU : constant := 37; -- CPU time limit exceeded
- SIGXFSZ : constant := 38; -- file size time limit exceeded
-
- SIGEVTS : constant := 39; -- signal event thread send
- SIGEVTD : constant := 40; -- signal event thread delete
-
- SIGRTMIN : constant := 48; -- Realtime signal min
- SIGRTMAX : constant := 63; -- Realtime signal max
-
- -----------------------------------
- -- Signal processing definitions --
- -----------------------------------
-
- -- The how in sigprocmask()
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
-
- -- The sa_flags in struct sigaction
-
- SA_SIGINFO : constant := 16#0002#;
- SA_ONSTACK : constant := 16#0004#;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- type sigset_t is private;
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- type isr_address is access procedure (sig : int);
- pragma Convention (C, isr_address);
-
- function c_signal (sig : Signal; handler : isr_address) return isr_address;
- pragma Import (C, c_signal, "signal");
-
- function pthread_sigmask
- (how : int;
- set : access sigset_t;
- oset : access sigset_t) return int;
- pragma Import (C, pthread_sigmask, "sigprocmask");
-
- subtype t_id is System.VxWorks.Ext.t_id;
- subtype Thread_Id is t_id;
- -- Thread_Id and t_id are VxWorks identifiers for tasks. This value,
- -- although represented as a Long_Integer, is in fact an address. With
- -- some BSPs, this address can have a value sufficiently high that the
- -- Thread_Id becomes negative: this should not be considered as an error.
-
- function kill (pid : t_id; sig : Signal) return int;
- pragma Inline (kill);
-
- function getpid return t_id renames System.VxWorks.Ext.getpid;
-
- function Task_Stop (tid : t_id) return int
- renames System.VxWorks.Ext.Task_Stop;
- -- If we are in the kernel space, stop the task whose t_id is given in
- -- parameter in such a way that it can be examined by the debugger. This
- -- typically maps to taskSuspend on VxWorks 5 and to taskStop on VxWorks 6.
-
- function Task_Cont (tid : t_id) return int
- renames System.VxWorks.Ext.Task_Cont;
- -- If we are in the kernel space, continue the task whose t_id is given
- -- in parameter if it has been stopped previously to be examined by the
- -- debugger (e.g. by taskStop). It typically maps to taskResume on VxWorks
- -- 5 and to taskCont on VxWorks 6.
-
- function Int_Lock return int renames System.VxWorks.Ext.Int_Lock;
- -- If we are in the kernel space, lock interrupts. It typically maps to
- -- intLock.
-
- function Int_Unlock (Old : int) return int
- renames System.VxWorks.Ext.Int_Unlock;
- -- If we are in the kernel space, unlock interrupts. It typically maps to
- -- intUnlock. The parameter Old is only used on PowerPC where it contains
- -- the returned value from Int_Lock (the old MPSR).
-
- ----------
- -- Time --
- ----------
-
- type time_t is new unsigned_long;
-
- type timespec is record
- ts_sec : time_t;
- ts_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type clockid_t is new int;
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
- -- Convert a Duration value to a timespec value. Note that in VxWorks,
- -- timespec is always non-negative (since time_t is defined above as
- -- unsigned long). This means that there is a potential problem if a
- -- negative argument is passed for D. However, in actual usage, the
- -- value of the input argument D is always non-negative, so no problem
- -- arises in practice.
-
- function To_Clock_Ticks (D : Duration) return int;
- -- Convert a duration value (in seconds) into clock ticks
-
- function clock_gettime
- (clock_id : clockid_t; tp : access timespec) return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- ----------------------
- -- Utility Routines --
- ----------------------
-
- function To_VxWorks_Priority (Priority : int) return int;
- pragma Inline (To_VxWorks_Priority);
- -- Convenience routine to convert between VxWorks priority and Ada priority
-
- --------------------------
- -- VxWorks specific API --
- --------------------------
-
- subtype STATUS is int;
- -- Equivalent of the C type STATUS
-
- OK : constant STATUS := 0;
- ERROR : constant STATUS := Interfaces.C.int (-1);
-
- function taskIdVerify (tid : t_id) return STATUS;
- pragma Import (C, taskIdVerify, "taskIdVerify");
-
- function taskIdSelf return t_id;
- pragma Import (C, taskIdSelf, "taskIdSelf");
-
- function taskOptionsGet (tid : t_id; pOptions : access int) return int;
- pragma Import (C, taskOptionsGet, "taskOptionsGet");
-
- function taskSuspend (tid : t_id) return int;
- pragma Import (C, taskSuspend, "taskSuspend");
-
- function taskResume (tid : t_id) return int;
- pragma Import (C, taskResume, "taskResume");
-
- function taskIsSuspended (tid : t_id) return int;
- pragma Import (C, taskIsSuspended, "taskIsSuspended");
-
- function taskDelay (ticks : int) return int;
- pragma Import (C, taskDelay, "taskDelay");
-
- function sysClkRateGet return int;
- pragma Import (C, sysClkRateGet, "sysClkRateGet");
-
- -- VxWorks 5.x specific functions
- -- Must not be called from run-time for versions that do not support
- -- taskVarLib: eg VxWorks 6 RTPs
-
- function taskVarAdd
- (tid : t_id; pVar : access System.Address) return int;
- pragma Import (C, taskVarAdd, "taskVarAdd");
-
- function taskVarDelete
- (tid : t_id; pVar : access System.Address) return int;
- pragma Import (C, taskVarDelete, "taskVarDelete");
-
- function taskVarSet
- (tid : t_id;
- pVar : access System.Address;
- value : System.Address) return int;
- pragma Import (C, taskVarSet, "taskVarSet");
-
- function taskVarGet
- (tid : t_id;
- pVar : access System.Address) return int;
- pragma Import (C, taskVarGet, "taskVarGet");
-
- -- VxWorks 6.x specific functions
-
- -- Can only be called from the VxWorks 6 run-time libary that supports
- -- tlsLib, and not by the VxWorks 6.6 SMP library
-
- function tlsKeyCreate return int;
- pragma Import (C, tlsKeyCreate, "tlsKeyCreate");
-
- function tlsValueGet (key : int) return System.Address;
- pragma Import (C, tlsValueGet, "tlsValueGet");
-
- function tlsValueSet (key : int; value : System.Address) return STATUS;
- pragma Import (C, tlsValueSet, "tlsValueSet");
-
- -- Option flags for taskSpawn
-
- VX_UNBREAKABLE : constant := 16#0002#;
- VX_FP_PRIVATE_ENV : constant := 16#0080#;
- VX_NO_STACK_FILL : constant := 16#0100#;
-
- function taskSpawn
- (name : System.Address; -- Pointer to task name
- priority : int;
- options : int;
- stacksize : size_t;
- start_routine : System.Address;
- arg1 : System.Address;
- arg2 : int := 0;
- arg3 : int := 0;
- arg4 : int := 0;
- arg5 : int := 0;
- arg6 : int := 0;
- arg7 : int := 0;
- arg8 : int := 0;
- arg9 : int := 0;
- arg10 : int := 0) return t_id;
- pragma Import (C, taskSpawn, "taskSpawn");
-
- procedure taskDelete (tid : t_id);
- pragma Import (C, taskDelete, "taskDelete");
-
- function Set_Time_Slice (ticks : int) return int
- renames System.VxWorks.Ext.Set_Time_Slice;
- -- Calls kernelTimeSlice under VxWorks 5.x, VxWorks 653, or in VxWorks 6
- -- kernel apps. Returns ERROR for RTPs, VxWorks 5 /CERT
-
- function taskPriorityGet (tid : t_id; pPriority : access int) return int;
- pragma Import (C, taskPriorityGet, "taskPriorityGet");
-
- function taskPrioritySet (tid : t_id; newPriority : int) return int;
- pragma Import (C, taskPrioritySet, "taskPrioritySet");
-
- -- Semaphore creation flags
-
- SEM_Q_FIFO : constant := 0;
- SEM_Q_PRIORITY : constant := 1;
- SEM_DELETE_SAFE : constant := 4; -- only valid for binary semaphore
- SEM_INVERSION_SAFE : constant := 8; -- only valid for binary semaphore
-
- -- Semaphore initial state flags
-
- SEM_EMPTY : constant := 0;
- SEM_FULL : constant := 1;
-
- -- Semaphore take (semTake) time constants
-
- WAIT_FOREVER : constant := -1;
- NO_WAIT : constant := 0;
-
- -- Error codes (errno). The lower level 16 bits are the error code, with
- -- the upper 16 bits representing the module number in which the error
- -- occurred. By convention, the module number is 0 for UNIX errors. VxWorks
- -- reserves module numbers 1-500, with the remaining module numbers being
- -- available for user applications.
-
- M_objLib : constant := 61 * 2**16;
- -- semTake() failure with ticks = NO_WAIT
- S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2;
- -- semTake() timeout with ticks > NO_WAIT
- S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4;
-
- subtype SEM_ID is System.VxWorks.Ext.SEM_ID;
- -- typedef struct semaphore *SEM_ID;
-
- -- We use two different kinds of VxWorks semaphores: mutex and binary
- -- semaphores. A null ID is returned when a semaphore cannot be created.
-
- function semBCreate (options : int; initial_state : int) return SEM_ID;
- pragma Import (C, semBCreate, "semBCreate");
- -- Create a binary semaphore. Return ID, or 0 if memory could not
- -- be allocated.
-
- function semMCreate (options : int) return SEM_ID;
- pragma Import (C, semMCreate, "semMCreate");
-
- function semDelete (Sem : SEM_ID) return int
- renames System.VxWorks.Ext.semDelete;
- -- Delete a semaphore
-
- function semGive (Sem : SEM_ID) return int;
- pragma Import (C, semGive, "semGive");
-
- function semTake (Sem : SEM_ID; timeout : int) return int;
- pragma Import (C, semTake, "semTake");
- -- Attempt to take binary semaphore. Error is returned if operation
- -- times out
-
- function semFlush (SemID : SEM_ID) return STATUS;
- pragma Import (C, semFlush, "semFlush");
- -- Release all threads blocked on the semaphore
-
- ------------------------------------------------------------
- -- Binary Semaphore Wrapper to Support interrupt Tasks --
- ------------------------------------------------------------
-
- type Binary_Semaphore_Id is new Long_Integer;
-
- function Binary_Semaphore_Create return Binary_Semaphore_Id;
- pragma Inline (Binary_Semaphore_Create);
-
- function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int;
- pragma Inline (Binary_Semaphore_Delete);
-
- function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int;
- pragma Inline (Binary_Semaphore_Obtain);
-
- function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int;
- pragma Inline (Binary_Semaphore_Release);
-
- function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int;
- pragma Inline (Binary_Semaphore_Flush);
-
- ------------------------------------------------------------
- -- Hardware Interrupt Wrappers to Support Interrupt Tasks --
- ------------------------------------------------------------
-
- type Interrupt_Handler is access procedure (parameter : System.Address);
- pragma Convention (C, Interrupt_Handler);
-
- type Interrupt_Vector is new System.Address;
-
- function Interrupt_Connect
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler;
- Parameter : System.Address := System.Null_Address) return int;
- pragma Inline (Interrupt_Connect);
- -- Use this to set up an user handler. The routine installs a user handler
- -- which is invoked after the OS has saved enough context for a high-level
- -- language routine to be safely invoked.
-
- function Interrupt_Context return int;
- pragma Inline (Interrupt_Context);
- -- Return 1 if executing in an interrupt context; return 0 if executing in
- -- a task context.
-
- function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector;
- pragma Inline (Interrupt_Number_To_Vector);
- -- Convert a logical interrupt number to the hardware interrupt vector
- -- number used to connect the interrupt.
-
- --------------------------------
- -- Processor Affinity for SMP --
- --------------------------------
-
- function taskCpuAffinitySet (tid : t_id; CPU : int) return int
- renames System.VxWorks.Ext.taskCpuAffinitySet;
- -- For SMP run-times the affinity to CPU.
- -- For uniprocessor systems return ERROR status.
-
- function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int
- renames System.VxWorks.Ext.taskMaskAffinitySet;
- -- For SMP run-times the affinity to CPU_Set.
- -- For uniprocessor systems return ERROR status.
-
- ---------------------
- -- Multiprocessors --
- ---------------------
-
- function Current_CPU return Multiprocessors.CPU;
- -- Return the id of the current CPU
-
-private
- type pid_t is new int;
-
- ERROR_PID : constant pid_t := -1;
-
- type sigset_t is new System.VxWorks.Ext.sigset_t;
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is for Linux/x32
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
-with Interfaces.C; use Interfaces.C;
-package body System.OS_Interface is
-
- --------------------
- -- Get_Stack_Base --
- --------------------
-
- function Get_Stack_Base (thread : pthread_t) return Address is
- pragma Warnings (Off, thread);
-
- begin
- return Null_Address;
- end Get_Stack_Base;
-
- ------------------
- -- pthread_init --
- ------------------
-
- procedure pthread_init is
- begin
- null;
- end pthread_init;
-
- -----------------
- -- To_Duration --
- -----------------
-
- function To_Duration (TS : timespec) return Duration is
- begin
- return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
- end To_Duration;
-
- ------------------------
- -- To_Target_Priority --
- ------------------------
-
- function To_Target_Priority
- (Prio : System.Any_Priority) return Interfaces.C.int
- is
- begin
- return Interfaces.C.int (Prio);
- end To_Target_Priority;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- use type System.Linux.time_t;
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return timespec'(tv_sec => S,
- tv_nsec => Long_Long_Integer (F * 10#1#E9));
- end To_Timespec;
-
-end System.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the definitions and routines 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a no tasking version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-package body System.Task_Primitives.Operations is
-
- use System.Tasking;
- use System.Parameters;
-
- pragma Warnings (Off);
- -- Turn off warnings since so many unreferenced parameters
-
- --------------
- -- Specific --
- --------------
-
- -- Package Specific contains target specific routines, and the body of
- -- this package is target specific.
-
- package Specific is
- procedure Set (Self_Id : Task_Id);
- pragma Inline (Set);
- -- Set the self id for the current task
- end Specific;
-
- package body Specific is
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- begin
- null;
- end Set;
- end Specific;
-
- ----------------------------------
- -- ATCB allocation/deallocation --
- ----------------------------------
-
- package body ATCB_Allocation is separate;
- -- The body of this package is shared across several targets
-
- ----------------
- -- Abort_Task --
- ----------------
-
- procedure Abort_Task (T : Task_Id) is
- begin
- null;
- end Abort_Task;
-
- ----------------
- -- Check_Exit --
- ----------------
-
- function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
- begin
- return True;
- end Check_Exit;
-
- --------------------
- -- Check_No_Locks --
- --------------------
-
- function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
- begin
- return True;
- end Check_No_Locks;
-
- -------------------
- -- Continue_Task --
- -------------------
-
- function Continue_Task (T : ST.Task_Id) return Boolean is
- begin
- return False;
- end Continue_Task;
-
- -------------------
- -- Current_State --
- -------------------
-
- function Current_State (S : Suspension_Object) return Boolean is
- begin
- return False;
- end Current_State;
-
- ----------------------
- -- Environment_Task --
- ----------------------
-
- function Environment_Task return Task_Id is
- begin
- return null;
- end Environment_Task;
-
- -----------------
- -- Create_Task --
- -----------------
-
- procedure Create_Task
- (T : Task_Id;
- Wrapper : System.Address;
- Stack_Size : System.Parameters.Size_Type;
- Priority : System.Any_Priority;
- Succeeded : out Boolean)
- is
- begin
- Succeeded := False;
- end Create_Task;
-
- ----------------
- -- Enter_Task --
- ----------------
-
- procedure Enter_Task (Self_ID : Task_Id) is
- begin
- null;
- end Enter_Task;
-
- ---------------
- -- Exit_Task --
- ---------------
-
- procedure Exit_Task is
- begin
- null;
- end Exit_Task;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (S : in out Suspension_Object) is
- begin
- null;
- end Finalize;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : not null access Lock) is
- begin
- null;
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : not null access RTS_Lock) is
- begin
- null;
- end Finalize_Lock;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- begin
- null;
- end Finalize_TCB;
-
- ------------------
- -- Get_Priority --
- ------------------
-
- function Get_Priority (T : Task_Id) return System.Any_Priority is
- begin
- return 0;
- end Get_Priority;
-
- --------------------
- -- Get_Thread_Id --
- --------------------
-
- function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
- begin
- return OSI.Thread_Id (T.Common.LL.Thread);
- end Get_Thread_Id;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- No_Tasking : Boolean;
- begin
- raise Program_Error with "tasking not implemented on this configuration";
- end Initialize;
-
- procedure Initialize (S : in out Suspension_Object) is
- begin
- null;
- end Initialize;
-
- ---------------------
- -- Initialize_Lock --
- ---------------------
-
- procedure Initialize_Lock
- (Prio : System.Any_Priority;
- L : not null access Lock)
- is
- begin
- null;
- end Initialize_Lock;
-
- procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level) is
- begin
- null;
- end Initialize_Lock;
-
- --------------------
- -- Initialize_TCB --
- --------------------
-
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- begin
- Succeeded := False;
- end Initialize_TCB;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- begin
- return False;
- end Is_Valid_Task;
-
- --------------
- -- Lock_RTS --
- --------------
-
- procedure Lock_RTS is
- begin
- null;
- end Lock_RTS;
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- function Monotonic_Clock return Duration is
- begin
- return 0.0;
- end Monotonic_Clock;
-
- ---------------
- -- Read_Lock --
- ---------------
-
- procedure Read_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- begin
- Ceiling_Violation := False;
- end Read_Lock;
-
- -----------------------------
- -- Register_Foreign_Thread --
- -----------------------------
-
- function Register_Foreign_Thread return Task_Id is
- begin
- return null;
- end Register_Foreign_Thread;
-
- -----------------
- -- Resume_Task --
- -----------------
-
- function Resume_Task
- (T : ST.Task_Id;
- Thread_Self : OSI.Thread_Id) return Boolean
- is
- begin
- return False;
- end Resume_Task;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- begin
- return 10#1.0#E-6;
- end RT_Resolution;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_Id is
- begin
- return Null_Task;
- end Self;
-
- -----------------
- -- Set_Ceiling --
- -----------------
-
- procedure Set_Ceiling
- (L : not null access Lock;
- Prio : System.Any_Priority)
- is
- begin
- null;
- end Set_Ceiling;
-
- ---------------
- -- Set_False --
- ---------------
-
- procedure Set_False (S : in out Suspension_Object) is
- begin
- null;
- end Set_False;
-
- ------------------
- -- Set_Priority --
- ------------------
-
- procedure Set_Priority
- (T : Task_Id;
- Prio : System.Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- begin
- null;
- end Set_Priority;
-
- -----------------------
- -- Set_Task_Affinity --
- -----------------------
-
- procedure Set_Task_Affinity (T : ST.Task_Id) is
- begin
- null;
- end Set_Task_Affinity;
-
- --------------
- -- Set_True --
- --------------
-
- procedure Set_True (S : in out Suspension_Object) is
- begin
- null;
- end Set_True;
-
- -----------
- -- Sleep --
- -----------
-
- procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
- begin
- null;
- end Sleep;
-
- -----------------
- -- Stack_Guard --
- -----------------
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- begin
- null;
- end Stack_Guard;
-
- ------------------
- -- Suspend_Task --
- ------------------
-
- function Suspend_Task
- (T : ST.Task_Id;
- Thread_Self : OSI.Thread_Id) return Boolean
- is
- begin
- return False;
- end Suspend_Task;
-
- --------------------
- -- Stop_All_Tasks --
- --------------------
-
- procedure Stop_All_Tasks is
- begin
- null;
- end Stop_All_Tasks;
-
- ---------------
- -- Stop_Task --
- ---------------
-
- function Stop_Task (T : ST.Task_Id) return Boolean is
- pragma Unreferenced (T);
- begin
- return False;
- end Stop_Task;
-
- ------------------------
- -- Suspend_Until_True --
- ------------------------
-
- procedure Suspend_Until_True (S : in out Suspension_Object) is
- begin
- null;
- end Suspend_Until_True;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- begin
- null;
- end Timed_Delay;
-
- -----------------
- -- Timed_Sleep --
- -----------------
-
- procedure Timed_Sleep
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes;
- Reason : System.Tasking.Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- begin
- Timedout := False;
- Yielded := False;
- end Timed_Sleep;
-
- ------------
- -- Unlock --
- ------------
-
- procedure Unlock (L : not null access Lock) is
- begin
- null;
- end Unlock;
-
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- begin
- null;
- end Unlock;
-
- procedure Unlock (T : Task_Id) is
- begin
- null;
- end Unlock;
-
- ----------------
- -- Unlock_RTS --
- ----------------
-
- procedure Unlock_RTS is
- begin
- null;
- end Unlock_RTS;
- ------------
- -- Wakeup --
- ------------
-
- procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
- begin
- null;
- end Wakeup;
-
- ----------------
- -- Write_Lock --
- ----------------
-
- procedure Write_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- begin
- Ceiling_Violation := False;
- end Write_Lock;
-
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- begin
- null;
- end Write_Lock;
-
- procedure Write_Lock (T : Task_Id) is
- begin
- null;
- end Write_Lock;
-
- -----------
- -- Yield --
- -----------
-
- procedure Yield (Do_Yield : Boolean := True) is
- begin
- null;
- end Yield;
-
-end System.Task_Primitives.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a HP-UX DCE threads (HPUX 10) version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-with System.Tasking.Debug;
-with System.Interrupt_Management;
-with System.OS_Constants;
-with System.OS_Primitives;
-with System.Task_Primitives.Interrupt_Operations;
-
-pragma Warnings (Off);
-with System.Interrupt_Management.Operations;
-pragma Elaborate_All (System.Interrupt_Management.Operations);
-pragma Warnings (On);
-
-with System.Soft_Links;
--- We use System.Soft_Links instead of System.Tasking.Initialization
--- because the later is a higher level package that we shouldn't depend on.
--- For example when using the restricted run time, it is replaced by
--- System.Tasking.Restricted.Stages.
-
-package body System.Task_Primitives.Operations is
-
- package OSC renames System.OS_Constants;
- package SSL renames System.Soft_Links;
-
- use System.Tasking.Debug;
- use System.Tasking;
- use Interfaces.C;
- use System.OS_Interface;
- use System.Parameters;
- use System.OS_Primitives;
-
- package PIO renames System.Task_Primitives.Interrupt_Operations;
-
- ----------------
- -- Local Data --
- ----------------
-
- -- The followings are logically constants, but need to be initialized
- -- at run time.
-
- Single_RTS_Lock : aliased RTS_Lock;
- -- This is a lock to allow only one thread of control in the RTS at
- -- a time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-
- Environment_Task_Id : Task_Id;
- -- A variable to hold Task_Id for the environment task
-
- Unblocked_Signal_Mask : aliased sigset_t;
- -- The set of signals that should unblocked in all tasks
-
- Time_Slice_Val : Integer;
- pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
-
- Dispatching_Policy : Character;
- pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
-
- -- Note: the reason that Locking_Policy is not needed is that this
- -- is not implemented for DCE threads. The HPUX 10 port is at this
- -- stage considered dead, and no further work is planned on it.
-
- Foreign_Task_Elaborated : aliased Boolean := True;
- -- Used to identified fake tasks (i.e., non-Ada Threads)
-
- --------------------
- -- Local Packages --
- --------------------
-
- package Specific is
-
- procedure Initialize (Environment_Task : Task_Id);
- pragma Inline (Initialize);
- -- Initialize various data needed by this package
-
- function Is_Valid_Task return Boolean;
- pragma Inline (Is_Valid_Task);
- -- Does the executing thread have a TCB?
-
- procedure Set (Self_Id : Task_Id);
- pragma Inline (Set);
- -- Set the self id for the current task
-
- function Self return Task_Id;
- pragma Inline (Self);
- -- Return a pointer to the Ada Task Control Block of the calling task
-
- end Specific;
-
- package body Specific is separate;
- -- The body of this package is target specific
-
- ----------------------------------
- -- ATCB allocation/deallocation --
- ----------------------------------
-
- package body ATCB_Allocation is separate;
- -- The body of this package is shared across several targets
-
- ---------------------------------
- -- Support for foreign threads --
- ---------------------------------
-
- function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread
-
- function Register_Foreign_Thread
- (Thread : Thread_Id) return Task_Id is separate;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Abort_Handler (Sig : Signal);
-
- function To_Address is
- new Ada.Unchecked_Conversion (Task_Id, System.Address);
-
- -------------------
- -- Abort_Handler --
- -------------------
-
- procedure Abort_Handler (Sig : Signal) is
- pragma Unreferenced (Sig);
-
- Self_Id : constant Task_Id := Self;
- Result : Interfaces.C.int;
- Old_Set : aliased sigset_t;
-
- begin
- if Self_Id.Deferral_Level = 0
- and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
- and then not Self_Id.Aborting
- then
- Self_Id.Aborting := True;
-
- -- Make sure signals used for RTS internal purpose are unmasked
-
- Result :=
- pthread_sigmask
- (SIG_UNBLOCK,
- Unblocked_Signal_Mask'Access,
- Old_Set'Access);
- pragma Assert (Result = 0);
-
- raise Standard'Abort_Signal;
- end if;
- end Abort_Handler;
-
- -----------------
- -- Stack_Guard --
- -----------------
-
- -- The underlying thread system sets a guard page at the bottom of a thread
- -- stack, so nothing is needed.
- -- ??? Check the comment above
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- pragma Unreferenced (T, On);
- begin
- null;
- end Stack_Guard;
-
- -------------------
- -- Get_Thread_Id --
- -------------------
-
- function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
- begin
- return T.Common.LL.Thread;
- end Get_Thread_Id;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_Id renames Specific.Self;
-
- ---------------------
- -- Initialize_Lock --
- ---------------------
-
- -- Note: mutexes and cond_variables needed per-task basis are initialized
- -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
- -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
- -- status change of RTS. Therefore raising Storage_Error in the following
- -- routines should be able to be handled safely.
-
- procedure Initialize_Lock
- (Prio : System.Any_Priority;
- L : not null access Lock)
- is
- Attributes : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
-
- begin
- Result := pthread_mutexattr_init (Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- L.Priority := Prio;
-
- Result := pthread_mutex_init (L.L'Access, Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- Result := pthread_mutexattr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
- end Initialize_Lock;
-
- procedure Initialize_Lock
- (L : not null access RTS_Lock;
- Level : Lock_Level)
- is
- pragma Unreferenced (Level);
-
- Attributes : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
-
- begin
- Result := pthread_mutexattr_init (Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- Result := pthread_mutex_init (L, Attributes'Access);
-
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- Result := pthread_mutexattr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
- end Initialize_Lock;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : not null access Lock) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_mutex_destroy (L.L'Access);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : not null access RTS_Lock) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_mutex_destroy (L);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- ----------------
- -- Write_Lock --
- ----------------
-
- procedure Write_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- Result : Interfaces.C.int;
-
- begin
- L.Owner_Priority := Get_Priority (Self);
-
- if L.Priority < L.Owner_Priority then
- Ceiling_Violation := True;
- return;
- end if;
-
- Result := pthread_mutex_lock (L.L'Access);
- pragma Assert (Result = 0);
- Ceiling_Violation := False;
- end Write_Lock;
-
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_lock (L);
- pragma Assert (Result = 0);
- end if;
- end Write_Lock;
-
- procedure Write_Lock (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock then
- Result := pthread_mutex_lock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
- end Write_Lock;
-
- ---------------
- -- Read_Lock --
- ---------------
-
- procedure Read_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- begin
- Write_Lock (L, Ceiling_Violation);
- end Read_Lock;
-
- ------------
- -- Unlock --
- ------------
-
- procedure Unlock (L : not null access Lock) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_mutex_unlock (L.L'Access);
- pragma Assert (Result = 0);
- end Unlock;
-
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_unlock (L);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- procedure Unlock (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock then
- Result := pthread_mutex_unlock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- -----------------
- -- Set_Ceiling --
- -----------------
-
- -- Dynamic priority ceilings are not supported by the underlying system
-
- procedure Set_Ceiling
- (L : not null access Lock;
- Prio : System.Any_Priority)
- is
- pragma Unreferenced (L, Prio);
- begin
- null;
- end Set_Ceiling;
-
- -----------
- -- Sleep --
- -----------
-
- procedure Sleep
- (Self_ID : Task_Id;
- Reason : System.Tasking.Task_States)
- is
- pragma Unreferenced (Reason);
-
- Result : Interfaces.C.int;
-
- begin
- Result :=
- pthread_cond_wait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access));
-
- -- EINTR is not considered a failure
-
- pragma Assert (Result = 0 or else Result = EINTR);
- end Sleep;
-
- -----------------
- -- Timed_Sleep --
- -----------------
-
- procedure Timed_Sleep
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes;
- Reason : System.Tasking.Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- pragma Unreferenced (Reason);
-
- Check_Time : constant Duration := Monotonic_Clock;
- Abs_Time : Duration;
- Request : aliased timespec;
- Result : Interfaces.C.int;
-
- begin
- Timedout := True;
- Yielded := False;
-
- Abs_Time :=
- (if Mode = Relative
- then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (Abs_Time);
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- Result :=
- pthread_cond_timedwait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
- abstime => Request'Access);
-
- exit when Abs_Time <= Monotonic_Clock;
-
- if Result = 0 or Result = EINTR then
-
- -- Somebody may have called Wakeup for us
-
- Timedout := False;
- exit;
- end if;
-
- pragma Assert (Result = ETIMEDOUT);
- end loop;
- end if;
- end Timed_Sleep;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Check_Time : constant Duration := Monotonic_Clock;
- Abs_Time : Duration;
- Request : aliased timespec;
-
- Result : Interfaces.C.int;
- pragma Warnings (Off, Result);
-
- begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
- Write_Lock (Self_ID);
-
- Abs_Time :=
- (if Mode = Relative
- then Time + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (Abs_Time);
- Self_ID.Common.State := Delay_Sleep;
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- Result :=
- pthread_cond_timedwait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
- abstime => Request'Access);
-
- exit when Abs_Time <= Monotonic_Clock;
-
- pragma Assert (Result = 0 or else
- Result = ETIMEDOUT or else
- Result = EINTR);
- end loop;
-
- Self_ID.Common.State := Runnable;
- end if;
-
- Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
- Result := sched_yield;
- end Timed_Delay;
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- function Monotonic_Clock return Duration is
- TS : aliased timespec;
- Result : Interfaces.C.int;
- begin
- Result := Clock_Gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
- pragma Assert (Result = 0);
- return To_Duration (TS);
- end Monotonic_Clock;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- begin
- return 10#1.0#E-6;
- end RT_Resolution;
-
- ------------
- -- Wakeup --
- ------------
-
- procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
- pragma Unreferenced (Reason);
- Result : Interfaces.C.int;
- begin
- Result := pthread_cond_signal (T.Common.LL.CV'Access);
- pragma Assert (Result = 0);
- end Wakeup;
-
- -----------
- -- Yield --
- -----------
-
- procedure Yield (Do_Yield : Boolean := True) is
- Result : Interfaces.C.int;
- pragma Unreferenced (Result);
- begin
- if Do_Yield then
- Result := sched_yield;
- end if;
- end Yield;
-
- ------------------
- -- Set_Priority --
- ------------------
-
- type Prio_Array_Type is array (System.Any_Priority) of Integer;
- pragma Atomic_Components (Prio_Array_Type);
-
- Prio_Array : Prio_Array_Type;
- -- Global array containing the id of the currently running task for
- -- each priority.
- --
- -- Note: assume we are on single processor with run-til-blocked scheduling
-
- procedure Set_Priority
- (T : Task_Id;
- Prio : System.Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- Result : Interfaces.C.int;
- Array_Item : Integer;
- Param : aliased struct_sched_param;
-
- function Get_Policy (Prio : System.Any_Priority) return Character;
- pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
- -- Get priority specific dispatching policy
-
- Priority_Specific_Policy : constant Character := Get_Policy (Prio);
- -- Upper case first character of the policy name corresponding to the
- -- task as set by a Priority_Specific_Dispatching pragma.
-
- begin
- Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
-
- if Dispatching_Policy = 'R'
- or else Priority_Specific_Policy = 'R'
- or else Time_Slice_Val > 0
- then
- Result :=
- pthread_setschedparam
- (T.Common.LL.Thread, SCHED_RR, Param'Access);
-
- elsif Dispatching_Policy = 'F'
- or else Priority_Specific_Policy = 'F'
- or else Time_Slice_Val = 0
- then
- Result :=
- pthread_setschedparam
- (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
-
- else
- Result :=
- pthread_setschedparam
- (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
- end if;
-
- pragma Assert (Result = 0);
-
- if Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' then
-
- -- Annex D requirement [RM D.2.2 par. 9]:
- -- If the task drops its priority due to the loss of inherited
- -- priority, it is added at the head of the ready queue for its
- -- new active priority.
-
- if Loss_Of_Inheritance
- and then Prio < T.Common.Current_Priority
- then
- Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
- Prio_Array (T.Common.Base_Priority) := Array_Item;
-
- loop
- -- Let some processes a chance to arrive
-
- Yield;
-
- -- Then wait for our turn to proceed
-
- exit when Array_Item = Prio_Array (T.Common.Base_Priority)
- or else Prio_Array (T.Common.Base_Priority) = 1;
- end loop;
-
- Prio_Array (T.Common.Base_Priority) :=
- Prio_Array (T.Common.Base_Priority) - 1;
- end if;
- end if;
-
- T.Common.Current_Priority := Prio;
- end Set_Priority;
-
- ------------------
- -- Get_Priority --
- ------------------
-
- function Get_Priority (T : Task_Id) return System.Any_Priority is
- begin
- return T.Common.Current_Priority;
- end Get_Priority;
-
- ----------------
- -- Enter_Task --
- ----------------
-
- procedure Enter_Task (Self_ID : Task_Id) is
- begin
- Self_ID.Common.LL.Thread := pthread_self;
- Specific.Set (Self_ID);
- end Enter_Task;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
-
- -----------------------------
- -- Register_Foreign_Thread --
- -----------------------------
-
- function Register_Foreign_Thread return Task_Id is
- begin
- if Is_Valid_Task then
- return Self;
- else
- return Register_Foreign_Thread (pthread_self);
- end if;
- end Register_Foreign_Thread;
-
- --------------------
- -- Initialize_TCB --
- --------------------
-
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- Mutex_Attr : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
- Cond_Attr : aliased pthread_condattr_t;
-
- begin
- if not Single_Lock then
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = 0 then
- Result :=
- pthread_mutex_init
- (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
- end if;
-
- if Result /= 0 then
- Succeeded := False;
- return;
- end if;
-
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result = 0);
- end if;
-
- Result := pthread_condattr_init (Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = 0 then
- Result :=
- pthread_cond_init
- (Self_ID.Common.LL.CV'Access,
- Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
- end if;
-
- if Result = 0 then
- Succeeded := True;
- else
- if not Single_Lock then
- Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
-
- Succeeded := False;
- end if;
-
- Result := pthread_condattr_destroy (Cond_Attr'Access);
- pragma Assert (Result = 0);
- end Initialize_TCB;
-
- -----------------
- -- Create_Task --
- -----------------
-
- procedure Create_Task
- (T : Task_Id;
- Wrapper : System.Address;
- Stack_Size : System.Parameters.Size_Type;
- Priority : System.Any_Priority;
- Succeeded : out Boolean)
- is
- Attributes : aliased pthread_attr_t;
- Result : Interfaces.C.int;
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- begin
- Result := pthread_attr_init (Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result /= 0 then
- Succeeded := False;
- return;
- end if;
-
- Result := pthread_attr_setstacksize
- (Attributes'Access, Interfaces.C.size_t (Stack_Size));
- pragma Assert (Result = 0);
-
- -- Since the initial signal mask of a thread is inherited from the
- -- creator, and the Environment task has all its signals masked, we
- -- do not need to manipulate caller's signal mask at this point.
- -- All tasks in RTS will have All_Tasks_Mask initially.
-
- Result := pthread_create
- (T.Common.LL.Thread'Access,
- Attributes'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
- pragma Assert (Result = 0 or else Result = EAGAIN);
-
- Succeeded := Result = 0;
-
- pthread_detach (T.Common.LL.Thread'Access);
- -- Detach the thread using pthread_detach, since DCE threads do not have
- -- pthread_attr_set_detachstate.
-
- Result := pthread_attr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
-
- Set_Priority (T, Priority);
- end Create_Task;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- Result : Interfaces.C.int;
-
- begin
- if not Single_Lock then
- Result := pthread_mutex_destroy (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
-
- Result := pthread_cond_destroy (T.Common.LL.CV'Access);
- pragma Assert (Result = 0);
-
- if T.Known_Tasks_Index /= -1 then
- Known_Tasks (T.Known_Tasks_Index) := null;
- end if;
-
- ATCB_Allocation.Free_ATCB (T);
- end Finalize_TCB;
-
- ---------------
- -- Exit_Task --
- ---------------
-
- procedure Exit_Task is
- begin
- Specific.Set (null);
- end Exit_Task;
-
- ----------------
- -- Abort_Task --
- ----------------
-
- procedure Abort_Task (T : Task_Id) is
- begin
- -- Interrupt Server_Tasks may be waiting on an "event" flag (signal)
-
- if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
- System.Interrupt_Management.Operations.Interrupt_Self_Process
- (PIO.Get_Interrupt_ID (T));
- end if;
- end Abort_Task;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (S : in out Suspension_Object) is
- Mutex_Attr : aliased pthread_mutexattr_t;
- Cond_Attr : aliased pthread_condattr_t;
- Result : Interfaces.C.int;
- begin
- -- Initialize internal state (always to False (ARM D.10(6)))
-
- S.State := False;
- S.Waiting := False;
-
- -- Initialize internal mutex
-
- Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- -- Initialize internal condition variable
-
- Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result /= 0 then
- Result := pthread_mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
- end if;
- end Initialize;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- -- Destroy internal mutex
-
- Result := pthread_mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- -- Destroy internal condition variable
-
- Result := pthread_cond_destroy (S.CV'Access);
- pragma Assert (Result = 0);
- end Finalize;
-
- -------------------
- -- Current_State --
- -------------------
-
- function Current_State (S : Suspension_Object) return Boolean is
- begin
- -- We do not want to use lock on this read operation. State is marked
- -- as Atomic so that we ensure that the value retrieved is correct.
-
- return S.State;
- end Current_State;
-
- ---------------
- -- Set_False --
- ---------------
-
- procedure Set_False (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := pthread_mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- S.State := False;
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end Set_False;
-
- --------------
- -- Set_True --
- --------------
-
- procedure Set_True (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := pthread_mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- -- If there is already a task waiting on this suspension object then
- -- we resume it, leaving the state of the suspension object to False,
- -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
- -- the state to True.
-
- if S.Waiting then
- S.Waiting := False;
- S.State := False;
-
- Result := pthread_cond_signal (S.CV'Access);
- pragma Assert (Result = 0);
-
- else
- S.State := True;
- end if;
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end Set_True;
-
- ------------------------
- -- Suspend_Until_True --
- ------------------------
-
- procedure Suspend_Until_True (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := pthread_mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- if S.Waiting then
- -- Program_Error must be raised upon calling Suspend_Until_True
- -- if another task is already waiting on that suspension object
- -- (ARM D.10 par. 10).
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
-
- raise Program_Error;
- else
- -- Suspend the task if the state is False. Otherwise, the task
- -- continues its execution, and the state of the suspension object
- -- is set to False (ARM D.10 par. 9).
-
- if S.State then
- S.State := False;
- else
- S.Waiting := True;
-
- loop
- -- Loop in case pthread_cond_wait returns earlier than expected
- -- (e.g. in case of EINTR caused by a signal).
-
- Result := pthread_cond_wait (S.CV'Access, S.L'Access);
- pragma Assert (Result = 0 or else Result = EINTR);
-
- exit when not S.Waiting;
- end loop;
- end if;
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end if;
- end Suspend_Until_True;
-
- ----------------
- -- Check_Exit --
- ----------------
-
- -- Dummy version
-
- function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
- pragma Unreferenced (Self_ID);
- begin
- return True;
- end Check_Exit;
-
- --------------------
- -- Check_No_Locks --
- --------------------
-
- function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
- pragma Unreferenced (Self_ID);
- begin
- return True;
- end Check_No_Locks;
-
- ----------------------
- -- Environment_Task --
- ----------------------
-
- function Environment_Task return Task_Id is
- begin
- return Environment_Task_Id;
- end Environment_Task;
-
- --------------
- -- Lock_RTS --
- --------------
-
- procedure Lock_RTS is
- begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
- end Lock_RTS;
-
- ----------------
- -- Unlock_RTS --
- ----------------
-
- procedure Unlock_RTS is
- begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
- end Unlock_RTS;
-
- ------------------
- -- Suspend_Task --
- ------------------
-
- function Suspend_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- pragma Unreferenced (T);
- pragma Unreferenced (Thread_Self);
- begin
- return False;
- end Suspend_Task;
-
- -----------------
- -- Resume_Task --
- -----------------
-
- function Resume_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- pragma Unreferenced (T);
- pragma Unreferenced (Thread_Self);
- begin
- return False;
- end Resume_Task;
-
- --------------------
- -- Stop_All_Tasks --
- --------------------
-
- procedure Stop_All_Tasks is
- begin
- null;
- end Stop_All_Tasks;
-
- ---------------
- -- Stop_Task --
- ---------------
-
- function Stop_Task (T : ST.Task_Id) return Boolean is
- pragma Unreferenced (T);
- begin
- return False;
- end Stop_Task;
-
- -------------------
- -- Continue_Task --
- -------------------
-
- function Continue_Task (T : ST.Task_Id) return Boolean is
- pragma Unreferenced (T);
- begin
- return False;
- end Continue_Task;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Tmp_Set : aliased sigset_t;
- Result : Interfaces.C.int;
-
- function State
- (Int : System.Interrupt_Management.Interrupt_ID) return Character;
- pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in a-init.c. The input argument is
- -- the interrupt number, and the result is one of the following:
-
- Default : constant Character := 's';
- -- 'n' this interrupt not set by any Interrupt_State pragma
- -- 'u' Interrupt_State pragma set state to User
- -- 'r' Interrupt_State pragma set state to Runtime
- -- 's' Interrupt_State pragma set state to System (use "default"
- -- system handler)
-
- begin
- Environment_Task_Id := Environment_Task;
-
- Interrupt_Management.Initialize;
-
- -- Initialize the lock used to synchronize chain of all ATCBs
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- Specific.Initialize (Environment_Task);
-
- -- Make environment task known here because it doesn't go through
- -- Activate_Tasks, which does it for all other tasks.
-
- Known_Tasks (Known_Tasks'First) := Environment_Task;
- Environment_Task.Known_Tasks_Index := Known_Tasks'First;
-
- Enter_Task (Environment_Task);
-
- -- Install the abort-signal handler
-
- if State (System.Interrupt_Management.Abort_Task_Interrupt)
- /= Default
- then
- act.sa_flags := 0;
- act.sa_handler := Abort_Handler'Address;
-
- Result := sigemptyset (Tmp_Set'Access);
- pragma Assert (Result = 0);
- act.sa_mask := Tmp_Set;
-
- Result :=
- sigaction (
- Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
- end if;
- end Initialize;
-
- -- NOTE: Unlike other pthread implementations, we do *not* mask all
- -- signals here since we handle signals using the process-wide primitive
- -- signal, rather than using sigthreadmask and sigwait. The reason of
- -- this difference is that sigwait doesn't work when some critical
- -- signals (SIGABRT, SIGPIPE) are masked.
-
- -----------------------
- -- Set_Task_Affinity --
- -----------------------
-
- procedure Set_Task_Affinity (T : ST.Task_Id) is
- pragma Unreferenced (T);
-
- begin
- -- Setting task affinity is not supported by the underlying system
-
- null;
- end Set_Task_Affinity;
-
-end System.Task_Primitives.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a GNU/Linux (GNU/LinuxThreads) version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with Interfaces.C; use Interfaces; use type Interfaces.C.int;
-
-with System.Task_Info;
-with System.Tasking.Debug;
-with System.Interrupt_Management;
-with System.OS_Constants;
-with System.OS_Primitives;
-with System.Multiprocessors;
-
-with System.Soft_Links;
--- We use System.Soft_Links instead of System.Tasking.Initialization
--- because the later is a higher level package that we shouldn't depend on.
--- For example when using the restricted run time, it is replaced by
--- System.Tasking.Restricted.Stages.
-
-package body System.Task_Primitives.Operations is
-
- package OSC renames System.OS_Constants;
- package SSL renames System.Soft_Links;
-
- use System.Tasking.Debug;
- use System.Tasking;
- use System.OS_Interface;
- use System.Parameters;
- use System.OS_Primitives;
- use System.Task_Info;
-
- ----------------
- -- Local Data --
- ----------------
-
- -- The followings are logically constants, but need to be initialized
- -- at run time.
-
- Single_RTS_Lock : aliased RTS_Lock;
- -- This is a lock to allow only one thread of control in the RTS at
- -- a time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-
- Environment_Task_Id : Task_Id;
- -- A variable to hold Task_Id for the environment task
-
- Unblocked_Signal_Mask : aliased sigset_t;
- -- The set of signals that should be unblocked in all tasks
-
- -- The followings are internal configuration constants needed
-
- Next_Serial_Number : Task_Serial_Number := 100;
- -- We start at 100 (reserve some special values for using in error checks)
-
- Time_Slice_Val : Integer;
- pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
-
- Dispatching_Policy : Character;
- pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
-
- Locking_Policy : Character;
- pragma Import (C, Locking_Policy, "__gl_locking_policy");
-
- Foreign_Task_Elaborated : aliased Boolean := True;
- -- Used to identified fake tasks (i.e., non-Ada Threads)
-
- Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
- -- Whether to use an alternate signal stack for stack overflows
-
- Abort_Handler_Installed : Boolean := False;
- -- True if a handler for the abort signal is installed
-
- Null_Thread_Id : constant pthread_t := pthread_t'Last;
- -- Constant to indicate that the thread identifier has not yet been
- -- initialized.
-
- --------------------
- -- Local Packages --
- --------------------
-
- package Specific is
-
- procedure Initialize (Environment_Task : Task_Id);
- pragma Inline (Initialize);
- -- Initialize various data needed by this package
-
- function Is_Valid_Task return Boolean;
- pragma Inline (Is_Valid_Task);
- -- Does executing thread have a TCB?
-
- procedure Set (Self_Id : Task_Id);
- pragma Inline (Set);
- -- Set the self id for the current task
-
- function Self return Task_Id;
- pragma Inline (Self);
- -- Return a pointer to the Ada Task Control Block of the calling task
-
- end Specific;
-
- package body Specific is separate;
- -- The body of this package is target specific
-
- ----------------------------------
- -- ATCB allocation/deallocation --
- ----------------------------------
-
- package body ATCB_Allocation is separate;
- -- The body of this package is shared across several targets
-
- ---------------------------------
- -- Support for foreign threads --
- ---------------------------------
-
- function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread
-
- function Register_Foreign_Thread
- (Thread : Thread_Id) return Task_Id is separate;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Abort_Handler (signo : Signal);
-
- function GNAT_pthread_condattr_setup
- (attr : access pthread_condattr_t) return C.int;
- pragma Import
- (C, GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
-
- function GNAT_has_cap_sys_nice return C.int;
- pragma Import
- (C, GNAT_has_cap_sys_nice, "__gnat_has_cap_sys_nice");
- -- We do not have pragma Linker_Options ("-lcap"); here, because this
- -- library is not present on many Linux systems. 'libcap' is the Linux
- -- "capabilities" library, called by __gnat_has_cap_sys_nice.
-
- function Prio_To_Linux_Prio (Prio : Any_Priority) return C.int is
- (C.int (Prio) + 1);
- -- Convert Ada priority to Linux priority. Priorities are 1 .. 99 on
- -- GNU/Linux, so we map 0 .. 98 to 1 .. 99.
-
- function Get_Ceiling_Support return Boolean;
- -- Get the value of the Ceiling_Support constant (see below).
- -- Note well: If this function or related code is modified, it should be
- -- tested by hand, because automated testing doesn't exercise it.
-
- function Get_Ceiling_Support return Boolean is
- Ceiling_Support : Boolean := False;
- begin
- if Locking_Policy /= 'C' then
- return False;
- end if;
-
- declare
- function geteuid return Integer;
- pragma Import (C, geteuid, "geteuid");
- Superuser : constant Boolean := geteuid = 0;
- Has_Cap : constant C.int := GNAT_has_cap_sys_nice;
- pragma Assert (Has_Cap in 0 | 1);
- begin
- Ceiling_Support := Superuser or else Has_Cap = 1;
- end;
-
- return Ceiling_Support;
- end Get_Ceiling_Support;
-
- pragma Warnings (Off, "non-static call not allowed in preelaborated unit");
- Ceiling_Support : constant Boolean := Get_Ceiling_Support;
- pragma Warnings (On, "non-static call not allowed in preelaborated unit");
- -- True if the locking policy is Ceiling_Locking, and the current process
- -- has permission to use this policy. The process has permission if it is
- -- running as 'root', or if the capability was set by the setcap command,
- -- as in "sudo /sbin/setcap cap_sys_nice=ep exe_file". If it doesn't have
- -- permission, then a request for Ceiling_Locking is ignored.
-
- type RTS_Lock_Ptr is not null access all RTS_Lock;
-
- function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int;
- -- Initialize the mutex L. If Ceiling_Support is True, then set the ceiling
- -- to Prio. Returns 0 for success, or ENOMEM for out-of-memory.
-
- -------------------
- -- Abort_Handler --
- -------------------
-
- procedure Abort_Handler (signo : Signal) is
- pragma Unreferenced (signo);
-
- Self_Id : constant Task_Id := Self;
- Result : C.int;
- Old_Set : aliased sigset_t;
-
- begin
- -- It's not safe to raise an exception when using GCC ZCX mechanism.
- -- Note that we still need to install a signal handler, since in some
- -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
- -- need to send the Abort signal to a task.
-
- if ZCX_By_Default then
- return;
- end if;
-
- if Self_Id.Deferral_Level = 0
- and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
- and then not Self_Id.Aborting
- then
- Self_Id.Aborting := True;
-
- -- Make sure signals used for RTS internal purpose are unmasked
-
- Result :=
- pthread_sigmask
- (SIG_UNBLOCK,
- Unblocked_Signal_Mask'Access,
- Old_Set'Access);
- pragma Assert (Result = 0);
-
- raise Standard'Abort_Signal;
- end if;
- end Abort_Handler;
-
- --------------
- -- Lock_RTS --
- --------------
-
- procedure Lock_RTS is
- begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
- end Lock_RTS;
-
- ----------------
- -- Unlock_RTS --
- ----------------
-
- procedure Unlock_RTS is
- begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
- end Unlock_RTS;
-
- -----------------
- -- Stack_Guard --
- -----------------
-
- -- The underlying thread system extends the memory (up to 2MB) when needed
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- pragma Unreferenced (T);
- pragma Unreferenced (On);
- begin
- null;
- end Stack_Guard;
-
- --------------------
- -- Get_Thread_Id --
- --------------------
-
- function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
- begin
- return T.Common.LL.Thread;
- end Get_Thread_Id;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_Id renames Specific.Self;
-
- ----------------
- -- Init_Mutex --
- ----------------
-
- function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int is
- Mutex_Attr : aliased pthread_mutexattr_t;
- Result, Result_2 : C.int;
-
- begin
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result in 0 | ENOMEM);
-
- if Result = ENOMEM then
- return Result;
- end if;
-
- if Ceiling_Support then
- Result := pthread_mutexattr_setprotocol
- (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
- pragma Assert (Result = 0);
-
- Result := pthread_mutexattr_setprioceiling
- (Mutex_Attr'Access, Prio_To_Linux_Prio (Prio));
- pragma Assert (Result = 0);
-
- elsif Locking_Policy = 'I' then
- Result := pthread_mutexattr_setprotocol
- (Mutex_Attr'Access, PTHREAD_PRIO_INHERIT);
- pragma Assert (Result = 0);
- end if;
-
- Result := pthread_mutex_init (L, Mutex_Attr'Access);
- pragma Assert (Result in 0 | ENOMEM);
-
- Result_2 := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result_2 = 0);
- return Result; -- of pthread_mutex_init, not pthread_mutexattr_destroy
- end Init_Mutex;
-
- ---------------------
- -- Initialize_Lock --
- ---------------------
-
- -- Note: mutexes and cond_variables needed per-task basis are initialized
- -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
- -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
- -- status change of RTS. Therefore raising Storage_Error in the following
- -- routines should be able to be handled safely.
-
- procedure Initialize_Lock
- (Prio : Any_Priority;
- L : not null access Lock)
- is
- begin
- if Locking_Policy = 'R' then
- declare
- RWlock_Attr : aliased pthread_rwlockattr_t;
- Result : C.int;
-
- begin
- -- Set the rwlock to prefer writer to avoid writers starvation
-
- Result := pthread_rwlockattr_init (RWlock_Attr'Access);
- pragma Assert (Result = 0);
-
- Result := pthread_rwlockattr_setkind_np
- (RWlock_Attr'Access,
- PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP);
- pragma Assert (Result = 0);
-
- Result := pthread_rwlock_init (L.RW'Access, RWlock_Attr'Access);
-
- pragma Assert (Result in 0 | ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error with "Failed to allocate a lock";
- end if;
- end;
-
- else
- if Init_Mutex (L.WO'Access, Prio) = ENOMEM then
- raise Storage_Error with "Failed to allocate a lock";
- end if;
- end if;
- end Initialize_Lock;
-
- procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level)
- is
- pragma Unreferenced (Level);
- begin
- if Init_Mutex (L.all'Access, Any_Priority'Last) = ENOMEM then
- raise Storage_Error with "Failed to allocate a lock";
- end if;
- end Initialize_Lock;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : not null access Lock) is
- Result : C.int;
- begin
- if Locking_Policy = 'R' then
- Result := pthread_rwlock_destroy (L.RW'Access);
- else
- Result := pthread_mutex_destroy (L.WO'Access);
- end if;
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : not null access RTS_Lock) is
- Result : C.int;
- begin
- Result := pthread_mutex_destroy (L);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- ----------------
- -- Write_Lock --
- ----------------
-
- procedure Write_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- Result : C.int;
- begin
- if Locking_Policy = 'R' then
- Result := pthread_rwlock_wrlock (L.RW'Access);
- else
- Result := pthread_mutex_lock (L.WO'Access);
- end if;
-
- -- The cause of EINVAL is a priority ceiling violation
-
- pragma Assert (Result in 0 | EINVAL);
- Ceiling_Violation := Result = EINVAL;
- end Write_Lock;
-
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : C.int;
- begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_lock (L);
- pragma Assert (Result = 0);
- end if;
- end Write_Lock;
-
- procedure Write_Lock (T : Task_Id) is
- Result : C.int;
- begin
- if not Single_Lock then
- Result := pthread_mutex_lock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
- end Write_Lock;
-
- ---------------
- -- Read_Lock --
- ---------------
-
- procedure Read_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- Result : C.int;
- begin
- if Locking_Policy = 'R' then
- Result := pthread_rwlock_rdlock (L.RW'Access);
- else
- Result := pthread_mutex_lock (L.WO'Access);
- end if;
-
- -- The cause of EINVAL is a priority ceiling violation
-
- pragma Assert (Result in 0 | EINVAL);
- Ceiling_Violation := Result = EINVAL;
- end Read_Lock;
-
- ------------
- -- Unlock --
- ------------
-
- procedure Unlock (L : not null access Lock) is
- Result : C.int;
- begin
- if Locking_Policy = 'R' then
- Result := pthread_rwlock_unlock (L.RW'Access);
- else
- Result := pthread_mutex_unlock (L.WO'Access);
- end if;
- pragma Assert (Result = 0);
- end Unlock;
-
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : C.int;
- begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_unlock (L);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- procedure Unlock (T : Task_Id) is
- Result : C.int;
- begin
- if not Single_Lock then
- Result := pthread_mutex_unlock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- -----------------
- -- Set_Ceiling --
- -----------------
-
- -- Dynamic priority ceilings are not supported by the underlying system
-
- procedure Set_Ceiling
- (L : not null access Lock;
- Prio : Any_Priority)
- is
- pragma Unreferenced (L, Prio);
- begin
- null;
- end Set_Ceiling;
-
- -----------
- -- Sleep --
- -----------
-
- procedure Sleep
- (Self_ID : Task_Id;
- Reason : System.Tasking.Task_States)
- is
- pragma Unreferenced (Reason);
-
- Result : C.int;
-
- begin
- pragma Assert (Self_ID = Self);
-
- Result :=
- pthread_cond_wait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access));
-
- -- EINTR is not considered a failure
-
- pragma Assert (Result in 0 | EINTR);
- end Sleep;
-
- -----------------
- -- Timed_Sleep --
- -----------------
-
- -- This is for use within the run-time system, so abort is
- -- assumed to be already deferred, and the caller should be
- -- holding its own ATCB lock.
-
- procedure Timed_Sleep
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes;
- Reason : System.Tasking.Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- pragma Unreferenced (Reason);
-
- Base_Time : constant Duration := Monotonic_Clock;
- Check_Time : Duration := Base_Time;
- Abs_Time : Duration;
- Request : aliased timespec;
- Result : C.int;
-
- begin
- Timedout := True;
- Yielded := False;
-
- Abs_Time :=
- (if Mode = Relative
- then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (Abs_Time);
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- Result :=
- pthread_cond_timedwait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
- abstime => Request'Access);
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- if Result in 0 | EINTR then
-
- -- Somebody may have called Wakeup for us
-
- Timedout := False;
- exit;
- end if;
-
- pragma Assert (Result = ETIMEDOUT);
- end loop;
- end if;
- end Timed_Sleep;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- -- This is for use in implementing delay statements, so we assume the
- -- caller is abort-deferred but is holding no locks.
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Base_Time : constant Duration := Monotonic_Clock;
- Check_Time : Duration := Base_Time;
- Abs_Time : Duration;
- Request : aliased timespec;
-
- Result : C.int;
- pragma Warnings (Off, Result);
-
- begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
- Write_Lock (Self_ID);
-
- Abs_Time :=
- (if Mode = Relative
- then Time + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (Abs_Time);
- Self_ID.Common.State := Delay_Sleep;
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- Result :=
- pthread_cond_timedwait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
- abstime => Request'Access);
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- pragma Assert (Result in 0 | ETIMEDOUT | EINTR);
- end loop;
-
- Self_ID.Common.State := Runnable;
- end if;
-
- Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
- Result := sched_yield;
- end Timed_Delay;
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- function Monotonic_Clock return Duration is
- TS : aliased timespec;
- Result : C.int;
- begin
- Result := clock_gettime
- (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
- pragma Assert (Result = 0);
-
- return To_Duration (TS);
- end Monotonic_Clock;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- TS : aliased timespec;
- Result : C.int;
-
- begin
- Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
- pragma Assert (Result = 0);
-
- return To_Duration (TS);
- end RT_Resolution;
-
- ------------
- -- Wakeup --
- ------------
-
- procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
- pragma Unreferenced (Reason);
- Result : C.int;
- begin
- Result := pthread_cond_signal (T.Common.LL.CV'Access);
- pragma Assert (Result = 0);
- end Wakeup;
-
- -----------
- -- Yield --
- -----------
-
- procedure Yield (Do_Yield : Boolean := True) is
- Result : C.int;
- pragma Unreferenced (Result);
- begin
- if Do_Yield then
- Result := sched_yield;
- end if;
- end Yield;
-
- ------------------
- -- Set_Priority --
- ------------------
-
- procedure Set_Priority
- (T : Task_Id;
- Prio : Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- pragma Unreferenced (Loss_Of_Inheritance);
-
- Result : C.int;
- Param : aliased struct_sched_param;
-
- function Get_Policy (Prio : Any_Priority) return Character;
- pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
- -- Get priority specific dispatching policy
-
- Priority_Specific_Policy : constant Character := Get_Policy (Prio);
- -- Upper case first character of the policy name corresponding to the
- -- task as set by a Priority_Specific_Dispatching pragma.
-
- begin
- T.Common.Current_Priority := Prio;
-
- Param.sched_priority := Prio_To_Linux_Prio (Prio);
-
- if Dispatching_Policy = 'R'
- or else Priority_Specific_Policy = 'R'
- or else Time_Slice_Val > 0
- then
- Result :=
- pthread_setschedparam
- (T.Common.LL.Thread, SCHED_RR, Param'Access);
-
- elsif Dispatching_Policy = 'F'
- or else Priority_Specific_Policy = 'F'
- or else Time_Slice_Val = 0
- then
- Result :=
- pthread_setschedparam
- (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
-
- else
- Param.sched_priority := 0;
- Result :=
- pthread_setschedparam
- (T.Common.LL.Thread,
- SCHED_OTHER, Param'Access);
- end if;
-
- pragma Assert (Result in 0 | EPERM | EINVAL);
- end Set_Priority;
-
- ------------------
- -- Get_Priority --
- ------------------
-
- function Get_Priority (T : Task_Id) return Any_Priority is
- begin
- return T.Common.Current_Priority;
- end Get_Priority;
-
- ----------------
- -- Enter_Task --
- ----------------
-
- procedure Enter_Task (Self_ID : Task_Id) is
- begin
- if Self_ID.Common.Task_Info /= null
- and then Self_ID.Common.Task_Info.CPU_Affinity = No_CPU
- then
- raise Invalid_CPU_Number;
- end if;
-
- Self_ID.Common.LL.Thread := pthread_self;
- Self_ID.Common.LL.LWP := lwp_self;
-
- -- Set thread name to ease debugging. If the name of the task is
- -- "foreign thread" (as set by Register_Foreign_Thread) retrieve
- -- the name of the thread and update the name of the task instead.
-
- if Self_ID.Common.Task_Image_Len = 14
- and then Self_ID.Common.Task_Image (1 .. 14) = "foreign thread"
- then
- declare
- Thread_Name : String (1 .. 16);
- -- PR_GET_NAME returns a string of up to 16 bytes
-
- Len : Natural := 0;
- -- Length of the task name contained in Task_Name
-
- Result : C.int;
- -- Result from the prctl call
- begin
- Result := prctl (PR_GET_NAME, unsigned_long (Thread_Name'Address));
- pragma Assert (Result = 0);
-
- -- Find the length of the given name
-
- for J in Thread_Name'Range loop
- if Thread_Name (J) /= ASCII.NUL then
- Len := Len + 1;
- else
- exit;
- end if;
- end loop;
-
- -- Cover the odd situation where someone decides to change
- -- Parameters.Max_Task_Image_Length to less than 16 characters.
-
- if Len > Parameters.Max_Task_Image_Length then
- Len := Parameters.Max_Task_Image_Length;
- end if;
-
- -- Copy the name of the thread to the task's ATCB
-
- Self_ID.Common.Task_Image (1 .. Len) := Thread_Name (1 .. Len);
- Self_ID.Common.Task_Image_Len := Len;
- end;
-
- elsif Self_ID.Common.Task_Image_Len > 0 then
- declare
- Task_Name : String (1 .. Parameters.Max_Task_Image_Length + 1);
- Result : C.int;
-
- begin
- Task_Name (1 .. Self_ID.Common.Task_Image_Len) :=
- Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len);
- Task_Name (Self_ID.Common.Task_Image_Len + 1) := ASCII.NUL;
-
- Result := prctl (PR_SET_NAME, unsigned_long (Task_Name'Address));
- pragma Assert (Result = 0);
- end;
- end if;
-
- Specific.Set (Self_ID);
-
- if Use_Alternate_Stack
- and then Self_ID.Common.Task_Alternate_Stack /= Null_Address
- then
- declare
- Stack : aliased stack_t;
- Result : C.int;
- begin
- Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack;
- Stack.ss_size := Alternate_Stack_Size;
- Stack.ss_flags := 0;
- Result := sigaltstack (Stack'Access, null);
- pragma Assert (Result = 0);
- end;
- end if;
- end Enter_Task;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
-
- -----------------------------
- -- Register_Foreign_Thread --
- -----------------------------
-
- function Register_Foreign_Thread return Task_Id is
- begin
- if Is_Valid_Task then
- return Self;
- else
- return Register_Foreign_Thread (pthread_self);
- end if;
- end Register_Foreign_Thread;
-
- --------------------
- -- Initialize_TCB --
- --------------------
-
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- Result : C.int;
- Cond_Attr : aliased pthread_condattr_t;
-
- begin
- -- Give the task a unique serial number
-
- Self_ID.Serial_Number := Next_Serial_Number;
- Next_Serial_Number := Next_Serial_Number + 1;
- pragma Assert (Next_Serial_Number /= 0);
-
- Self_ID.Common.LL.Thread := Null_Thread_Id;
-
- if not Single_Lock then
- if Init_Mutex
- (Self_ID.Common.LL.L'Access, Any_Priority'Last) /= 0
- then
- Succeeded := False;
- return;
- end if;
- end if;
-
- Result := pthread_condattr_init (Cond_Attr'Access);
- pragma Assert (Result in 0 | ENOMEM);
-
- if Result = 0 then
- Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
- pragma Assert (Result = 0);
-
- Result :=
- pthread_cond_init
- (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
- pragma Assert (Result in 0 | ENOMEM);
- end if;
-
- if Result = 0 then
- Succeeded := True;
- else
- if not Single_Lock then
- Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
-
- Succeeded := False;
- end if;
-
- Result := pthread_condattr_destroy (Cond_Attr'Access);
- pragma Assert (Result = 0);
- end Initialize_TCB;
-
- -----------------
- -- Create_Task --
- -----------------
-
- procedure Create_Task
- (T : Task_Id;
- Wrapper : System.Address;
- Stack_Size : System.Parameters.Size_Type;
- Priority : Any_Priority;
- Succeeded : out Boolean)
- is
- Thread_Attr : aliased pthread_attr_t;
- Adjusted_Stack_Size : C.size_t;
- Result : C.int;
-
- use type Multiprocessors.CPU_Range, Interfaces.C.size_t;
-
- begin
- -- Check whether both Dispatching_Domain and CPU are specified for
- -- the task, and the CPU value is not contained within the range of
- -- processors for the domain.
-
- if T.Common.Domain /= null
- and then T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU
- and then
- (T.Common.Base_CPU not in T.Common.Domain'Range
- or else not T.Common.Domain (T.Common.Base_CPU))
- then
- Succeeded := False;
- return;
- end if;
-
- Adjusted_Stack_Size := C.size_t (Stack_Size + Alternate_Stack_Size);
-
- Result := pthread_attr_init (Thread_Attr'Access);
- pragma Assert (Result in 0 | ENOMEM);
-
- if Result /= 0 then
- Succeeded := False;
- return;
- end if;
-
- Result :=
- pthread_attr_setstacksize (Thread_Attr'Access, Adjusted_Stack_Size);
- pragma Assert (Result = 0);
-
- Result :=
- pthread_attr_setdetachstate
- (Thread_Attr'Access, PTHREAD_CREATE_DETACHED);
- pragma Assert (Result = 0);
-
- -- Set the required attributes for the creation of the thread
-
- -- Note: Previously, we called pthread_setaffinity_np (after thread
- -- creation but before thread activation) to set the affinity but it was
- -- not behaving as expected. Setting the required attributes for the
- -- creation of the thread works correctly and it is more appropriate.
-
- -- Do nothing if required support not provided by the operating system
-
- if pthread_attr_setaffinity_np'Address = Null_Address then
- null;
-
- -- Support is available
-
- elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
- declare
- CPUs : constant size_t :=
- C.size_t (Multiprocessors.Number_Of_CPUs);
- CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
- Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
-
- begin
- CPU_ZERO (Size, CPU_Set);
- System.OS_Interface.CPU_SET
- (int (T.Common.Base_CPU), Size, CPU_Set);
- Result :=
- pthread_attr_setaffinity_np (Thread_Attr'Access, Size, CPU_Set);
- pragma Assert (Result = 0);
-
- CPU_FREE (CPU_Set);
- end;
-
- -- Handle Task_Info
-
- elsif T.Common.Task_Info /= null then
- Result :=
- pthread_attr_setaffinity_np
- (Thread_Attr'Access,
- CPU_SETSIZE / 8,
- T.Common.Task_Info.CPU_Affinity'Access);
- pragma Assert (Result = 0);
-
- -- Handle dispatching domains
-
- -- To avoid changing CPU affinities when not needed, we set the
- -- affinity only when assigning to a domain other than the default
- -- one, or when the default one has been modified.
-
- elsif T.Common.Domain /= null and then
- (T.Common.Domain /= ST.System_Domain
- or else T.Common.Domain.all /=
- (Multiprocessors.CPU'First ..
- Multiprocessors.Number_Of_CPUs => True))
- then
- declare
- CPUs : constant size_t :=
- C.size_t (Multiprocessors.Number_Of_CPUs);
- CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
- Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
-
- begin
- CPU_ZERO (Size, CPU_Set);
-
- -- Set the affinity to all the processors belonging to the
- -- dispatching domain.
-
- for Proc in T.Common.Domain'Range loop
- if T.Common.Domain (Proc) then
- System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
- end if;
- end loop;
-
- Result :=
- pthread_attr_setaffinity_np (Thread_Attr'Access, Size, CPU_Set);
- pragma Assert (Result = 0);
-
- CPU_FREE (CPU_Set);
- end;
- end if;
-
- -- Since the initial signal mask of a thread is inherited from the
- -- creator, and the Environment task has all its signals masked, we
- -- do not need to manipulate caller's signal mask at this point.
- -- All tasks in RTS will have All_Tasks_Mask initially.
-
- -- Note: the use of Unrestricted_Access in the following call is needed
- -- because otherwise we have an error of getting a access-to-volatile
- -- value which points to a non-volatile object. But in this case it is
- -- safe to do this, since we know we have no problems with aliasing and
- -- Unrestricted_Access bypasses this check.
-
- Result := pthread_create
- (T.Common.LL.Thread'Unrestricted_Access,
- Thread_Attr'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
-
- pragma Assert (Result in 0 | EAGAIN | ENOMEM);
-
- if Result /= 0 then
- Succeeded := False;
- Result := pthread_attr_destroy (Thread_Attr'Access);
- pragma Assert (Result = 0);
- return;
- end if;
-
- Succeeded := True;
-
- Result := pthread_attr_destroy (Thread_Attr'Access);
- pragma Assert (Result = 0);
-
- Set_Priority (T, Priority);
- end Create_Task;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- Result : C.int;
-
- begin
- if not Single_Lock then
- Result := pthread_mutex_destroy (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
-
- Result := pthread_cond_destroy (T.Common.LL.CV'Access);
- pragma Assert (Result = 0);
-
- if T.Known_Tasks_Index /= -1 then
- Known_Tasks (T.Known_Tasks_Index) := null;
- end if;
-
- ATCB_Allocation.Free_ATCB (T);
- end Finalize_TCB;
-
- ---------------
- -- Exit_Task --
- ---------------
-
- procedure Exit_Task is
- begin
- Specific.Set (null);
- end Exit_Task;
-
- ----------------
- -- Abort_Task --
- ----------------
-
- procedure Abort_Task (T : Task_Id) is
- Result : C.int;
-
- ESRCH : constant := 3; -- No such process
- -- It can happen that T has already vanished, in which case pthread_kill
- -- returns ESRCH, so we don't consider that to be an error.
-
- begin
- if Abort_Handler_Installed then
- Result :=
- pthread_kill
- (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
- pragma Assert (Result in 0 | ESRCH);
- end if;
- end Abort_Task;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (S : in out Suspension_Object) is
- Result : C.int;
-
- begin
- -- Initialize internal state (always to False (RM D.10(6)))
-
- S.State := False;
- S.Waiting := False;
-
- -- Initialize internal mutex
-
- Result := pthread_mutex_init (S.L'Access, null);
-
- pragma Assert (Result in 0 | ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- -- Initialize internal condition variable
-
- Result := pthread_cond_init (S.CV'Access, null);
-
- pragma Assert (Result in 0 | ENOMEM);
-
- if Result /= 0 then
- Result := pthread_mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
- end if;
- end Initialize;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (S : in out Suspension_Object) is
- Result : C.int;
-
- begin
- -- Destroy internal mutex
-
- Result := pthread_mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- -- Destroy internal condition variable
-
- Result := pthread_cond_destroy (S.CV'Access);
- pragma Assert (Result = 0);
- end Finalize;
-
- -------------------
- -- Current_State --
- -------------------
-
- function Current_State (S : Suspension_Object) return Boolean is
- begin
- -- We do not want to use lock on this read operation. State is marked
- -- as Atomic so that we ensure that the value retrieved is correct.
-
- return S.State;
- end Current_State;
-
- ---------------
- -- Set_False --
- ---------------
-
- procedure Set_False (S : in out Suspension_Object) is
- Result : C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := pthread_mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- S.State := False;
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end Set_False;
-
- --------------
- -- Set_True --
- --------------
-
- procedure Set_True (S : in out Suspension_Object) is
- Result : C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := pthread_mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- -- If there is already a task waiting on this suspension object then
- -- we resume it, leaving the state of the suspension object to False,
- -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
- -- the state to True.
-
- if S.Waiting then
- S.Waiting := False;
- S.State := False;
-
- Result := pthread_cond_signal (S.CV'Access);
- pragma Assert (Result = 0);
-
- else
- S.State := True;
- end if;
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end Set_True;
-
- ------------------------
- -- Suspend_Until_True --
- ------------------------
-
- procedure Suspend_Until_True (S : in out Suspension_Object) is
- Result : C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := pthread_mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- if S.Waiting then
-
- -- Program_Error must be raised upon calling Suspend_Until_True
- -- if another task is already waiting on that suspension object
- -- (RM D.10(10)).
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
-
- raise Program_Error;
-
- else
- -- Suspend the task if the state is False. Otherwise, the task
- -- continues its execution, and the state of the suspension object
- -- is set to False (ARM D.10 par. 9).
-
- if S.State then
- S.State := False;
- else
- S.Waiting := True;
-
- loop
- -- Loop in case pthread_cond_wait returns earlier than expected
- -- (e.g. in case of EINTR caused by a signal). This should not
- -- happen with the current Linux implementation of pthread, but
- -- POSIX does not guarantee it so this may change in future.
-
- Result := pthread_cond_wait (S.CV'Access, S.L'Access);
- pragma Assert (Result in 0 | EINTR);
-
- exit when not S.Waiting;
- end loop;
- end if;
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end if;
- end Suspend_Until_True;
-
- ----------------
- -- Check_Exit --
- ----------------
-
- -- Dummy version
-
- function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
- pragma Unreferenced (Self_ID);
- begin
- return True;
- end Check_Exit;
-
- --------------------
- -- Check_No_Locks --
- --------------------
-
- function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
- pragma Unreferenced (Self_ID);
- begin
- return True;
- end Check_No_Locks;
-
- ----------------------
- -- Environment_Task --
- ----------------------
-
- function Environment_Task return Task_Id is
- begin
- return Environment_Task_Id;
- end Environment_Task;
-
- ------------------
- -- Suspend_Task --
- ------------------
-
- function Suspend_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- begin
- if T.Common.LL.Thread /= Thread_Self then
- return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0;
- else
- return True;
- end if;
- end Suspend_Task;
-
- -----------------
- -- Resume_Task --
- -----------------
-
- function Resume_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- begin
- if T.Common.LL.Thread /= Thread_Self then
- return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0;
- else
- return True;
- end if;
- end Resume_Task;
-
- --------------------
- -- Stop_All_Tasks --
- --------------------
-
- procedure Stop_All_Tasks is
- begin
- null;
- end Stop_All_Tasks;
-
- ---------------
- -- Stop_Task --
- ---------------
-
- function Stop_Task (T : ST.Task_Id) return Boolean is
- pragma Unreferenced (T);
- begin
- return False;
- end Stop_Task;
-
- -------------------
- -- Continue_Task --
- -------------------
-
- function Continue_Task (T : ST.Task_Id) return Boolean is
- pragma Unreferenced (T);
- begin
- return False;
- end Continue_Task;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Tmp_Set : aliased sigset_t;
- Result : C.int;
- -- Whether to use an alternate signal stack for stack overflows
-
- function State
- (Int : System.Interrupt_Management.Interrupt_ID) return Character;
- pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in a-init.c
- -- The input argument is the interrupt number,
- -- and the result is one of the following:
-
- Default : constant Character := 's';
- -- 'n' this interrupt not set by any Interrupt_State pragma
- -- 'u' Interrupt_State pragma set state to User
- -- 'r' Interrupt_State pragma set state to Runtime
- -- 's' Interrupt_State pragma set state to System (use "default"
- -- system handler)
-
- begin
- Environment_Task_Id := Environment_Task;
-
- Interrupt_Management.Initialize;
-
- -- Prepare the set of signals that should be unblocked in all tasks
-
- Result := sigemptyset (Unblocked_Signal_Mask'Access);
- pragma Assert (Result = 0);
-
- for J in Interrupt_Management.Interrupt_ID loop
- if System.Interrupt_Management.Keep_Unmasked (J) then
- Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
- pragma Assert (Result = 0);
- end if;
- end loop;
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- -- Initialize the global RTS lock
-
- Specific.Initialize (Environment_Task);
-
- if Use_Alternate_Stack then
- Environment_Task.Common.Task_Alternate_Stack :=
- Alternate_Stack'Address;
- end if;
-
- -- Make environment task known here because it doesn't go through
- -- Activate_Tasks, which does it for all other tasks.
-
- Known_Tasks (Known_Tasks'First) := Environment_Task;
- Environment_Task.Known_Tasks_Index := Known_Tasks'First;
-
- Enter_Task (Environment_Task);
-
- if State
- (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
- then
- act.sa_flags := 0;
- act.sa_handler := Abort_Handler'Address;
-
- Result := sigemptyset (Tmp_Set'Access);
- pragma Assert (Result = 0);
- act.sa_mask := Tmp_Set;
-
- Result :=
- sigaction
- (Signal (Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
- Abort_Handler_Installed := True;
- end if;
-
- -- pragma CPU and dispatching domains for the environment task
-
- Set_Task_Affinity (Environment_Task);
- end Initialize;
-
- -----------------------
- -- Set_Task_Affinity --
- -----------------------
-
- procedure Set_Task_Affinity (T : ST.Task_Id) is
- use type Multiprocessors.CPU_Range;
-
- begin
- -- Do nothing if there is no support for setting affinities or the
- -- underlying thread has not yet been created. If the thread has not
- -- yet been created then the proper affinity will be set during its
- -- creation.
-
- if pthread_setaffinity_np'Address /= Null_Address
- and then T.Common.LL.Thread /= Null_Thread_Id
- then
- declare
- CPUs : constant size_t :=
- C.size_t (Multiprocessors.Number_Of_CPUs);
- CPU_Set : cpu_set_t_ptr := null;
- Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
-
- Result : C.int;
-
- begin
- -- We look at the specific CPU (Base_CPU) first, then at the
- -- Task_Info field, and finally at the assigned dispatching
- -- domain, if any.
-
- if T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
-
- -- Set the affinity to an unique CPU
-
- CPU_Set := CPU_ALLOC (CPUs);
- System.OS_Interface.CPU_ZERO (Size, CPU_Set);
- System.OS_Interface.CPU_SET
- (int (T.Common.Base_CPU), Size, CPU_Set);
-
- -- Handle Task_Info
-
- elsif T.Common.Task_Info /= null then
- CPU_Set := T.Common.Task_Info.CPU_Affinity'Access;
-
- -- Handle dispatching domains
-
- elsif T.Common.Domain /= null and then
- (T.Common.Domain /= ST.System_Domain
- or else T.Common.Domain.all /=
- (Multiprocessors.CPU'First ..
- Multiprocessors.Number_Of_CPUs => True))
- then
- -- Set the affinity to all the processors belonging to the
- -- dispatching domain. To avoid changing CPU affinities when
- -- not needed, we set the affinity only when assigning to a
- -- domain other than the default one, or when the default one
- -- has been modified.
-
- CPU_Set := CPU_ALLOC (CPUs);
- System.OS_Interface.CPU_ZERO (Size, CPU_Set);
-
- for Proc in T.Common.Domain'Range loop
- if T.Common.Domain (Proc) then
- System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
- end if;
- end loop;
- end if;
-
- -- We set the new affinity if needed. Otherwise, the new task
- -- will inherit its creator's CPU affinity mask (according to
- -- the documentation of pthread_setaffinity_np), which is
- -- consistent with Ada's required semantics.
-
- if CPU_Set /= null then
- Result :=
- pthread_setaffinity_np (T.Common.LL.Thread, Size, CPU_Set);
- pragma Assert (Result = 0);
-
- CPU_FREE (CPU_Set);
- end if;
- end;
- end if;
- end Set_Task_Affinity;
-
-end System.Task_Primitives.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a NT (native) version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with Interfaces.C;
-with Interfaces.C.Strings;
-
-with System.Float_Control;
-with System.Interrupt_Management;
-with System.Multiprocessors;
-with System.OS_Primitives;
-with System.Task_Info;
-with System.Tasking.Debug;
-with System.Win32.Ext;
-
-with System.Soft_Links;
--- We use System.Soft_Links instead of System.Tasking.Initialization because
--- the later is a higher level package that we shouldn't depend on. For
--- example when using the restricted run time, it is replaced by
--- System.Tasking.Restricted.Stages.
-
-package body System.Task_Primitives.Operations is
-
- package SSL renames System.Soft_Links;
-
- use Interfaces.C;
- use Interfaces.C.Strings;
- use System.OS_Interface;
- use System.OS_Primitives;
- use System.Parameters;
- use System.Task_Info;
- use System.Tasking;
- use System.Tasking.Debug;
- use System.Win32;
- use System.Win32.Ext;
-
- pragma Link_With ("-Xlinker --stack=0x200000,0x1000");
- -- Change the default stack size (2 MB) for tasking programs on Windows.
- -- This allows about 1000 tasks running at the same time. Note that
- -- we set the stack size for non tasking programs on System unit.
- -- Also note that under Windows XP, we use a Windows XP extension to
- -- specify the stack size on a per task basis, as done under other OSes.
-
- ---------------------
- -- Local Functions --
- ---------------------
-
- procedure InitializeCriticalSection (pCriticalSection : access RTS_Lock);
- procedure InitializeCriticalSection
- (pCriticalSection : access CRITICAL_SECTION);
- pragma Import
- (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
-
- procedure EnterCriticalSection (pCriticalSection : access RTS_Lock);
- procedure EnterCriticalSection
- (pCriticalSection : access CRITICAL_SECTION);
- pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
-
- procedure LeaveCriticalSection (pCriticalSection : access RTS_Lock);
- procedure LeaveCriticalSection (pCriticalSection : access CRITICAL_SECTION);
- pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
-
- procedure DeleteCriticalSection (pCriticalSection : access RTS_Lock);
- procedure DeleteCriticalSection
- (pCriticalSection : access CRITICAL_SECTION);
- pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
-
- ----------------
- -- Local Data --
- ----------------
-
- Environment_Task_Id : Task_Id;
- -- A variable to hold Task_Id for the environment task
-
- Single_RTS_Lock : aliased RTS_Lock;
- -- This is a lock to allow only one thread of control in the RTS at
- -- a time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-
- Time_Slice_Val : Integer;
- pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
-
- Dispatching_Policy : Character;
- pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
-
- function Get_Policy (Prio : System.Any_Priority) return Character;
- pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
- -- Get priority specific dispatching policy
-
- Foreign_Task_Elaborated : aliased Boolean := True;
- -- Used to identified fake tasks (i.e., non-Ada Threads)
-
- Null_Thread_Id : constant Thread_Id := 0;
- -- Constant to indicate that the thread identifier has not yet been
- -- initialized.
-
- ------------------------------------
- -- The thread local storage index --
- ------------------------------------
-
- TlsIndex : DWORD;
- pragma Export (Ada, TlsIndex);
- -- To ensure that this variable won't be local to this package, since
- -- in some cases, inlining forces this variable to be global anyway.
-
- --------------------
- -- Local Packages --
- --------------------
-
- package Specific is
-
- function Is_Valid_Task return Boolean;
- pragma Inline (Is_Valid_Task);
- -- Does executing thread have a TCB?
-
- procedure Set (Self_Id : Task_Id);
- pragma Inline (Set);
- -- Set the self id for the current task
-
- end Specific;
-
- package body Specific is
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- begin
- return TlsGetValue (TlsIndex) /= System.Null_Address;
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- Succeeded : BOOL;
- begin
- Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
- pragma Assert (Succeeded = Win32.TRUE);
- end Set;
-
- end Specific;
-
- ----------------------------------
- -- ATCB allocation/deallocation --
- ----------------------------------
-
- package body ATCB_Allocation is separate;
- -- The body of this package is shared across several targets
-
- ---------------------------------
- -- Support for foreign threads --
- ---------------------------------
-
- function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread
-
- function Register_Foreign_Thread
- (Thread : Thread_Id) return Task_Id is separate;
-
- ----------------------------------
- -- Condition Variable Functions --
- ----------------------------------
-
- procedure Initialize_Cond (Cond : not null access Condition_Variable);
- -- Initialize given condition variable Cond
-
- procedure Finalize_Cond (Cond : not null access Condition_Variable);
- -- Finalize given condition variable Cond
-
- procedure Cond_Signal (Cond : not null access Condition_Variable);
- -- Signal condition variable Cond
-
- procedure Cond_Wait
- (Cond : not null access Condition_Variable;
- L : not null access RTS_Lock);
- -- Wait on conditional variable Cond, using lock L
-
- procedure Cond_Timed_Wait
- (Cond : not null access Condition_Variable;
- L : not null access RTS_Lock;
- Rel_Time : Duration;
- Timed_Out : out Boolean;
- Status : out Integer);
- -- Do timed wait on condition variable Cond using lock L. The duration
- -- of the timed wait is given by Rel_Time. When the condition is
- -- signalled, Timed_Out shows whether or not a time out occurred.
- -- Status is only valid if Timed_Out is False, in which case it
- -- shows whether Cond_Timed_Wait completed successfully.
-
- ---------------------
- -- Initialize_Cond --
- ---------------------
-
- procedure Initialize_Cond (Cond : not null access Condition_Variable) is
- hEvent : HANDLE;
- begin
- hEvent := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
- pragma Assert (hEvent /= 0);
- Cond.all := Condition_Variable (hEvent);
- end Initialize_Cond;
-
- -------------------
- -- Finalize_Cond --
- -------------------
-
- -- No such problem here, DosCloseEventSem has been derived.
- -- What does such refer to in above comment???
-
- procedure Finalize_Cond (Cond : not null access Condition_Variable) is
- Result : BOOL;
- begin
- Result := CloseHandle (HANDLE (Cond.all));
- pragma Assert (Result = Win32.TRUE);
- end Finalize_Cond;
-
- -----------------
- -- Cond_Signal --
- -----------------
-
- procedure Cond_Signal (Cond : not null access Condition_Variable) is
- Result : BOOL;
- begin
- Result := SetEvent (HANDLE (Cond.all));
- pragma Assert (Result = Win32.TRUE);
- end Cond_Signal;
-
- ---------------
- -- Cond_Wait --
- ---------------
-
- -- Pre-condition: Cond is posted
- -- L is locked.
-
- -- Post-condition: Cond is posted
- -- L is locked.
-
- procedure Cond_Wait
- (Cond : not null access Condition_Variable;
- L : not null access RTS_Lock)
- is
- Result : DWORD;
- Result_Bool : BOOL;
-
- begin
- -- Must reset Cond BEFORE L is unlocked
-
- Result_Bool := ResetEvent (HANDLE (Cond.all));
- pragma Assert (Result_Bool = Win32.TRUE);
- Unlock (L, Global_Lock => True);
-
- -- No problem if we are interrupted here: if the condition is signaled,
- -- WaitForSingleObject will simply not block
-
- Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
- pragma Assert (Result = 0);
-
- Write_Lock (L, Global_Lock => True);
- end Cond_Wait;
-
- ---------------------
- -- Cond_Timed_Wait --
- ---------------------
-
- -- Pre-condition: Cond is posted
- -- L is locked.
-
- -- Post-condition: Cond is posted
- -- L is locked.
-
- procedure Cond_Timed_Wait
- (Cond : not null access Condition_Variable;
- L : not null access RTS_Lock;
- Rel_Time : Duration;
- Timed_Out : out Boolean;
- Status : out Integer)
- is
- Time_Out_Max : constant DWORD := 16#FFFF0000#;
- -- NT 4 can't handle excessive timeout values (e.g. DWORD'Last - 1)
-
- Time_Out : DWORD;
- Result : BOOL;
- Wait_Result : DWORD;
-
- begin
- -- Must reset Cond BEFORE L is unlocked
-
- Result := ResetEvent (HANDLE (Cond.all));
- pragma Assert (Result = Win32.TRUE);
- Unlock (L, Global_Lock => True);
-
- -- No problem if we are interrupted here: if the condition is signaled,
- -- WaitForSingleObject will simply not block.
-
- if Rel_Time <= 0.0 then
- Timed_Out := True;
- Wait_Result := 0;
-
- else
- Time_Out :=
- (if Rel_Time >= Duration (Time_Out_Max) / 1000
- then Time_Out_Max
- else DWORD (Rel_Time * 1000));
-
- Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
-
- if Wait_Result = WAIT_TIMEOUT then
- Timed_Out := True;
- Wait_Result := 0;
- else
- Timed_Out := False;
- end if;
- end if;
-
- Write_Lock (L, Global_Lock => True);
-
- -- Ensure post-condition
-
- if Timed_Out then
- Result := SetEvent (HANDLE (Cond.all));
- pragma Assert (Result = Win32.TRUE);
- end if;
-
- Status := Integer (Wait_Result);
- end Cond_Timed_Wait;
-
- ------------------
- -- Stack_Guard --
- ------------------
-
- -- The underlying thread system sets a guard page at the bottom of a thread
- -- stack, so nothing is needed.
- -- ??? Check the comment above
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- pragma Unreferenced (T, On);
- begin
- null;
- end Stack_Guard;
-
- --------------------
- -- Get_Thread_Id --
- --------------------
-
- function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
- begin
- return T.Common.LL.Thread;
- end Get_Thread_Id;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_Id is
- Self_Id : constant Task_Id := To_Task_Id (TlsGetValue (TlsIndex));
- begin
- if Self_Id = null then
- return Register_Foreign_Thread (GetCurrentThread);
- else
- return Self_Id;
- end if;
- end Self;
-
- ---------------------
- -- Initialize_Lock --
- ---------------------
-
- -- Note: mutexes and cond_variables needed per-task basis are initialized
- -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
- -- as RTS_Lock, Memory_Lock...) used in the RTS is initialized before any
- -- status change of RTS. Therefore raising Storage_Error in the following
- -- routines should be able to be handled safely.
-
- procedure Initialize_Lock
- (Prio : System.Any_Priority;
- L : not null access Lock)
- is
- begin
- InitializeCriticalSection (L.Mutex'Access);
- L.Owner_Priority := 0;
- L.Priority := Prio;
- end Initialize_Lock;
-
- procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level)
- is
- pragma Unreferenced (Level);
- begin
- InitializeCriticalSection (L);
- end Initialize_Lock;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : not null access Lock) is
- begin
- DeleteCriticalSection (L.Mutex'Access);
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : not null access RTS_Lock) is
- begin
- DeleteCriticalSection (L);
- end Finalize_Lock;
-
- ----------------
- -- Write_Lock --
- ----------------
-
- procedure Write_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean) is
- begin
- L.Owner_Priority := Get_Priority (Self);
-
- if L.Priority < L.Owner_Priority then
- Ceiling_Violation := True;
- return;
- end if;
-
- EnterCriticalSection (L.Mutex'Access);
-
- Ceiling_Violation := False;
- end Write_Lock;
-
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- begin
- if not Single_Lock or else Global_Lock then
- EnterCriticalSection (L);
- end if;
- end Write_Lock;
-
- procedure Write_Lock (T : Task_Id) is
- begin
- if not Single_Lock then
- EnterCriticalSection (T.Common.LL.L'Access);
- end if;
- end Write_Lock;
-
- ---------------
- -- Read_Lock --
- ---------------
-
- procedure Read_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean) is
- begin
- Write_Lock (L, Ceiling_Violation);
- end Read_Lock;
-
- ------------
- -- Unlock --
- ------------
-
- procedure Unlock (L : not null access Lock) is
- begin
- LeaveCriticalSection (L.Mutex'Access);
- end Unlock;
-
- procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False) is
- begin
- if not Single_Lock or else Global_Lock then
- LeaveCriticalSection (L);
- end if;
- end Unlock;
-
- procedure Unlock (T : Task_Id) is
- begin
- if not Single_Lock then
- LeaveCriticalSection (T.Common.LL.L'Access);
- end if;
- end Unlock;
-
- -----------------
- -- Set_Ceiling --
- -----------------
-
- -- Dynamic priority ceilings are not supported by the underlying system
-
- procedure Set_Ceiling
- (L : not null access Lock;
- Prio : System.Any_Priority)
- is
- pragma Unreferenced (L, Prio);
- begin
- null;
- end Set_Ceiling;
-
- -----------
- -- Sleep --
- -----------
-
- procedure Sleep
- (Self_ID : Task_Id;
- Reason : System.Tasking.Task_States)
- is
- pragma Unreferenced (Reason);
-
- begin
- pragma Assert (Self_ID = Self);
-
- if Single_Lock then
- Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
- else
- Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
- end if;
-
- if Self_ID.Deferral_Level = 0
- and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- then
- Unlock (Self_ID);
- raise Standard'Abort_Signal;
- end if;
- end Sleep;
-
- -----------------
- -- Timed_Sleep --
- -----------------
-
- -- This is for use within the run-time system, so abort is assumed to be
- -- already deferred, and the caller should be holding its own ATCB lock.
-
- procedure Timed_Sleep
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes;
- Reason : System.Tasking.Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- pragma Unreferenced (Reason);
- Check_Time : Duration := Monotonic_Clock;
- Rel_Time : Duration;
- Abs_Time : Duration;
-
- Result : Integer;
- pragma Unreferenced (Result);
-
- Local_Timedout : Boolean;
-
- begin
- Timedout := True;
- Yielded := False;
-
- if Mode = Relative then
- Rel_Time := Time;
- Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
- else
- Rel_Time := Time - Check_Time;
- Abs_Time := Time;
- end if;
-
- if Rel_Time > 0.0 then
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- if Single_Lock then
- Cond_Timed_Wait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Rel_Time, Local_Timedout, Result);
- else
- Cond_Timed_Wait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access,
- Rel_Time, Local_Timedout, Result);
- end if;
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time;
-
- if not Local_Timedout then
-
- -- Somebody may have called Wakeup for us
-
- Timedout := False;
- exit;
- end if;
-
- Rel_Time := Abs_Time - Check_Time;
- end loop;
- end if;
- end Timed_Sleep;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Check_Time : Duration := Monotonic_Clock;
- Rel_Time : Duration;
- Abs_Time : Duration;
-
- Timedout : Boolean;
- Result : Integer;
- pragma Unreferenced (Timedout, Result);
-
- begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
- Write_Lock (Self_ID);
-
- if Mode = Relative then
- Rel_Time := Time;
- Abs_Time := Time + Check_Time;
- else
- Rel_Time := Time - Check_Time;
- Abs_Time := Time;
- end if;
-
- if Rel_Time > 0.0 then
- Self_ID.Common.State := Delay_Sleep;
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- if Single_Lock then
- Cond_Timed_Wait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Rel_Time, Timedout, Result);
- else
- Cond_Timed_Wait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access,
- Rel_Time, Timedout, Result);
- end if;
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time;
-
- Rel_Time := Abs_Time - Check_Time;
- end loop;
-
- Self_ID.Common.State := Runnable;
- end if;
-
- Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
- Yield;
- end Timed_Delay;
-
- ------------
- -- Wakeup --
- ------------
-
- procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
- pragma Unreferenced (Reason);
- begin
- Cond_Signal (T.Common.LL.CV'Access);
- end Wakeup;
-
- -----------
- -- Yield --
- -----------
-
- procedure Yield (Do_Yield : Boolean := True) is
- begin
- -- Note: in a previous implementation if Do_Yield was False, then we
- -- introduced a delay of 1 millisecond in an attempt to get closer to
- -- annex D semantics, and in particular to make ACATS CXD8002 pass. But
- -- this change introduced a huge performance regression evaluating the
- -- Count attribute. So we decided to remove this processing.
-
- -- Moreover, CXD8002 appears to pass on Windows (although we do not
- -- guarantee full Annex D compliance on Windows in any case).
-
- if Do_Yield then
- SwitchToThread;
- end if;
- end Yield;
-
- ------------------
- -- Set_Priority --
- ------------------
-
- procedure Set_Priority
- (T : Task_Id;
- Prio : System.Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- Res : BOOL;
- pragma Unreferenced (Loss_Of_Inheritance);
-
- begin
- Res :=
- SetThreadPriority
- (T.Common.LL.Thread,
- Interfaces.C.int (Underlying_Priorities (Prio)));
- pragma Assert (Res = Win32.TRUE);
-
- -- Note: Annex D (RM D.2.3(5/2)) requires the task to be placed at the
- -- head of its priority queue when decreasing its priority as a result
- -- of a loss of inherited priority. This is not the case, but we
- -- consider it an acceptable variation (RM 1.1.3(6)), given this is
- -- the built-in behavior offered by the Windows operating system.
-
- -- In older versions we attempted to better approximate the Annex D
- -- required behavior, but this simulation was not entirely accurate,
- -- and it seems better to live with the standard Windows semantics.
-
- T.Common.Current_Priority := Prio;
- end Set_Priority;
-
- ------------------
- -- Get_Priority --
- ------------------
-
- function Get_Priority (T : Task_Id) return System.Any_Priority is
- begin
- return T.Common.Current_Priority;
- end Get_Priority;
-
- ----------------
- -- Enter_Task --
- ----------------
-
- -- There were two paths were we needed to call Enter_Task :
- -- 1) from System.Task_Primitives.Operations.Initialize
- -- 2) from System.Tasking.Stages.Task_Wrapper
-
- -- The pseudo handle (LL.Thread) need not be closed when it is no
- -- longer needed. Calling the CloseHandle function with this handle
- -- has no effect.
-
- procedure Enter_Task (Self_ID : Task_Id) is
- procedure Get_Stack_Bounds (Base : Address; Limit : Address);
- pragma Import (C, Get_Stack_Bounds, "__gnat_get_stack_bounds");
- -- Get stack boundaries
- begin
- Specific.Set (Self_ID);
-
- -- Properly initializes the FPU for x86 systems
-
- System.Float_Control.Reset;
-
- if Self_ID.Common.Task_Info /= null
- and then
- Self_ID.Common.Task_Info.CPU >= CPU_Number (Number_Of_Processors)
- then
- raise Invalid_CPU_Number;
- end if;
-
- Self_ID.Common.LL.Thread := GetCurrentThread;
- Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
-
- Get_Stack_Bounds
- (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base'Address,
- Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address);
- end Enter_Task;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
-
- -----------------------------
- -- Register_Foreign_Thread --
- -----------------------------
-
- function Register_Foreign_Thread return Task_Id is
- begin
- if Is_Valid_Task then
- return Self;
- else
- return Register_Foreign_Thread (GetCurrentThread);
- end if;
- end Register_Foreign_Thread;
-
- --------------------
- -- Initialize_TCB --
- --------------------
-
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- begin
- -- Initialize thread ID to 0, this is needed to detect threads that
- -- are not yet activated.
-
- Self_ID.Common.LL.Thread := Null_Thread_Id;
-
- Initialize_Cond (Self_ID.Common.LL.CV'Access);
-
- if not Single_Lock then
- Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
- end if;
-
- Succeeded := True;
- end Initialize_TCB;
-
- -----------------
- -- Create_Task --
- -----------------
-
- procedure Create_Task
- (T : Task_Id;
- Wrapper : System.Address;
- Stack_Size : System.Parameters.Size_Type;
- Priority : System.Any_Priority;
- Succeeded : out Boolean)
- is
- Initial_Stack_Size : constant := 1024;
- -- We set the initial stack size to 1024. On Windows version prior to XP
- -- there is no way to fix a task stack size. Only the initial stack size
- -- can be set, the operating system will raise the task stack size if
- -- needed.
-
- function Is_Windows_XP return Integer;
- pragma Import (C, Is_Windows_XP, "__gnat_is_windows_xp");
- -- Returns 1 if running on Windows XP
-
- hTask : HANDLE;
- TaskId : aliased DWORD;
- pTaskParameter : Win32.PVOID;
- Result : DWORD;
- Entry_Point : PTHREAD_START_ROUTINE;
-
- use type System.Multiprocessors.CPU_Range;
-
- begin
- -- Check whether both Dispatching_Domain and CPU are specified for the
- -- task, and the CPU value is not contained within the range of
- -- processors for the domain.
-
- if T.Common.Domain /= null
- and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
- and then
- (T.Common.Base_CPU not in T.Common.Domain'Range
- or else not T.Common.Domain (T.Common.Base_CPU))
- then
- Succeeded := False;
- return;
- end if;
-
- pTaskParameter := To_Address (T);
-
- Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
-
- if Is_Windows_XP = 1 then
- hTask := CreateThread
- (null,
- DWORD (Stack_Size),
- Entry_Point,
- pTaskParameter,
- DWORD (Create_Suspended)
- or DWORD (Stack_Size_Param_Is_A_Reservation),
- TaskId'Unchecked_Access);
- else
- hTask := CreateThread
- (null,
- Initial_Stack_Size,
- Entry_Point,
- pTaskParameter,
- DWORD (Create_Suspended),
- TaskId'Unchecked_Access);
- end if;
-
- -- Step 1: Create the thread in blocked mode
-
- if hTask = 0 then
- Succeeded := False;
- return;
- end if;
-
- -- Step 2: set its TCB
-
- T.Common.LL.Thread := hTask;
-
- -- Note: it would be useful to initialize Thread_Id right away to avoid
- -- a race condition in gdb where Thread_ID may not have the right value
- -- yet, but GetThreadId is a Vista specific API, not available under XP:
- -- T.Common.LL.Thread_Id := GetThreadId (hTask); so instead we set the
- -- field to 0 to avoid having a random value. Thread_Id is initialized
- -- in Enter_Task anyway.
-
- T.Common.LL.Thread_Id := 0;
-
- -- Step 3: set its priority (child has inherited priority from parent)
-
- Set_Priority (T, Priority);
-
- if Time_Slice_Val = 0
- or else Dispatching_Policy = 'F'
- or else Get_Policy (Priority) = 'F'
- then
- -- Here we need Annex D semantics so we disable the NT priority
- -- boost. A priority boost is temporarily given by the system to
- -- a thread when it is taken out of a wait state.
-
- SetThreadPriorityBoost (hTask, DisablePriorityBoost => Win32.TRUE);
- end if;
-
- -- Step 4: Handle pragma CPU and Task_Info
-
- Set_Task_Affinity (T);
-
- -- Step 5: Now, start it for good
-
- Result := ResumeThread (hTask);
- pragma Assert (Result = 1);
-
- Succeeded := Result = 1;
- end Create_Task;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- Succeeded : BOOL;
- pragma Unreferenced (Succeeded);
-
- begin
- if not Single_Lock then
- Finalize_Lock (T.Common.LL.L'Access);
- end if;
-
- Finalize_Cond (T.Common.LL.CV'Access);
-
- if T.Known_Tasks_Index /= -1 then
- Known_Tasks (T.Known_Tasks_Index) := null;
- end if;
-
- if T.Common.LL.Thread /= 0 then
-
- -- This task has been activated. Close the thread handle. This
- -- is needed to release system resources.
-
- Succeeded := CloseHandle (T.Common.LL.Thread);
- -- Note that we do not check for the returned value, this is
- -- because the above call will fail for a foreign thread. But
- -- we still need to call it to properly close Ada tasks created
- -- with CreateThread() in Create_Task above.
- end if;
-
- ATCB_Allocation.Free_ATCB (T);
- end Finalize_TCB;
-
- ---------------
- -- Exit_Task --
- ---------------
-
- procedure Exit_Task is
- begin
- Specific.Set (null);
- end Exit_Task;
-
- ----------------
- -- Abort_Task --
- ----------------
-
- procedure Abort_Task (T : Task_Id) is
- pragma Unreferenced (T);
- begin
- null;
- end Abort_Task;
-
- ----------------------
- -- Environment_Task --
- ----------------------
-
- function Environment_Task return Task_Id is
- begin
- return Environment_Task_Id;
- end Environment_Task;
-
- --------------
- -- Lock_RTS --
- --------------
-
- procedure Lock_RTS is
- begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
- end Lock_RTS;
-
- ----------------
- -- Unlock_RTS --
- ----------------
-
- procedure Unlock_RTS is
- begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
- end Unlock_RTS;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- Discard : BOOL;
-
- begin
- Environment_Task_Id := Environment_Task;
- OS_Primitives.Initialize;
- Interrupt_Management.Initialize;
-
- if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
- -- Here we need Annex D semantics, switch the current process to the
- -- Realtime_Priority_Class.
-
- Discard := OS_Interface.SetPriorityClass
- (GetCurrentProcess, Realtime_Priority_Class);
- end if;
-
- TlsIndex := TlsAlloc;
-
- -- Initialize the lock used to synchronize chain of all ATCBs
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- Environment_Task.Common.LL.Thread := GetCurrentThread;
-
- -- Make environment task known here because it doesn't go through
- -- Activate_Tasks, which does it for all other tasks.
-
- Known_Tasks (Known_Tasks'First) := Environment_Task;
- Environment_Task.Known_Tasks_Index := Known_Tasks'First;
-
- Enter_Task (Environment_Task);
-
- -- pragma CPU and dispatching domains for the environment task
-
- Set_Task_Affinity (Environment_Task);
- end Initialize;
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- function Monotonic_Clock return Duration is
- function Internal_Clock return Duration;
- pragma Import (Ada, Internal_Clock, "__gnat_monotonic_clock");
- begin
- return Internal_Clock;
- end Monotonic_Clock;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- Ticks_Per_Second : aliased LARGE_INTEGER;
- begin
- QueryPerformanceFrequency (Ticks_Per_Second'Access);
- return Duration (1.0 / Ticks_Per_Second);
- end RT_Resolution;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (S : in out Suspension_Object) is
- begin
- -- Initialize internal state. It is always initialized to False (ARM
- -- D.10 par. 6).
-
- S.State := False;
- S.Waiting := False;
-
- -- Initialize internal mutex
-
- InitializeCriticalSection (S.L'Access);
-
- -- Initialize internal condition variable
-
- S.CV := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
- pragma Assert (S.CV /= 0);
- end Initialize;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (S : in out Suspension_Object) is
- Result : BOOL;
-
- begin
- -- Destroy internal mutex
-
- DeleteCriticalSection (S.L'Access);
-
- -- Destroy internal condition variable
-
- Result := CloseHandle (S.CV);
- pragma Assert (Result = Win32.TRUE);
- end Finalize;
-
- -------------------
- -- Current_State --
- -------------------
-
- function Current_State (S : Suspension_Object) return Boolean is
- begin
- -- We do not want to use lock on this read operation. State is marked
- -- as Atomic so that we ensure that the value retrieved is correct.
-
- return S.State;
- end Current_State;
-
- ---------------
- -- Set_False --
- ---------------
-
- procedure Set_False (S : in out Suspension_Object) is
- begin
- SSL.Abort_Defer.all;
-
- EnterCriticalSection (S.L'Access);
-
- S.State := False;
-
- LeaveCriticalSection (S.L'Access);
-
- SSL.Abort_Undefer.all;
- end Set_False;
-
- --------------
- -- Set_True --
- --------------
-
- procedure Set_True (S : in out Suspension_Object) is
- Result : BOOL;
-
- begin
- SSL.Abort_Defer.all;
-
- EnterCriticalSection (S.L'Access);
-
- -- If there is already a task waiting on this suspension object then
- -- we resume it, leaving the state of the suspension object to False,
- -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
- -- the state to True.
-
- if S.Waiting then
- S.Waiting := False;
- S.State := False;
-
- Result := SetEvent (S.CV);
- pragma Assert (Result = Win32.TRUE);
-
- else
- S.State := True;
- end if;
-
- LeaveCriticalSection (S.L'Access);
-
- SSL.Abort_Undefer.all;
- end Set_True;
-
- ------------------------
- -- Suspend_Until_True --
- ------------------------
-
- procedure Suspend_Until_True (S : in out Suspension_Object) is
- Result : DWORD;
- Result_Bool : BOOL;
-
- begin
- SSL.Abort_Defer.all;
-
- EnterCriticalSection (S.L'Access);
-
- if S.Waiting then
-
- -- Program_Error must be raised upon calling Suspend_Until_True
- -- if another task is already waiting on that suspension object
- -- (ARM D.10 par. 10).
-
- LeaveCriticalSection (S.L'Access);
-
- SSL.Abort_Undefer.all;
-
- raise Program_Error;
-
- else
- -- Suspend the task if the state is False. Otherwise, the task
- -- continues its execution, and the state of the suspension object
- -- is set to False (ARM D.10 par. 9).
-
- if S.State then
- S.State := False;
-
- LeaveCriticalSection (S.L'Access);
-
- SSL.Abort_Undefer.all;
-
- else
- S.Waiting := True;
-
- -- Must reset CV BEFORE L is unlocked
-
- Result_Bool := ResetEvent (S.CV);
- pragma Assert (Result_Bool = Win32.TRUE);
-
- LeaveCriticalSection (S.L'Access);
-
- SSL.Abort_Undefer.all;
-
- Result := WaitForSingleObject (S.CV, Wait_Infinite);
- pragma Assert (Result = 0);
- end if;
- end if;
- end Suspend_Until_True;
-
- ----------------
- -- Check_Exit --
- ----------------
-
- -- Dummy versions, currently this only works for solaris (native)
-
- function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
- pragma Unreferenced (Self_ID);
- begin
- return True;
- end Check_Exit;
-
- --------------------
- -- Check_No_Locks --
- --------------------
-
- function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
- pragma Unreferenced (Self_ID);
- begin
- return True;
- end Check_No_Locks;
-
- ------------------
- -- Suspend_Task --
- ------------------
-
- function Suspend_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- begin
- if T.Common.LL.Thread /= Thread_Self then
- return SuspendThread (T.Common.LL.Thread) = NO_ERROR;
- else
- return True;
- end if;
- end Suspend_Task;
-
- -----------------
- -- Resume_Task --
- -----------------
-
- function Resume_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- begin
- if T.Common.LL.Thread /= Thread_Self then
- return ResumeThread (T.Common.LL.Thread) = NO_ERROR;
- else
- return True;
- end if;
- end Resume_Task;
-
- --------------------
- -- Stop_All_Tasks --
- --------------------
-
- procedure Stop_All_Tasks is
- begin
- null;
- end Stop_All_Tasks;
-
- ---------------
- -- Stop_Task --
- ---------------
-
- function Stop_Task (T : ST.Task_Id) return Boolean is
- pragma Unreferenced (T);
- begin
- return False;
- end Stop_Task;
-
- -------------------
- -- Continue_Task --
- -------------------
-
- function Continue_Task (T : ST.Task_Id) return Boolean is
- pragma Unreferenced (T);
- begin
- return False;
- end Continue_Task;
-
- -----------------------
- -- Set_Task_Affinity --
- -----------------------
-
- procedure Set_Task_Affinity (T : ST.Task_Id) is
- Result : DWORD;
-
- use type System.Multiprocessors.CPU_Range;
-
- begin
- -- Do nothing if the underlying thread has not yet been created. If the
- -- thread has not yet been created then the proper affinity will be set
- -- during its creation.
-
- if T.Common.LL.Thread = Null_Thread_Id then
- null;
-
- -- pragma CPU
-
- elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
-
- -- The CPU numbering in pragma CPU starts at 1 while the subprogram
- -- to set the affinity starts at 0, therefore we must substract 1.
-
- Result :=
- SetThreadIdealProcessor
- (T.Common.LL.Thread, ProcessorId (T.Common.Base_CPU) - 1);
- pragma Assert (Result = 1);
-
- -- Task_Info
-
- elsif T.Common.Task_Info /= null then
- if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then
- Result :=
- SetThreadIdealProcessor
- (T.Common.LL.Thread, T.Common.Task_Info.CPU);
- pragma Assert (Result = 1);
- end if;
-
- -- Dispatching domains
-
- elsif T.Common.Domain /= null
- and then (T.Common.Domain /= ST.System_Domain
- or else
- T.Common.Domain.all /=
- (Multiprocessors.CPU'First ..
- Multiprocessors.Number_Of_CPUs => True))
- then
- declare
- CPU_Set : DWORD := 0;
-
- begin
- for Proc in T.Common.Domain'Range loop
- if T.Common.Domain (Proc) then
-
- -- The thread affinity mask is a bit vector in which each
- -- bit represents a logical processor.
-
- CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1);
- end if;
- end loop;
-
- Result := SetThreadAffinityMask (T.Common.LL.Thread, CPU_Set);
- pragma Assert (Result = 1);
- end;
- end if;
- end Set_Task_Affinity;
-
-end System.Task_Primitives.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a POSIX-like version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
--- Note: this file can only be used for POSIX compliant systems that implement
--- SCHED_FIFO and Ceiling Locking correctly.
-
--- For configurations where SCHED_FIFO and priority ceiling are not a
--- requirement, this file can also be used (e.g AiX threads)
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-with System.Tasking.Debug;
-with System.Interrupt_Management;
-with System.OS_Constants;
-with System.OS_Primitives;
-with System.Task_Info;
-
-with System.Soft_Links;
--- We use System.Soft_Links instead of System.Tasking.Initialization
--- because the later is a higher level package that we shouldn't depend on.
--- For example when using the restricted run time, it is replaced by
--- System.Tasking.Restricted.Stages.
-
-package body System.Task_Primitives.Operations is
-
- package OSC renames System.OS_Constants;
- package SSL renames System.Soft_Links;
-
- use System.Tasking.Debug;
- use System.Tasking;
- use Interfaces.C;
- use System.OS_Interface;
- use System.Parameters;
- use System.OS_Primitives;
-
- ----------------
- -- Local Data --
- ----------------
-
- -- The followings are logically constants, but need to be initialized
- -- at run time.
-
- Single_RTS_Lock : aliased RTS_Lock;
- -- This is a lock to allow only one thread of control in the RTS at
- -- a time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-
- Environment_Task_Id : Task_Id;
- -- A variable to hold Task_Id for the environment task
-
- Locking_Policy : Character;
- pragma Import (C, Locking_Policy, "__gl_locking_policy");
- -- Value of the pragma Locking_Policy:
- -- 'C' for Ceiling_Locking
- -- 'I' for Inherit_Locking
- -- ' ' for none.
-
- Unblocked_Signal_Mask : aliased sigset_t;
- -- The set of signals that should unblocked in all tasks
-
- -- The followings are internal configuration constants needed
-
- Next_Serial_Number : Task_Serial_Number := 100;
- -- We start at 100, to reserve some special values for
- -- using in error checking.
-
- Time_Slice_Val : Integer;
- pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
-
- Dispatching_Policy : Character;
- pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
-
- Foreign_Task_Elaborated : aliased Boolean := True;
- -- Used to identified fake tasks (i.e., non-Ada Threads)
-
- Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
- -- Whether to use an alternate signal stack for stack overflows
-
- Abort_Handler_Installed : Boolean := False;
- -- True if a handler for the abort signal is installed
-
- --------------------
- -- Local Packages --
- --------------------
-
- package Specific is
-
- procedure Initialize (Environment_Task : Task_Id);
- pragma Inline (Initialize);
- -- Initialize various data needed by this package
-
- function Is_Valid_Task return Boolean;
- pragma Inline (Is_Valid_Task);
- -- Does executing thread have a TCB?
-
- procedure Set (Self_Id : Task_Id);
- pragma Inline (Set);
- -- Set the self id for the current task
-
- function Self return Task_Id;
- pragma Inline (Self);
- -- Return a pointer to the Ada Task Control Block of the calling task
-
- end Specific;
-
- package body Specific is separate;
- -- The body of this package is target specific
-
- ----------------------------------
- -- ATCB allocation/deallocation --
- ----------------------------------
-
- package body ATCB_Allocation is separate;
- -- The body of this package is shared across several targets
-
- ---------------------------------
- -- Support for foreign threads --
- ---------------------------------
-
- function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread
-
- function Register_Foreign_Thread
- (Thread : Thread_Id) return Task_Id is separate;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Abort_Handler (Sig : Signal);
- -- Signal handler used to implement asynchronous abort.
- -- See also comment before body, below.
-
- function To_Address is
- new Ada.Unchecked_Conversion (Task_Id, System.Address);
-
- function GNAT_pthread_condattr_setup
- (attr : access pthread_condattr_t) return int;
- pragma Import (C,
- GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
-
- procedure Compute_Deadline
- (Time : Duration;
- Mode : ST.Delay_Modes;
- Check_Time : out Duration;
- Abs_Time : out Duration;
- Rel_Time : out Duration);
- -- Helper for Timed_Sleep and Timed_Delay: given a deadline specified by
- -- Time and Mode, compute the current clock reading (Check_Time), and the
- -- target absolute and relative clock readings (Abs_Time, Rel_Time). The
- -- epoch for Time depends on Mode; the epoch for Check_Time and Abs_Time
- -- is always that of CLOCK_RT_Ada.
-
- -------------------
- -- Abort_Handler --
- -------------------
-
- -- Target-dependent binding of inter-thread Abort signal to the raising of
- -- the Abort_Signal exception.
-
- -- The technical issues and alternatives here are essentially the
- -- same as for raising exceptions in response to other signals
- -- (e.g. Storage_Error). See code and comments in the package body
- -- System.Interrupt_Management.
-
- -- Some implementations may not allow an exception to be propagated out of
- -- a handler, and others might leave the signal or interrupt that invoked
- -- this handler masked after the exceptional return to the application
- -- code.
-
- -- GNAT exceptions are originally implemented using setjmp()/longjmp(). On
- -- most UNIX systems, this will allow transfer out of a signal handler,
- -- which is usually the only mechanism available for implementing
- -- asynchronous handlers of this kind. However, some systems do not
- -- restore the signal mask on longjmp(), leaving the abort signal masked.
-
- procedure Abort_Handler (Sig : Signal) is
- pragma Unreferenced (Sig);
-
- T : constant Task_Id := Self;
- Old_Set : aliased sigset_t;
-
- Result : Interfaces.C.int;
- pragma Warnings (Off, Result);
-
- begin
- -- It's not safe to raise an exception when using GCC ZCX mechanism.
- -- Note that we still need to install a signal handler, since in some
- -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
- -- need to send the Abort signal to a task.
-
- if ZCX_By_Default then
- return;
- end if;
-
- if T.Deferral_Level = 0
- and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
- not T.Aborting
- then
- T.Aborting := True;
-
- -- Make sure signals used for RTS internal purpose are unmasked
-
- Result := pthread_sigmask (SIG_UNBLOCK,
- Unblocked_Signal_Mask'Access, Old_Set'Access);
- pragma Assert (Result = 0);
-
- raise Standard'Abort_Signal;
- end if;
- end Abort_Handler;
-
- ----------------------
- -- Compute_Deadline --
- ----------------------
-
- procedure Compute_Deadline
- (Time : Duration;
- Mode : ST.Delay_Modes;
- Check_Time : out Duration;
- Abs_Time : out Duration;
- Rel_Time : out Duration)
- is
- begin
- Check_Time := Monotonic_Clock;
-
- -- Relative deadline
-
- if Mode = Relative then
- Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
-
- if Relative_Timed_Wait then
- Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
- end if;
-
- pragma Warnings (Off);
- -- Comparison "OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME" is compile
- -- time known.
-
- -- Absolute deadline specified using the tasking clock (CLOCK_RT_Ada)
-
- elsif Mode = Absolute_RT
- or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME
- then
- pragma Warnings (On);
- Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
-
- if Relative_Timed_Wait then
- Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
- end if;
-
- -- Absolute deadline specified using the calendar clock, in the
- -- case where it is not the same as the tasking clock: compensate for
- -- difference between clock epochs (Base_Time - Base_Cal_Time).
-
- else
- declare
- Cal_Check_Time : constant Duration := OS_Primitives.Clock;
- RT_Time : constant Duration :=
- Time + Check_Time - Cal_Check_Time;
-
- begin
- Abs_Time :=
- Duration'Min (Check_Time + Max_Sensible_Delay, RT_Time);
-
- if Relative_Timed_Wait then
- Rel_Time :=
- Duration'Min (Max_Sensible_Delay, RT_Time - Check_Time);
- end if;
- end;
- end if;
- end Compute_Deadline;
-
- -----------------
- -- Stack_Guard --
- -----------------
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread);
- Page_Size : Address;
- Res : Interfaces.C.int;
-
- begin
- if Stack_Base_Available then
-
- -- Compute the guard page address
-
- Page_Size := Address (Get_Page_Size);
- Res :=
- mprotect
- (Stack_Base - (Stack_Base mod Page_Size) + Page_Size,
- size_t (Page_Size),
- prot => (if On then PROT_ON else PROT_OFF));
- pragma Assert (Res = 0);
- end if;
- end Stack_Guard;
-
- --------------------
- -- Get_Thread_Id --
- --------------------
-
- function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
- begin
- return T.Common.LL.Thread;
- end Get_Thread_Id;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_Id renames Specific.Self;
-
- ---------------------
- -- Initialize_Lock --
- ---------------------
-
- -- Note: mutexes and cond_variables needed per-task basis are initialized
- -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
- -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
- -- status change of RTS. Therefore raising Storage_Error in the following
- -- routines should be able to be handled safely.
-
- procedure Initialize_Lock
- (Prio : System.Any_Priority;
- L : not null access Lock)
- is
- Attributes : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
-
- begin
- Result := pthread_mutexattr_init (Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- if Locking_Policy = 'C' then
- Result := pthread_mutexattr_setprotocol
- (Attributes'Access, PTHREAD_PRIO_PROTECT);
- pragma Assert (Result = 0);
-
- Result := pthread_mutexattr_setprioceiling
- (Attributes'Access, Interfaces.C.int (Prio));
- pragma Assert (Result = 0);
-
- elsif Locking_Policy = 'I' then
- Result := pthread_mutexattr_setprotocol
- (Attributes'Access, PTHREAD_PRIO_INHERIT);
- pragma Assert (Result = 0);
- end if;
-
- Result := pthread_mutex_init (L.WO'Access, Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- Result := pthread_mutexattr_destroy (Attributes'Access);
- raise Storage_Error;
- end if;
-
- Result := pthread_mutexattr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
- end Initialize_Lock;
-
- procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level)
- is
- pragma Unreferenced (Level);
-
- Attributes : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
-
- begin
- Result := pthread_mutexattr_init (Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- if Locking_Policy = 'C' then
- Result := pthread_mutexattr_setprotocol
- (Attributes'Access, PTHREAD_PRIO_PROTECT);
- pragma Assert (Result = 0);
-
- Result := pthread_mutexattr_setprioceiling
- (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
- pragma Assert (Result = 0);
-
- elsif Locking_Policy = 'I' then
- Result := pthread_mutexattr_setprotocol
- (Attributes'Access, PTHREAD_PRIO_INHERIT);
- pragma Assert (Result = 0);
- end if;
-
- Result := pthread_mutex_init (L, Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- Result := pthread_mutexattr_destroy (Attributes'Access);
- raise Storage_Error;
- end if;
-
- Result := pthread_mutexattr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
- end Initialize_Lock;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : not null access Lock) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_mutex_destroy (L.WO'Access);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : not null access RTS_Lock) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_mutex_destroy (L);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- ----------------
- -- Write_Lock --
- ----------------
-
- procedure Write_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean)
- is
- Result : Interfaces.C.int;
-
- begin
- Result := pthread_mutex_lock (L.WO'Access);
-
- -- The cause of EINVAL is a priority ceiling violation
-
- Ceiling_Violation := Result = EINVAL;
- pragma Assert (Result = 0 or else Ceiling_Violation);
- end Write_Lock;
-
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_lock (L);
- pragma Assert (Result = 0);
- end if;
- end Write_Lock;
-
- procedure Write_Lock (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock then
- Result := pthread_mutex_lock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
- end Write_Lock;
-
- ---------------
- -- Read_Lock --
- ---------------
-
- procedure Read_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean) is
- begin
- Write_Lock (L, Ceiling_Violation);
- end Read_Lock;
-
- ------------
- -- Unlock --
- ------------
-
- procedure Unlock (L : not null access Lock) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_mutex_unlock (L.WO'Access);
- pragma Assert (Result = 0);
- end Unlock;
-
- procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
- is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock or else Global_Lock then
- Result := pthread_mutex_unlock (L);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- procedure Unlock (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock then
- Result := pthread_mutex_unlock (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- -----------------
- -- Set_Ceiling --
- -----------------
-
- -- Dynamic priority ceilings are not supported by the underlying system
-
- procedure Set_Ceiling
- (L : not null access Lock;
- Prio : System.Any_Priority)
- is
- pragma Unreferenced (L, Prio);
- begin
- null;
- end Set_Ceiling;
-
- -----------
- -- Sleep --
- -----------
-
- procedure Sleep
- (Self_ID : Task_Id;
- Reason : System.Tasking.Task_States)
- is
- pragma Unreferenced (Reason);
-
- Result : Interfaces.C.int;
-
- begin
- Result :=
- pthread_cond_wait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access));
-
- -- EINTR is not considered a failure
-
- pragma Assert (Result = 0 or else Result = EINTR);
- end Sleep;
-
- -----------------
- -- Timed_Sleep --
- -----------------
-
- -- This is for use within the run-time system, so abort is
- -- assumed to be already deferred, and the caller should be
- -- holding its own ATCB lock.
-
- procedure Timed_Sleep
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes;
- Reason : Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- pragma Unreferenced (Reason);
-
- Base_Time : Duration;
- Check_Time : Duration;
- Abs_Time : Duration;
- Rel_Time : Duration;
-
- Request : aliased timespec;
- Result : Interfaces.C.int;
-
- begin
- Timedout := True;
- Yielded := False;
-
- Compute_Deadline
- (Time => Time,
- Mode => Mode,
- Check_Time => Check_Time,
- Abs_Time => Abs_Time,
- Rel_Time => Rel_Time);
- Base_Time := Check_Time;
-
- if Abs_Time > Check_Time then
- Request :=
- To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time);
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- Result :=
- pthread_cond_timedwait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
- abstime => Request'Access);
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- if Result = 0 or Result = EINTR then
-
- -- Somebody may have called Wakeup for us
-
- Timedout := False;
- exit;
- end if;
-
- pragma Assert (Result = ETIMEDOUT);
- end loop;
- end if;
- end Timed_Sleep;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- -- This is for use in implementing delay statements, so we assume the
- -- caller is abort-deferred but is holding no locks.
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Base_Time : Duration;
- Check_Time : Duration;
- Abs_Time : Duration;
- Rel_Time : Duration;
- Request : aliased timespec;
-
- Result : Interfaces.C.int;
- pragma Warnings (Off, Result);
-
- begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
- Write_Lock (Self_ID);
-
- Compute_Deadline
- (Time => Time,
- Mode => Mode,
- Check_Time => Check_Time,
- Abs_Time => Abs_Time,
- Rel_Time => Rel_Time);
- Base_Time := Check_Time;
-
- if Abs_Time > Check_Time then
- Request :=
- To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time);
- Self_ID.Common.State := Delay_Sleep;
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- Result :=
- pthread_cond_timedwait
- (cond => Self_ID.Common.LL.CV'Access,
- mutex => (if Single_Lock
- then Single_RTS_Lock'Access
- else Self_ID.Common.LL.L'Access),
- abstime => Request'Access);
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- pragma Assert (Result = 0
- or else Result = ETIMEDOUT
- or else Result = EINTR);
- end loop;
-
- Self_ID.Common.State := Runnable;
- end if;
-
- Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
- Result := sched_yield;
- end Timed_Delay;
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- function Monotonic_Clock return Duration is
- TS : aliased timespec;
- Result : Interfaces.C.int;
- begin
- Result := clock_gettime
- (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
- pragma Assert (Result = 0);
- return To_Duration (TS);
- end Monotonic_Clock;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- TS : aliased timespec;
- Result : Interfaces.C.int;
- begin
- Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
- pragma Assert (Result = 0);
-
- return To_Duration (TS);
- end RT_Resolution;
-
- ------------
- -- Wakeup --
- ------------
-
- procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
- pragma Unreferenced (Reason);
- Result : Interfaces.C.int;
- begin
- Result := pthread_cond_signal (T.Common.LL.CV'Access);
- pragma Assert (Result = 0);
- end Wakeup;
-
- -----------
- -- Yield --
- -----------
-
- procedure Yield (Do_Yield : Boolean := True) is
- Result : Interfaces.C.int;
- pragma Unreferenced (Result);
- begin
- if Do_Yield then
- Result := sched_yield;
- end if;
- end Yield;
-
- ------------------
- -- Set_Priority --
- ------------------
-
- procedure Set_Priority
- (T : Task_Id;
- Prio : System.Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- pragma Unreferenced (Loss_Of_Inheritance);
-
- Result : Interfaces.C.int;
- Param : aliased struct_sched_param;
-
- function Get_Policy (Prio : System.Any_Priority) return Character;
- pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
- -- Get priority specific dispatching policy
-
- Priority_Specific_Policy : constant Character := Get_Policy (Prio);
- -- Upper case first character of the policy name corresponding to the
- -- task as set by a Priority_Specific_Dispatching pragma.
-
- begin
- T.Common.Current_Priority := Prio;
- Param.sched_priority := To_Target_Priority (Prio);
-
- if Time_Slice_Supported
- and then (Dispatching_Policy = 'R'
- or else Priority_Specific_Policy = 'R'
- or else Time_Slice_Val > 0)
- then
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_RR, Param'Access);
-
- elsif Dispatching_Policy = 'F'
- or else Priority_Specific_Policy = 'F'
- or else Time_Slice_Val = 0
- then
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
-
- else
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
- end if;
-
- pragma Assert (Result = 0);
- end Set_Priority;
-
- ------------------
- -- Get_Priority --
- ------------------
-
- function Get_Priority (T : Task_Id) return System.Any_Priority is
- begin
- return T.Common.Current_Priority;
- end Get_Priority;
-
- ----------------
- -- Enter_Task --
- ----------------
-
- procedure Enter_Task (Self_ID : Task_Id) is
- begin
- Self_ID.Common.LL.Thread := pthread_self;
- Self_ID.Common.LL.LWP := lwp_self;
-
- Specific.Set (Self_ID);
-
- if Use_Alternate_Stack then
- declare
- Stack : aliased stack_t;
- Result : Interfaces.C.int;
- begin
- Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack;
- Stack.ss_size := Alternate_Stack_Size;
- Stack.ss_flags := 0;
- Result := sigaltstack (Stack'Access, null);
- pragma Assert (Result = 0);
- end;
- end if;
- end Enter_Task;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
-
- -----------------------------
- -- Register_Foreign_Thread --
- -----------------------------
-
- function Register_Foreign_Thread return Task_Id is
- begin
- if Is_Valid_Task then
- return Self;
- else
- return Register_Foreign_Thread (pthread_self);
- end if;
- end Register_Foreign_Thread;
-
- --------------------
- -- Initialize_TCB --
- --------------------
-
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- Mutex_Attr : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
- Cond_Attr : aliased pthread_condattr_t;
-
- begin
- -- Give the task a unique serial number
-
- Self_ID.Serial_Number := Next_Serial_Number;
- Next_Serial_Number := Next_Serial_Number + 1;
- pragma Assert (Next_Serial_Number /= 0);
-
- if not Single_Lock then
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = 0 then
- if Locking_Policy = 'C' then
- Result :=
- pthread_mutexattr_setprotocol
- (Mutex_Attr'Access,
- PTHREAD_PRIO_PROTECT);
- pragma Assert (Result = 0);
-
- Result :=
- pthread_mutexattr_setprioceiling
- (Mutex_Attr'Access,
- Interfaces.C.int (System.Any_Priority'Last));
- pragma Assert (Result = 0);
-
- elsif Locking_Policy = 'I' then
- Result :=
- pthread_mutexattr_setprotocol
- (Mutex_Attr'Access,
- PTHREAD_PRIO_INHERIT);
- pragma Assert (Result = 0);
- end if;
-
- Result :=
- pthread_mutex_init
- (Self_ID.Common.LL.L'Access,
- Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
- end if;
-
- if Result /= 0 then
- Succeeded := False;
- return;
- end if;
-
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result = 0);
- end if;
-
- Result := pthread_condattr_init (Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = 0 then
- Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
- pragma Assert (Result = 0);
-
- Result :=
- pthread_cond_init
- (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
- end if;
-
- if Result = 0 then
- Succeeded := True;
- else
- if not Single_Lock then
- Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
-
- Succeeded := False;
- end if;
-
- Result := pthread_condattr_destroy (Cond_Attr'Access);
- pragma Assert (Result = 0);
- end Initialize_TCB;
-
- -----------------
- -- Create_Task --
- -----------------
-
- procedure Create_Task
- (T : Task_Id;
- Wrapper : System.Address;
- Stack_Size : System.Parameters.Size_Type;
- Priority : System.Any_Priority;
- Succeeded : out Boolean)
- is
- Attributes : aliased pthread_attr_t;
- Adjusted_Stack_Size : Interfaces.C.size_t;
- Page_Size : constant Interfaces.C.size_t :=
- Interfaces.C.size_t (Get_Page_Size);
- Result : Interfaces.C.int;
-
- function Thread_Body_Access is new
- Ada.Unchecked_Conversion (System.Address, Thread_Body);
-
- use System.Task_Info;
-
- begin
- Adjusted_Stack_Size :=
- Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
-
- if Stack_Base_Available then
-
- -- If Stack Checking is supported then allocate 2 additional pages:
-
- -- In the worst case, stack is allocated at something like
- -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages
- -- to be sure the effective stack size is greater than what
- -- has been asked.
-
- Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Page_Size;
- end if;
-
- -- Round stack size as this is required by some OSes (Darwin)
-
- Adjusted_Stack_Size := Adjusted_Stack_Size + Page_Size - 1;
- Adjusted_Stack_Size :=
- Adjusted_Stack_Size - Adjusted_Stack_Size mod Page_Size;
-
- Result := pthread_attr_init (Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result /= 0 then
- Succeeded := False;
- return;
- end if;
-
- Result :=
- pthread_attr_setdetachstate
- (Attributes'Access, PTHREAD_CREATE_DETACHED);
- pragma Assert (Result = 0);
-
- Result :=
- pthread_attr_setstacksize
- (Attributes'Access, Adjusted_Stack_Size);
- pragma Assert (Result = 0);
-
- if T.Common.Task_Info /= Default_Scope then
- case T.Common.Task_Info is
- when System.Task_Info.Process_Scope =>
- Result :=
- pthread_attr_setscope
- (Attributes'Access, PTHREAD_SCOPE_PROCESS);
-
- when System.Task_Info.System_Scope =>
- Result :=
- pthread_attr_setscope
- (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
-
- when System.Task_Info.Default_Scope =>
- Result := 0;
- end case;
-
- pragma Assert (Result = 0);
- end if;
-
- -- Since the initial signal mask of a thread is inherited from the
- -- creator, and the Environment task has all its signals masked, we
- -- do not need to manipulate caller's signal mask at this point.
- -- All tasks in RTS will have All_Tasks_Mask initially.
-
- -- Note: the use of Unrestricted_Access in the following call is needed
- -- because otherwise we have an error of getting a access-to-volatile
- -- value which points to a non-volatile object. But in this case it is
- -- safe to do this, since we know we have no problems with aliasing and
- -- Unrestricted_Access bypasses this check.
-
- Result := pthread_create
- (T.Common.LL.Thread'Unrestricted_Access,
- Attributes'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
- pragma Assert (Result = 0 or else Result = EAGAIN);
-
- Succeeded := Result = 0;
-
- Result := pthread_attr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
-
- if Succeeded then
- Set_Priority (T, Priority);
- end if;
- end Create_Task;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- Result : Interfaces.C.int;
-
- begin
- if not Single_Lock then
- Result := pthread_mutex_destroy (T.Common.LL.L'Access);
- pragma Assert (Result = 0);
- end if;
-
- Result := pthread_cond_destroy (T.Common.LL.CV'Access);
- pragma Assert (Result = 0);
-
- if T.Known_Tasks_Index /= -1 then
- Known_Tasks (T.Known_Tasks_Index) := null;
- end if;
-
- ATCB_Allocation.Free_ATCB (T);
- end Finalize_TCB;
-
- ---------------
- -- Exit_Task --
- ---------------
-
- procedure Exit_Task is
- begin
- -- Mark this task as unknown, so that if Self is called, it won't
- -- return a dangling pointer.
-
- Specific.Set (null);
- end Exit_Task;
-
- ----------------
- -- Abort_Task --
- ----------------
-
- procedure Abort_Task (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- if Abort_Handler_Installed then
- Result :=
- pthread_kill
- (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
- pragma Assert (Result = 0);
- end if;
- end Abort_Task;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (S : in out Suspension_Object) is
- Mutex_Attr : aliased pthread_mutexattr_t;
- Cond_Attr : aliased pthread_condattr_t;
- Result : Interfaces.C.int;
-
- begin
- -- Initialize internal state (always to False (RM D.10 (6)))
-
- S.State := False;
- S.Waiting := False;
-
- -- Initialize internal mutex
-
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result = 0);
-
- raise Storage_Error;
- end if;
-
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result = 0);
-
- -- Initialize internal condition variable
-
- Result := pthread_condattr_init (Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result /= 0 then
- Result := pthread_mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- -- Storage_Error is propagated as intended if the allocation of the
- -- underlying OS entities fails.
-
- raise Storage_Error;
-
- else
- Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
- pragma Assert (Result = 0);
- end if;
-
- Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result /= 0 then
- Result := pthread_mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- Result := pthread_condattr_destroy (Cond_Attr'Access);
- pragma Assert (Result = 0);
-
- -- Storage_Error is propagated as intended if the allocation of the
- -- underlying OS entities fails.
-
- raise Storage_Error;
- end if;
-
- Result := pthread_condattr_destroy (Cond_Attr'Access);
- pragma Assert (Result = 0);
- end Initialize;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- -- Destroy internal mutex
-
- Result := pthread_mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- -- Destroy internal condition variable
-
- Result := pthread_cond_destroy (S.CV'Access);
- pragma Assert (Result = 0);
- end Finalize;
-
- -------------------
- -- Current_State --
- -------------------
-
- function Current_State (S : Suspension_Object) return Boolean is
- begin
- -- We do not want to use lock on this read operation. State is marked
- -- as Atomic so that we ensure that the value retrieved is correct.
-
- return S.State;
- end Current_State;
-
- ---------------
- -- Set_False --
- ---------------
-
- procedure Set_False (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := pthread_mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- S.State := False;
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end Set_False;
-
- --------------
- -- Set_True --
- --------------
-
- procedure Set_True (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := pthread_mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- -- If there is already a task waiting on this suspension object then
- -- we resume it, leaving the state of the suspension object to False,
- -- as it is specified in (RM D.10(9)). Otherwise, it just leaves
- -- the state to True.
-
- if S.Waiting then
- S.Waiting := False;
- S.State := False;
-
- Result := pthread_cond_signal (S.CV'Access);
- pragma Assert (Result = 0);
-
- else
- S.State := True;
- end if;
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end Set_True;
-
- ------------------------
- -- Suspend_Until_True --
- ------------------------
-
- procedure Suspend_Until_True (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := pthread_mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- if S.Waiting then
-
- -- Program_Error must be raised upon calling Suspend_Until_True
- -- if another task is already waiting on that suspension object
- -- (RM D.10(10)).
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
-
- raise Program_Error;
-
- else
- -- Suspend the task if the state is False. Otherwise, the task
- -- continues its execution, and the state of the suspension object
- -- is set to False (ARM D.10 par. 9).
-
- if S.State then
- S.State := False;
- else
- S.Waiting := True;
-
- loop
- -- Loop in case pthread_cond_wait returns earlier than expected
- -- (e.g. in case of EINTR caused by a signal).
-
- Result := pthread_cond_wait (S.CV'Access, S.L'Access);
- pragma Assert (Result = 0 or else Result = EINTR);
-
- exit when not S.Waiting;
- end loop;
- end if;
-
- Result := pthread_mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end if;
- end Suspend_Until_True;
-
- ----------------
- -- Check_Exit --
- ----------------
-
- -- Dummy version
-
- function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
- pragma Unreferenced (Self_ID);
- begin
- return True;
- end Check_Exit;
-
- --------------------
- -- Check_No_Locks --
- --------------------
-
- function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
- pragma Unreferenced (Self_ID);
- begin
- return True;
- end Check_No_Locks;
-
- ----------------------
- -- Environment_Task --
- ----------------------
-
- function Environment_Task return Task_Id is
- begin
- return Environment_Task_Id;
- end Environment_Task;
-
- --------------
- -- Lock_RTS --
- --------------
-
- procedure Lock_RTS is
- begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
- end Lock_RTS;
-
- ----------------
- -- Unlock_RTS --
- ----------------
-
- procedure Unlock_RTS is
- begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
- end Unlock_RTS;
-
- ------------------
- -- Suspend_Task --
- ------------------
-
- function Suspend_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- pragma Unreferenced (T, Thread_Self);
- begin
- return False;
- end Suspend_Task;
-
- -----------------
- -- Resume_Task --
- -----------------
-
- function Resume_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- pragma Unreferenced (T, Thread_Self);
- begin
- return False;
- end Resume_Task;
-
- --------------------
- -- Stop_All_Tasks --
- --------------------
-
- procedure Stop_All_Tasks is
- begin
- null;
- end Stop_All_Tasks;
-
- ---------------
- -- Stop_Task --
- ---------------
-
- function Stop_Task (T : ST.Task_Id) return Boolean is
- pragma Unreferenced (T);
- begin
- return False;
- end Stop_Task;
-
- -------------------
- -- Continue_Task --
- -------------------
-
- function Continue_Task (T : ST.Task_Id) return Boolean is
- pragma Unreferenced (T);
- begin
- return False;
- end Continue_Task;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Tmp_Set : aliased sigset_t;
- Result : Interfaces.C.int;
-
- function State
- (Int : System.Interrupt_Management.Interrupt_ID) return Character;
- pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in a-init.c
- -- The input argument is the interrupt number,
- -- and the result is one of the following:
-
- Default : constant Character := 's';
- -- 'n' this interrupt not set by any Interrupt_State pragma
- -- 'u' Interrupt_State pragma set state to User
- -- 'r' Interrupt_State pragma set state to Runtime
- -- 's' Interrupt_State pragma set state to System (use "default"
- -- system handler)
-
- begin
- Environment_Task_Id := Environment_Task;
-
- Interrupt_Management.Initialize;
-
- -- Prepare the set of signals that should unblocked in all tasks
-
- Result := sigemptyset (Unblocked_Signal_Mask'Access);
- pragma Assert (Result = 0);
-
- for J in Interrupt_Management.Interrupt_ID loop
- if System.Interrupt_Management.Keep_Unmasked (J) then
- Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
- pragma Assert (Result = 0);
- end if;
- end loop;
-
- -- Initialize the lock used to synchronize chain of all ATCBs
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- Specific.Initialize (Environment_Task);
-
- if Use_Alternate_Stack then
- Environment_Task.Common.Task_Alternate_Stack :=
- Alternate_Stack'Address;
- end if;
-
- -- Make environment task known here because it doesn't go through
- -- Activate_Tasks, which does it for all other tasks.
-
- Known_Tasks (Known_Tasks'First) := Environment_Task;
- Environment_Task.Known_Tasks_Index := Known_Tasks'First;
-
- Enter_Task (Environment_Task);
-
- if State
- (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
- then
- act.sa_flags := 0;
- act.sa_handler := Abort_Handler'Address;
-
- Result := sigemptyset (Tmp_Set'Access);
- pragma Assert (Result = 0);
- act.sa_mask := Tmp_Set;
-
- Result :=
- sigaction
- (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
- Abort_Handler_Installed := True;
- end if;
- end Initialize;
-
- -----------------------
- -- Set_Task_Affinity --
- -----------------------
-
- procedure Set_Task_Affinity (T : ST.Task_Id) is
- pragma Unreferenced (T);
-
- begin
- -- Setting task affinity is not supported by the underlying system
-
- null;
- end Set_Task_Affinity;
-
-end System.Task_Primitives.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a Solaris (native) version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with Interfaces.C;
-
-with System.Multiprocessors;
-with System.Tasking.Debug;
-with System.Interrupt_Management;
-with System.OS_Constants;
-with System.OS_Primitives;
-with System.Task_Info;
-
-pragma Warnings (Off);
-with System.OS_Lib;
-pragma Warnings (On);
-
-with System.Soft_Links;
--- We use System.Soft_Links instead of System.Tasking.Initialization
--- because the later is a higher level package that we shouldn't depend on.
--- For example when using the restricted run time, it is replaced by
--- System.Tasking.Restricted.Stages.
-
-package body System.Task_Primitives.Operations is
-
- package OSC renames System.OS_Constants;
- package SSL renames System.Soft_Links;
-
- use System.Tasking.Debug;
- use System.Tasking;
- use Interfaces.C;
- use System.OS_Interface;
- use System.Parameters;
- use System.OS_Primitives;
-
- ----------------
- -- Local Data --
- ----------------
-
- -- The following are logically constants, but need to be initialized
- -- at run time.
-
- Environment_Task_Id : Task_Id;
- -- A variable to hold Task_Id for the environment task.
- -- If we use this variable to get the Task_Id, we need the following
- -- ATCB_Key only for non-Ada threads.
-
- Unblocked_Signal_Mask : aliased sigset_t;
- -- The set of signals that should unblocked in all tasks
-
- ATCB_Key : aliased thread_key_t;
- -- Key used to find the Ada Task_Id associated with a thread,
- -- at least for C threads unknown to the Ada run-time system.
-
- Single_RTS_Lock : aliased RTS_Lock;
- -- This is a lock to allow only one thread of control in the RTS at
- -- a time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-
- Next_Serial_Number : Task_Serial_Number := 100;
- -- We start at 100, to reserve some special values for
- -- using in error checking.
- -- The following are internal configuration constants needed.
-
- Abort_Handler_Installed : Boolean := False;
- -- True if a handler for the abort signal is installed
-
- Null_Thread_Id : constant Thread_Id := Thread_Id'Last;
- -- Constant to indicate that the thread identifier has not yet been
- -- initialized.
-
- ----------------------
- -- Priority Support --
- ----------------------
-
- Priority_Ceiling_Emulation : constant Boolean := True;
- -- controls whether we emulate priority ceiling locking
-
- -- To get a scheduling close to annex D requirements, we use the real-time
- -- class provided for LWPs and map each task/thread to a specific and
- -- unique LWP (there is 1 thread per LWP, and 1 LWP per thread).
-
- -- The real time class can only be set when the process has root
- -- privileges, so in the other cases, we use the normal thread scheduling
- -- and priority handling.
-
- Using_Real_Time_Class : Boolean := False;
- -- indicates whether the real time class is being used (i.e. the process
- -- has root privileges).
-
- Prio_Param : aliased struct_pcparms;
- -- Hold priority info (Real_Time) initialized during the package
- -- elaboration.
-
- -----------------------------------
- -- External Configuration Values --
- -----------------------------------
-
- Time_Slice_Val : Integer;
- pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
-
- Locking_Policy : Character;
- pragma Import (C, Locking_Policy, "__gl_locking_policy");
-
- Dispatching_Policy : Character;
- pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
-
- Foreign_Task_Elaborated : aliased Boolean := True;
- -- Used to identified fake tasks (i.e., non-Ada Threads)
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function sysconf (name : System.OS_Interface.int) return processorid_t;
- pragma Import (C, sysconf, "sysconf");
-
- SC_NPROCESSORS_CONF : constant System.OS_Interface.int := 14;
-
- function Num_Procs
- (name : System.OS_Interface.int := SC_NPROCESSORS_CONF)
- return processorid_t renames sysconf;
-
- procedure Abort_Handler
- (Sig : Signal;
- Code : not null access siginfo_t;
- Context : not null access ucontext_t);
- -- Target-dependent binding of inter-thread Abort signal to
- -- the raising of the Abort_Signal exception.
- -- See also comments in 7staprop.adb
-
- ------------
- -- Checks --
- ------------
-
- function Check_Initialize_Lock
- (L : Lock_Ptr;
- Level : Lock_Level) return Boolean;
- pragma Inline (Check_Initialize_Lock);
-
- function Check_Lock (L : Lock_Ptr) return Boolean;
- pragma Inline (Check_Lock);
-
- function Record_Lock (L : Lock_Ptr) return Boolean;
- pragma Inline (Record_Lock);
-
- function Check_Sleep (Reason : Task_States) return Boolean;
- pragma Inline (Check_Sleep);
-
- function Record_Wakeup
- (L : Lock_Ptr;
- Reason : Task_States) return Boolean;
- pragma Inline (Record_Wakeup);
-
- function Check_Wakeup
- (T : Task_Id;
- Reason : Task_States) return Boolean;
- pragma Inline (Check_Wakeup);
-
- function Check_Unlock (L : Lock_Ptr) return Boolean;
- pragma Inline (Check_Unlock);
-
- function Check_Finalize_Lock (L : Lock_Ptr) return Boolean;
- pragma Inline (Check_Finalize_Lock);
-
- --------------------
- -- Local Packages --
- --------------------
-
- package Specific is
-
- procedure Initialize (Environment_Task : Task_Id);
- pragma Inline (Initialize);
- -- Initialize various data needed by this package
-
- function Is_Valid_Task return Boolean;
- pragma Inline (Is_Valid_Task);
- -- Does executing thread have a TCB?
-
- procedure Set (Self_Id : Task_Id);
- pragma Inline (Set);
- -- Set the self id for the current task
-
- function Self return Task_Id;
- pragma Inline (Self);
- -- Return a pointer to the Ada Task Control Block of the calling task
-
- end Specific;
-
- package body Specific is separate;
- -- The body of this package is target specific
-
- ----------------------------------
- -- ATCB allocation/deallocation --
- ----------------------------------
-
- package body ATCB_Allocation is separate;
- -- The body of this package is shared across several targets
-
- ---------------------------------
- -- Support for foreign threads --
- ---------------------------------
-
- function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread
-
- function Register_Foreign_Thread
- (Thread : Thread_Id) return Task_Id is separate;
-
- ------------
- -- Checks --
- ------------
-
- Check_Count : Integer := 0;
- Lock_Count : Integer := 0;
- Unlock_Count : Integer := 0;
-
- -------------------
- -- Abort_Handler --
- -------------------
-
- procedure Abort_Handler
- (Sig : Signal;
- Code : not null access siginfo_t;
- Context : not null access ucontext_t)
- is
- pragma Unreferenced (Sig);
- pragma Unreferenced (Code);
- pragma Unreferenced (Context);
-
- Self_ID : constant Task_Id := Self;
- Old_Set : aliased sigset_t;
-
- Result : Interfaces.C.int;
- pragma Warnings (Off, Result);
-
- begin
- -- It's not safe to raise an exception when using GCC ZCX mechanism.
- -- Note that we still need to install a signal handler, since in some
- -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
- -- need to send the Abort signal to a task.
-
- if ZCX_By_Default then
- return;
- end if;
-
- if Self_ID.Deferral_Level = 0
- and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- and then not Self_ID.Aborting
- then
- Self_ID.Aborting := True;
-
- -- Make sure signals used for RTS internal purpose are unmasked
-
- Result :=
- thr_sigsetmask
- (SIG_UNBLOCK,
- Unblocked_Signal_Mask'Unchecked_Access,
- Old_Set'Unchecked_Access);
- pragma Assert (Result = 0);
-
- raise Standard'Abort_Signal;
- end if;
- end Abort_Handler;
-
- -----------------
- -- Stack_Guard --
- -----------------
-
- -- The underlying thread system sets a guard page at the
- -- bottom of a thread stack, so nothing is needed.
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- pragma Unreferenced (T);
- pragma Unreferenced (On);
- begin
- null;
- end Stack_Guard;
-
- -------------------
- -- Get_Thread_Id --
- -------------------
-
- function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
- begin
- return T.Common.LL.Thread;
- end Get_Thread_Id;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : ST.Task_Id) is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Tmp_Set : aliased sigset_t;
- Result : Interfaces.C.int;
-
- procedure Configure_Processors;
- -- Processors configuration
- -- The user can specify a processor which the program should run
- -- on to emulate a single-processor system. This can be easily
- -- done by setting environment variable GNAT_PROCESSOR to one of
- -- the following :
- --
- -- -2 : use the default configuration (run the program on all
- -- available processors) - this is the same as having
- -- GNAT_PROCESSOR unset
- -- -1 : let the RTS choose one processor and run the program on
- -- that processor
- -- 0 .. Last_Proc : run the program on the specified processor
- --
- -- Last_Proc is equal to the value of the system variable
- -- _SC_NPROCESSORS_CONF, minus one.
-
- procedure Configure_Processors is
- Proc_Acc : constant System.OS_Lib.String_Access :=
- System.OS_Lib.Getenv ("GNAT_PROCESSOR");
- Proc : aliased processorid_t; -- User processor #
- Last_Proc : processorid_t; -- Last processor #
-
- begin
- if Proc_Acc.all'Length /= 0 then
-
- -- Environment variable is defined
-
- Last_Proc := Num_Procs - 1;
-
- if Last_Proc /= -1 then
- Proc := processorid_t'Value (Proc_Acc.all);
-
- if Proc <= -2 or else Proc > Last_Proc then
-
- -- Use the default configuration
-
- null;
-
- elsif Proc = -1 then
-
- -- Choose a processor
-
- Result := 0;
- while Proc < Last_Proc loop
- Proc := Proc + 1;
- Result := p_online (Proc, PR_STATUS);
- exit when Result = PR_ONLINE;
- end loop;
-
- pragma Assert (Result = PR_ONLINE);
- Result := processor_bind (P_PID, P_MYID, Proc, null);
- pragma Assert (Result = 0);
-
- else
- -- Use user processor
-
- Result := processor_bind (P_PID, P_MYID, Proc, null);
- pragma Assert (Result = 0);
- end if;
- end if;
- end if;
-
- exception
- when Constraint_Error =>
-
- -- Illegal environment variable GNAT_PROCESSOR - ignored
-
- null;
- end Configure_Processors;
-
- function State
- (Int : System.Interrupt_Management.Interrupt_ID) return Character;
- pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in a-init.c
- -- The input argument is the interrupt number,
- -- and the result is one of the following:
-
- Default : constant Character := 's';
- -- 'n' this interrupt not set by any Interrupt_State pragma
- -- 'u' Interrupt_State pragma set state to User
- -- 'r' Interrupt_State pragma set state to Runtime
- -- 's' Interrupt_State pragma set state to System (use "default"
- -- system handler)
-
- -- Start of processing for Initialize
-
- begin
- Environment_Task_Id := Environment_Task;
-
- Interrupt_Management.Initialize;
-
- -- Prepare the set of signals that should unblocked in all tasks
-
- Result := sigemptyset (Unblocked_Signal_Mask'Access);
- pragma Assert (Result = 0);
-
- for J in Interrupt_Management.Interrupt_ID loop
- if System.Interrupt_Management.Keep_Unmasked (J) then
- Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
- pragma Assert (Result = 0);
- end if;
- end loop;
-
- if Dispatching_Policy = 'F' then
- declare
- Result : Interfaces.C.long;
- Class_Info : aliased struct_pcinfo;
- Secs, Nsecs : Interfaces.C.long;
-
- begin
- -- If a pragma Time_Slice is specified, takes the value in account
-
- if Time_Slice_Val > 0 then
-
- -- Convert Time_Slice_Val (microseconds) to seconds/nanosecs
-
- Secs := Interfaces.C.long (Time_Slice_Val / 1_000_000);
- Nsecs :=
- Interfaces.C.long ((Time_Slice_Val rem 1_000_000) * 1_000);
-
- -- Otherwise, default to no time slicing (i.e run until blocked)
-
- else
- Secs := RT_TQINF;
- Nsecs := RT_TQINF;
- end if;
-
- -- Get the real time class id
-
- Class_Info.pc_clname (1) := 'R';
- Class_Info.pc_clname (2) := 'T';
- Class_Info.pc_clname (3) := ASCII.NUL;
-
- Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID,
- Class_Info'Address);
-
- -- Request the real time class
-
- Prio_Param.pc_cid := Class_Info.pc_cid;
- Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri);
- Prio_Param.rt_tqsecs := Secs;
- Prio_Param.rt_tqnsecs := Nsecs;
-
- Result :=
- priocntl
- (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS, Prio_Param'Address);
-
- Using_Real_Time_Class := Result /= -1;
- end;
- end if;
-
- Specific.Initialize (Environment_Task);
-
- -- The following is done in Enter_Task, but this is too late for the
- -- Environment Task, since we need to call Self in Check_Locks when
- -- the run time is compiled with assertions on.
-
- Specific.Set (Environment_Task);
-
- -- Initialize the lock used to synchronize chain of all ATCBs
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- -- Make environment task known here because it doesn't go through
- -- Activate_Tasks, which does it for all other tasks.
-
- Known_Tasks (Known_Tasks'First) := Environment_Task;
- Environment_Task.Known_Tasks_Index := Known_Tasks'First;
-
- Enter_Task (Environment_Task);
-
- Configure_Processors;
-
- if State
- (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
- then
- -- Set sa_flags to SA_NODEFER so that during the handler execution
- -- we do not change the Signal_Mask to be masked for the Abort_Signal
- -- This is a temporary fix to the problem that the Signal_Mask is
- -- not restored after the exception (longjmp) from the handler.
- -- The right fix should be made in sigsetjmp so that we save
- -- the Signal_Set and restore it after a longjmp.
- -- In that case, this field should be changed back to 0. ???
-
- act.sa_flags := 16;
-
- act.sa_handler := Abort_Handler'Address;
- Result := sigemptyset (Tmp_Set'Access);
- pragma Assert (Result = 0);
- act.sa_mask := Tmp_Set;
-
- Result :=
- sigaction
- (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
- Abort_Handler_Installed := True;
- end if;
- end Initialize;
-
- ---------------------
- -- Initialize_Lock --
- ---------------------
-
- -- Note: mutexes and cond_variables needed per-task basis are initialized
- -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
- -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
- -- status change of RTS. Therefore raising Storage_Error in the following
- -- routines should be able to be handled safely.
-
- procedure Initialize_Lock
- (Prio : System.Any_Priority;
- L : not null access Lock)
- is
- Result : Interfaces.C.int;
-
- begin
- pragma Assert (Check_Initialize_Lock (Lock_Ptr (L), PO_Level));
-
- if Priority_Ceiling_Emulation then
- L.Ceiling := Prio;
- end if;
-
- Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error with "Failed to allocate a lock";
- end if;
- end Initialize_Lock;
-
- procedure Initialize_Lock
- (L : not null access RTS_Lock;
- Level : Lock_Level)
- is
- Result : Interfaces.C.int;
-
- begin
- pragma Assert
- (Check_Initialize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level));
- Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error with "Failed to allocate a lock";
- end if;
- end Initialize_Lock;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : not null access Lock) is
- Result : Interfaces.C.int;
- begin
- pragma Assert (Check_Finalize_Lock (Lock_Ptr (L)));
- Result := mutex_destroy (L.L'Access);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : not null access RTS_Lock) is
- Result : Interfaces.C.int;
- begin
- pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
- Result := mutex_destroy (L.L'Access);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- ----------------
- -- Write_Lock --
- ----------------
-
- procedure Write_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- Result : Interfaces.C.int;
-
- begin
- pragma Assert (Check_Lock (Lock_Ptr (L)));
-
- if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
- declare
- Self_Id : constant Task_Id := Self;
- Saved_Priority : System.Any_Priority;
-
- begin
- if Self_Id.Common.LL.Active_Priority > L.Ceiling then
- Ceiling_Violation := True;
- return;
- end if;
-
- Saved_Priority := Self_Id.Common.LL.Active_Priority;
-
- if Self_Id.Common.LL.Active_Priority < L.Ceiling then
- Set_Priority (Self_Id, L.Ceiling);
- end if;
-
- Result := mutex_lock (L.L'Access);
- pragma Assert (Result = 0);
- Ceiling_Violation := False;
-
- L.Saved_Priority := Saved_Priority;
- end;
-
- else
- Result := mutex_lock (L.L'Access);
- pragma Assert (Result = 0);
- Ceiling_Violation := False;
- end if;
-
- pragma Assert (Record_Lock (Lock_Ptr (L)));
- end Write_Lock;
-
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock or else Global_Lock then
- pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
- Result := mutex_lock (L.L'Access);
- pragma Assert (Result = 0);
- pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
- end if;
- end Write_Lock;
-
- procedure Write_Lock (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock then
- pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
- Result := mutex_lock (T.Common.LL.L.L'Access);
- pragma Assert (Result = 0);
- pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
- end if;
- end Write_Lock;
-
- ---------------
- -- Read_Lock --
- ---------------
-
- procedure Read_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean) is
- begin
- Write_Lock (L, Ceiling_Violation);
- end Read_Lock;
-
- ------------
- -- Unlock --
- ------------
-
- procedure Unlock (L : not null access Lock) is
- Result : Interfaces.C.int;
-
- begin
- pragma Assert (Check_Unlock (Lock_Ptr (L)));
-
- if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
- declare
- Self_Id : constant Task_Id := Self;
-
- begin
- Result := mutex_unlock (L.L'Access);
- pragma Assert (Result = 0);
-
- if Self_Id.Common.LL.Active_Priority > L.Saved_Priority then
- Set_Priority (Self_Id, L.Saved_Priority);
- end if;
- end;
- else
- Result := mutex_unlock (L.L'Access);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock or else Global_Lock then
- pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
- Result := mutex_unlock (L.L'Access);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- procedure Unlock (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- if not Single_Lock then
- pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access)));
- Result := mutex_unlock (T.Common.LL.L.L'Access);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- -----------------
- -- Set_Ceiling --
- -----------------
-
- -- Dynamic priority ceilings are not supported by the underlying system
-
- procedure Set_Ceiling
- (L : not null access Lock;
- Prio : System.Any_Priority)
- is
- pragma Unreferenced (L, Prio);
- begin
- null;
- end Set_Ceiling;
-
- -- For the time delay implementation, we need to make sure we
- -- achieve following criteria:
-
- -- 1) We have to delay at least for the amount requested.
- -- 2) We have to give up CPU even though the actual delay does not
- -- result in blocking.
- -- 3) Except for restricted run-time systems that do not support
- -- ATC or task abort, the delay must be interrupted by the
- -- abort_task operation.
- -- 4) The implementation has to be efficient so that the delay overhead
- -- is relatively cheap.
- -- (1)-(3) are Ada requirements. Even though (2) is an Annex-D
- -- requirement we still want to provide the effect in all cases.
- -- The reason is that users may want to use short delays to implement
- -- their own scheduling effect in the absence of language provided
- -- scheduling policies.
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- function Monotonic_Clock return Duration is
- TS : aliased timespec;
- Result : Interfaces.C.int;
- begin
- Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
- pragma Assert (Result = 0);
- return To_Duration (TS);
- end Monotonic_Clock;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- TS : aliased timespec;
- Result : Interfaces.C.int;
- begin
- Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
- pragma Assert (Result = 0);
-
- return To_Duration (TS);
- end RT_Resolution;
-
- -----------
- -- Yield --
- -----------
-
- procedure Yield (Do_Yield : Boolean := True) is
- begin
- if Do_Yield then
- System.OS_Interface.thr_yield;
- end if;
- end Yield;
-
- -----------
- -- Self ---
- -----------
-
- function Self return Task_Id renames Specific.Self;
-
- ------------------
- -- Set_Priority --
- ------------------
-
- procedure Set_Priority
- (T : Task_Id;
- Prio : System.Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- pragma Unreferenced (Loss_Of_Inheritance);
-
- Result : Interfaces.C.int;
- pragma Unreferenced (Result);
-
- Param : aliased struct_pcparms;
-
- use Task_Info;
-
- begin
- T.Common.Current_Priority := Prio;
-
- if Priority_Ceiling_Emulation then
- T.Common.LL.Active_Priority := Prio;
- end if;
-
- if Using_Real_Time_Class then
- Param.pc_cid := Prio_Param.pc_cid;
- Param.rt_pri := pri_t (Prio);
- Param.rt_tqsecs := Prio_Param.rt_tqsecs;
- Param.rt_tqnsecs := Prio_Param.rt_tqnsecs;
-
- Result := Interfaces.C.int (
- priocntl (PC_VERSION, P_LWPID, T.Common.LL.LWP, PC_SETPARMS,
- Param'Address));
-
- else
- if T.Common.Task_Info /= null
- and then not T.Common.Task_Info.Bound_To_LWP
- then
- -- The task is not bound to a LWP, so use thr_setprio
-
- Result :=
- thr_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
-
- else
- -- The task is bound to a LWP, use priocntl
- -- ??? TBD
-
- null;
- end if;
- end if;
- end Set_Priority;
-
- ------------------
- -- Get_Priority --
- ------------------
-
- function Get_Priority (T : Task_Id) return System.Any_Priority is
- begin
- return T.Common.Current_Priority;
- end Get_Priority;
-
- ----------------
- -- Enter_Task --
- ----------------
-
- procedure Enter_Task (Self_ID : Task_Id) is
- begin
- Self_ID.Common.LL.Thread := thr_self;
- Self_ID.Common.LL.LWP := lwp_self;
-
- Set_Task_Affinity (Self_ID);
- Specific.Set (Self_ID);
-
- -- We need the above code even if we do direct fetch of Task_Id in Self
- -- for the main task on Sun, x86 Solaris and for gcc 2.7.2.
- end Enter_Task;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
-
- -----------------------------
- -- Register_Foreign_Thread --
- -----------------------------
-
- function Register_Foreign_Thread return Task_Id is
- begin
- if Is_Valid_Task then
- return Self;
- else
- return Register_Foreign_Thread (thr_self);
- end if;
- end Register_Foreign_Thread;
-
- --------------------
- -- Initialize_TCB --
- --------------------
-
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- Result : Interfaces.C.int := 0;
-
- begin
- -- Give the task a unique serial number
-
- Self_ID.Serial_Number := Next_Serial_Number;
- Next_Serial_Number := Next_Serial_Number + 1;
- pragma Assert (Next_Serial_Number /= 0);
-
- Self_ID.Common.LL.Thread := Null_Thread_Id;
-
- if not Single_Lock then
- Result :=
- mutex_init
- (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address);
- Self_ID.Common.LL.L.Level :=
- Private_Task_Serial_Number (Self_ID.Serial_Number);
- pragma Assert (Result = 0 or else Result = ENOMEM);
- end if;
-
- if Result = 0 then
- Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0);
- pragma Assert (Result = 0 or else Result = ENOMEM);
- end if;
-
- if Result = 0 then
- Succeeded := True;
- else
- if not Single_Lock then
- Result := mutex_destroy (Self_ID.Common.LL.L.L'Access);
- pragma Assert (Result = 0);
- end if;
-
- Succeeded := False;
- end if;
- end Initialize_TCB;
-
- -----------------
- -- Create_Task --
- -----------------
-
- procedure Create_Task
- (T : Task_Id;
- Wrapper : System.Address;
- Stack_Size : System.Parameters.Size_Type;
- Priority : System.Any_Priority;
- Succeeded : out Boolean)
- is
- pragma Unreferenced (Priority);
-
- Result : Interfaces.C.int;
- Adjusted_Stack_Size : Interfaces.C.size_t;
- Opts : Interfaces.C.int := THR_DETACHED;
-
- Page_Size : constant System.Parameters.Size_Type := 4096;
- -- This constant is for reserving extra space at the
- -- end of the stack, which can be used by the stack
- -- checking as guard page. The idea is that we need
- -- to have at least Stack_Size bytes available for
- -- actual use.
-
- use System.Task_Info;
- use type System.Multiprocessors.CPU_Range;
-
- begin
- -- Check whether both Dispatching_Domain and CPU are specified for the
- -- task, and the CPU value is not contained within the range of
- -- processors for the domain.
-
- if T.Common.Domain /= null
- and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
- and then
- (T.Common.Base_CPU not in T.Common.Domain'Range
- or else not T.Common.Domain (T.Common.Base_CPU))
- then
- Succeeded := False;
- return;
- end if;
-
- Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Page_Size);
-
- -- Since the initial signal mask of a thread is inherited from the
- -- creator, and the Environment task has all its signals masked, we
- -- do not need to manipulate caller's signal mask at this point.
- -- All tasks in RTS will have All_Tasks_Mask initially.
-
- if T.Common.Task_Info /= null then
- if T.Common.Task_Info.New_LWP then
- Opts := Opts + THR_NEW_LWP;
- end if;
-
- if T.Common.Task_Info.Bound_To_LWP then
- Opts := Opts + THR_BOUND;
- end if;
-
- else
- Opts := THR_DETACHED + THR_BOUND;
- end if;
-
- -- Note: the use of Unrestricted_Access in the following call is needed
- -- because otherwise we have an error of getting a access-to-volatile
- -- value which points to a non-volatile object. But in this case it is
- -- safe to do this, since we know we have no problems with aliasing and
- -- Unrestricted_Access bypasses this check.
-
- Result :=
- thr_create
- (System.Null_Address,
- Adjusted_Stack_Size,
- Thread_Body_Access (Wrapper),
- To_Address (T),
- Opts,
- T.Common.LL.Thread'Unrestricted_Access);
-
- Succeeded := Result = 0;
- pragma Assert
- (Result = 0
- or else Result = ENOMEM
- or else Result = EAGAIN);
- end Create_Task;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- Result : Interfaces.C.int;
-
- begin
- T.Common.LL.Thread := Null_Thread_Id;
-
- if not Single_Lock then
- Result := mutex_destroy (T.Common.LL.L.L'Access);
- pragma Assert (Result = 0);
- end if;
-
- Result := cond_destroy (T.Common.LL.CV'Access);
- pragma Assert (Result = 0);
-
- if T.Known_Tasks_Index /= -1 then
- Known_Tasks (T.Known_Tasks_Index) := null;
- end if;
-
- ATCB_Allocation.Free_ATCB (T);
- end Finalize_TCB;
-
- ---------------
- -- Exit_Task --
- ---------------
-
- -- This procedure must be called with abort deferred. It can no longer
- -- call Self or access the current task's ATCB, since the ATCB has been
- -- deallocated.
-
- procedure Exit_Task is
- begin
- Specific.Set (null);
- end Exit_Task;
-
- ----------------
- -- Abort_Task --
- ----------------
-
- procedure Abort_Task (T : Task_Id) is
- Result : Interfaces.C.int;
- begin
- if Abort_Handler_Installed then
- pragma Assert (T /= Self);
- Result :=
- thr_kill
- (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
- pragma Assert (Result = 0);
- end if;
- end Abort_Task;
-
- -----------
- -- Sleep --
- -----------
-
- procedure Sleep
- (Self_ID : Task_Id;
- Reason : Task_States)
- is
- Result : Interfaces.C.int;
-
- begin
- pragma Assert (Check_Sleep (Reason));
-
- if Single_Lock then
- Result :=
- cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access);
- else
- Result :=
- cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
- end if;
-
- pragma Assert
- (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
- pragma Assert (Result = 0 or else Result = EINTR);
- end Sleep;
-
- -- Note that we are relying heavily here on GNAT representing
- -- Calendar.Time, System.Real_Time.Time, Duration,
- -- System.Real_Time.Time_Span in the same way, i.e., as a 64-bit count of
- -- nanoseconds.
-
- -- This allows us to always pass the timeout value as a Duration
-
- -- ???
- -- We are taking liberties here with the semantics of the delays. That is,
- -- we make no distinction between delays on the Calendar clock and delays
- -- on the Real_Time clock. That is technically incorrect, if the Calendar
- -- clock happens to be reset or adjusted. To solve this defect will require
- -- modification to the compiler interface, so that it can pass through more
- -- information, to tell us here which clock to use.
-
- -- cond_timedwait will return if any of the following happens:
- -- 1) some other task did cond_signal on this condition variable
- -- In this case, the return value is 0
- -- 2) the call just returned, for no good reason
- -- This is called a "spurious wakeup".
- -- In this case, the return value may also be 0.
- -- 3) the time delay expires
- -- In this case, the return value is ETIME
- -- 4) this task received a signal, which was handled by some
- -- handler procedure, and now the thread is resuming execution
- -- UNIX calls this an "interrupted" system call.
- -- In this case, the return value is EINTR
-
- -- If the cond_timedwait returns 0 or EINTR, it is still possible that the
- -- time has actually expired, and by chance a signal or cond_signal
- -- occurred at around the same time.
-
- -- We have also observed that on some OS's the value ETIME will be
- -- returned, but the clock will show that the full delay has not yet
- -- expired.
-
- -- For these reasons, we need to check the clock after return from
- -- cond_timedwait. If the time has expired, we will set Timedout = True.
-
- -- This check might be omitted for systems on which the cond_timedwait()
- -- never returns early or wakes up spuriously.
-
- -- Annex D requires that completion of a delay cause the task to go to the
- -- end of its priority queue, regardless of whether the task actually was
- -- suspended by the delay. Since cond_timedwait does not do this on
- -- Solaris, we add a call to thr_yield at the end. We might do this at the
- -- beginning, instead, but then the round-robin effect would not be the
- -- same; the delayed task would be ahead of other tasks of the same
- -- priority that awoke while it was sleeping.
-
- -- For Timed_Sleep, we are expecting possible cond_signals to indicate
- -- other events (e.g., completion of a RV or completion of the abortable
- -- part of an async. select), we want to always return if interrupted. The
- -- caller will be responsible for checking the task state to see whether
- -- the wakeup was spurious, and to go back to sleep again in that case. We
- -- don't need to check for pending abort or priority change on the way in
- -- our out; that is the caller's responsibility.
-
- -- For Timed_Delay, we are not expecting any cond_signals or other
- -- interruptions, except for priority changes and aborts. Therefore, we
- -- don't want to return unless the delay has actually expired, or the call
- -- has been aborted. In this case, since we want to implement the entire
- -- delay statement semantics, we do need to check for pending abort and
- -- priority changes. We can quietly handle priority changes inside the
- -- procedure, since there is no entry-queue reordering involved.
-
- -----------------
- -- Timed_Sleep --
- -----------------
-
- procedure Timed_Sleep
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes;
- Reason : System.Tasking.Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- Base_Time : constant Duration := Monotonic_Clock;
- Check_Time : Duration := Base_Time;
- Abs_Time : Duration;
- Request : aliased timespec;
- Result : Interfaces.C.int;
-
- begin
- pragma Assert (Check_Sleep (Reason));
- Timedout := True;
- Yielded := False;
-
- Abs_Time :=
- (if Mode = Relative
- then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (Abs_Time);
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- if Single_Lock then
- Result :=
- cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock.L'Access, Request'Access);
- else
- Result :=
- cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L.L'Access, Request'Access);
- end if;
-
- Yielded := True;
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- if Result = 0 or Result = EINTR then
-
- -- Somebody may have called Wakeup for us
-
- Timedout := False;
- exit;
- end if;
-
- pragma Assert (Result = ETIME);
- end loop;
- end if;
-
- pragma Assert
- (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
- end Timed_Sleep;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Base_Time : constant Duration := Monotonic_Clock;
- Check_Time : Duration := Base_Time;
- Abs_Time : Duration;
- Request : aliased timespec;
- Result : Interfaces.C.int;
- Yielded : Boolean := False;
-
- begin
- if Single_Lock then
- Lock_RTS;
- end if;
-
- Write_Lock (Self_ID);
-
- Abs_Time :=
- (if Mode = Relative
- then Time + Check_Time
- else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
-
- if Abs_Time > Check_Time then
- Request := To_Timespec (Abs_Time);
- Self_ID.Common.State := Delay_Sleep;
-
- pragma Assert (Check_Sleep (Delay_Sleep));
-
- loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- if Single_Lock then
- Result :=
- cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock.L'Access,
- Request'Access);
- else
- Result :=
- cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L.L'Access,
- Request'Access);
- end if;
-
- Yielded := True;
-
- Check_Time := Monotonic_Clock;
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- pragma Assert
- (Result = 0 or else
- Result = ETIME or else
- Result = EINTR);
- end loop;
-
- pragma Assert
- (Record_Wakeup
- (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep));
-
- Self_ID.Common.State := Runnable;
- end if;
-
- Unlock (Self_ID);
-
- if Single_Lock then
- Unlock_RTS;
- end if;
-
- if not Yielded then
- thr_yield;
- end if;
- end Timed_Delay;
-
- ------------
- -- Wakeup --
- ------------
-
- procedure Wakeup
- (T : Task_Id;
- Reason : Task_States)
- is
- Result : Interfaces.C.int;
- begin
- pragma Assert (Check_Wakeup (T, Reason));
- Result := cond_signal (T.Common.LL.CV'Access);
- pragma Assert (Result = 0);
- end Wakeup;
-
- ---------------------------
- -- Check_Initialize_Lock --
- ---------------------------
-
- -- The following code is intended to check some of the invariant assertions
- -- related to lock usage, on which we depend.
-
- function Check_Initialize_Lock
- (L : Lock_Ptr;
- Level : Lock_Level) return Boolean
- is
- Self_ID : constant Task_Id := Self;
-
- begin
- -- Check that caller is abort-deferred
-
- if Self_ID.Deferral_Level = 0 then
- return False;
- end if;
-
- -- Check that the lock is not yet initialized
-
- if L.Level /= 0 then
- return False;
- end if;
-
- L.Level := Lock_Level'Pos (Level) + 1;
- return True;
- end Check_Initialize_Lock;
-
- ----------------
- -- Check_Lock --
- ----------------
-
- function Check_Lock (L : Lock_Ptr) return Boolean is
- Self_ID : constant Task_Id := Self;
- P : Lock_Ptr;
-
- begin
- -- Check that the argument is not null
-
- if L = null then
- return False;
- end if;
-
- -- Check that L is not frozen
-
- if L.Frozen then
- return False;
- end if;
-
- -- Check that caller is abort-deferred
-
- if Self_ID.Deferral_Level = 0 then
- return False;
- end if;
-
- -- Check that caller is not holding this lock already
-
- if L.Owner = To_Owner_ID (To_Address (Self_ID)) then
- return False;
- end if;
-
- if Single_Lock then
- return True;
- end if;
-
- -- Check that TCB lock order rules are satisfied
-
- P := Self_ID.Common.LL.Locks;
- if P /= null then
- if P.Level >= L.Level
- and then (P.Level > 2 or else L.Level > 2)
- then
- return False;
- end if;
- end if;
-
- return True;
- end Check_Lock;
-
- -----------------
- -- Record_Lock --
- -----------------
-
- function Record_Lock (L : Lock_Ptr) return Boolean is
- Self_ID : constant Task_Id := Self;
- P : Lock_Ptr;
-
- begin
- Lock_Count := Lock_Count + 1;
-
- -- There should be no owner for this lock at this point
-
- if L.Owner /= null then
- return False;
- end if;
-
- -- Record new owner
-
- L.Owner := To_Owner_ID (To_Address (Self_ID));
-
- if Single_Lock then
- return True;
- end if;
-
- -- Check that TCB lock order rules are satisfied
-
- P := Self_ID.Common.LL.Locks;
-
- if P /= null then
- L.Next := P;
- end if;
-
- Self_ID.Common.LL.Locking := null;
- Self_ID.Common.LL.Locks := L;
- return True;
- end Record_Lock;
-
- -----------------
- -- Check_Sleep --
- -----------------
-
- function Check_Sleep (Reason : Task_States) return Boolean is
- pragma Unreferenced (Reason);
-
- Self_ID : constant Task_Id := Self;
- P : Lock_Ptr;
-
- begin
- -- Check that caller is abort-deferred
-
- if Self_ID.Deferral_Level = 0 then
- return False;
- end if;
-
- if Single_Lock then
- return True;
- end if;
-
- -- Check that caller is holding own lock, on top of list
-
- if Self_ID.Common.LL.Locks /=
- To_Lock_Ptr (Self_ID.Common.LL.L'Access)
- then
- return False;
- end if;
-
- -- Check that TCB lock order rules are satisfied
-
- if Self_ID.Common.LL.Locks.Next /= null then
- return False;
- end if;
-
- Self_ID.Common.LL.L.Owner := null;
- P := Self_ID.Common.LL.Locks;
- Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
- P.Next := null;
- return True;
- end Check_Sleep;
-
- -------------------
- -- Record_Wakeup --
- -------------------
-
- function Record_Wakeup
- (L : Lock_Ptr;
- Reason : Task_States) return Boolean
- is
- pragma Unreferenced (Reason);
-
- Self_ID : constant Task_Id := Self;
- P : Lock_Ptr;
-
- begin
- -- Record new owner
-
- L.Owner := To_Owner_ID (To_Address (Self_ID));
-
- if Single_Lock then
- return True;
- end if;
-
- -- Check that TCB lock order rules are satisfied
-
- P := Self_ID.Common.LL.Locks;
-
- if P /= null then
- L.Next := P;
- end if;
-
- Self_ID.Common.LL.Locking := null;
- Self_ID.Common.LL.Locks := L;
- return True;
- end Record_Wakeup;
-
- ------------------
- -- Check_Wakeup --
- ------------------
-
- function Check_Wakeup
- (T : Task_Id;
- Reason : Task_States) return Boolean
- is
- Self_ID : constant Task_Id := Self;
-
- begin
- -- Is caller holding T's lock?
-
- if T.Common.LL.L.Owner /= To_Owner_ID (To_Address (Self_ID)) then
- return False;
- end if;
-
- -- Are reasons for wakeup and sleep consistent?
-
- if T.Common.State /= Reason then
- return False;
- end if;
-
- return True;
- end Check_Wakeup;
-
- ------------------
- -- Check_Unlock --
- ------------------
-
- function Check_Unlock (L : Lock_Ptr) return Boolean is
- Self_ID : constant Task_Id := Self;
- P : Lock_Ptr;
-
- begin
- Unlock_Count := Unlock_Count + 1;
-
- if L = null then
- return False;
- end if;
-
- if L.Buddy /= null then
- return False;
- end if;
-
- -- Magic constant 4???
-
- if L.Level = 4 then
- Check_Count := Unlock_Count;
- end if;
-
- -- Magic constant 1000???
-
- if Unlock_Count - Check_Count > 1000 then
- Check_Count := Unlock_Count;
- end if;
-
- -- Check that caller is abort-deferred
-
- if Self_ID.Deferral_Level = 0 then
- return False;
- end if;
-
- -- Check that caller is holding this lock, on top of list
-
- if Self_ID.Common.LL.Locks /= L then
- return False;
- end if;
-
- -- Record there is no owner now
-
- L.Owner := null;
- P := Self_ID.Common.LL.Locks;
- Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
- P.Next := null;
- return True;
- end Check_Unlock;
-
- --------------------
- -- Check_Finalize --
- --------------------
-
- function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is
- Self_ID : constant Task_Id := Self;
-
- begin
- -- Check that caller is abort-deferred
-
- if Self_ID.Deferral_Level = 0 then
- return False;
- end if;
-
- -- Check that no one is holding this lock
-
- if L.Owner /= null then
- return False;
- end if;
-
- L.Frozen := True;
- return True;
- end Check_Finalize_Lock;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- -- Initialize internal state (always to zero (RM D.10(6)))
-
- S.State := False;
- S.Waiting := False;
-
- -- Initialize internal mutex
-
- Result := mutex_init (S.L'Access, USYNC_THREAD, System.Null_Address);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error with "Failed to allocate a lock";
- end if;
-
- -- Initialize internal condition variable
-
- Result := cond_init (S.CV'Access, USYNC_THREAD, 0);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result /= 0 then
- Result := mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
- end if;
- end Initialize;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- -- Destroy internal mutex
-
- Result := mutex_destroy (S.L'Access);
- pragma Assert (Result = 0);
-
- -- Destroy internal condition variable
-
- Result := cond_destroy (S.CV'Access);
- pragma Assert (Result = 0);
- end Finalize;
-
- -------------------
- -- Current_State --
- -------------------
-
- function Current_State (S : Suspension_Object) return Boolean is
- begin
- -- We do not want to use lock on this read operation. State is marked
- -- as Atomic so that we ensure that the value retrieved is correct.
-
- return S.State;
- end Current_State;
-
- ---------------
- -- Set_False --
- ---------------
-
- procedure Set_False (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- S.State := False;
-
- Result := mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end Set_False;
-
- --------------
- -- Set_True --
- --------------
-
- procedure Set_True (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- -- If there is already a task waiting on this suspension object then
- -- we resume it, leaving the state of the suspension object to False,
- -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
- -- the state to True.
-
- if S.Waiting then
- S.Waiting := False;
- S.State := False;
-
- Result := cond_signal (S.CV'Access);
- pragma Assert (Result = 0);
-
- else
- S.State := True;
- end if;
-
- Result := mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end Set_True;
-
- ------------------------
- -- Suspend_Until_True --
- ------------------------
-
- procedure Suspend_Until_True (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := mutex_lock (S.L'Access);
- pragma Assert (Result = 0);
-
- if S.Waiting then
-
- -- Program_Error must be raised upon calling Suspend_Until_True
- -- if another task is already waiting on that suspension object
- -- (RM D.10(10)).
-
- Result := mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
-
- raise Program_Error;
-
- else
- -- Suspend the task if the state is False. Otherwise, the task
- -- continues its execution, and the state of the suspension object
- -- is set to False (ARM D.10 par. 9).
-
- if S.State then
- S.State := False;
- else
- S.Waiting := True;
-
- loop
- -- Loop in case pthread_cond_wait returns earlier than expected
- -- (e.g. in case of EINTR caused by a signal).
-
- Result := cond_wait (S.CV'Access, S.L'Access);
- pragma Assert (Result = 0 or else Result = EINTR);
-
- exit when not S.Waiting;
- end loop;
- end if;
-
- Result := mutex_unlock (S.L'Access);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
- end if;
- end Suspend_Until_True;
-
- ----------------
- -- Check_Exit --
- ----------------
-
- function Check_Exit (Self_ID : Task_Id) return Boolean is
- begin
- -- Check that caller is just holding Global_Task_Lock and no other locks
-
- if Self_ID.Common.LL.Locks = null then
- return False;
- end if;
-
- -- 2 = Global_Task_Level
-
- if Self_ID.Common.LL.Locks.Level /= 2 then
- return False;
- end if;
-
- if Self_ID.Common.LL.Locks.Next /= null then
- return False;
- end if;
-
- -- Check that caller is abort-deferred
-
- if Self_ID.Deferral_Level = 0 then
- return False;
- end if;
-
- return True;
- end Check_Exit;
-
- --------------------
- -- Check_No_Locks --
- --------------------
-
- function Check_No_Locks (Self_ID : Task_Id) return Boolean is
- begin
- return Self_ID.Common.LL.Locks = null;
- end Check_No_Locks;
-
- ----------------------
- -- Environment_Task --
- ----------------------
-
- function Environment_Task return Task_Id is
- begin
- return Environment_Task_Id;
- end Environment_Task;
-
- --------------
- -- Lock_RTS --
- --------------
-
- procedure Lock_RTS is
- begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
- end Lock_RTS;
-
- ----------------
- -- Unlock_RTS --
- ----------------
-
- procedure Unlock_RTS is
- begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
- end Unlock_RTS;
-
- ------------------
- -- Suspend_Task --
- ------------------
-
- function Suspend_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- begin
- if T.Common.LL.Thread /= Thread_Self then
- return thr_suspend (T.Common.LL.Thread) = 0;
- else
- return True;
- end if;
- end Suspend_Task;
-
- -----------------
- -- Resume_Task --
- -----------------
-
- function Resume_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- begin
- if T.Common.LL.Thread /= Thread_Self then
- return thr_continue (T.Common.LL.Thread) = 0;
- else
- return True;
- end if;
- end Resume_Task;
-
- --------------------
- -- Stop_All_Tasks --
- --------------------
-
- procedure Stop_All_Tasks is
- begin
- null;
- end Stop_All_Tasks;
-
- ---------------
- -- Stop_Task --
- ---------------
-
- function Stop_Task (T : ST.Task_Id) return Boolean is
- pragma Unreferenced (T);
- begin
- return False;
- end Stop_Task;
-
- -------------------
- -- Continue_Task --
- -------------------
-
- function Continue_Task (T : ST.Task_Id) return Boolean is
- pragma Unreferenced (T);
- begin
- return False;
- end Continue_Task;
-
- -----------------------
- -- Set_Task_Affinity --
- -----------------------
-
- procedure Set_Task_Affinity (T : ST.Task_Id) is
- Result : Interfaces.C.int;
- Proc : processorid_t; -- User processor #
- Last_Proc : processorid_t; -- Last processor #
-
- use System.Task_Info;
- use type System.Multiprocessors.CPU_Range;
-
- begin
- -- Do nothing if the underlying thread has not yet been created. If the
- -- thread has not yet been created then the proper affinity will be set
- -- during its creation.
-
- if T.Common.LL.Thread = Null_Thread_Id then
- null;
-
- -- pragma CPU
-
- elsif T.Common.Base_CPU /=
- System.Multiprocessors.Not_A_Specific_CPU
- then
- -- The CPU numbering in pragma CPU starts at 1 while the subprogram
- -- to set the affinity starts at 0, therefore we must substract 1.
-
- Result :=
- processor_bind
- (P_LWPID, id_t (T.Common.LL.LWP),
- processorid_t (T.Common.Base_CPU) - 1, null);
- pragma Assert (Result = 0);
-
- -- Task_Info
-
- elsif T.Common.Task_Info /= null then
- if T.Common.Task_Info.New_LWP
- and then T.Common.Task_Info.CPU /= CPU_UNCHANGED
- then
- Last_Proc := Num_Procs - 1;
-
- if T.Common.Task_Info.CPU = ANY_CPU then
- Result := 0;
-
- Proc := 0;
- while Proc < Last_Proc loop
- Result := p_online (Proc, PR_STATUS);
- exit when Result = PR_ONLINE;
- Proc := Proc + 1;
- end loop;
-
- Result :=
- processor_bind
- (P_LWPID, id_t (T.Common.LL.LWP), Proc, null);
- pragma Assert (Result = 0);
-
- else
- -- Use specified processor
-
- if T.Common.Task_Info.CPU < 0
- or else T.Common.Task_Info.CPU > Last_Proc
- then
- raise Invalid_CPU_Number;
- end if;
-
- Result :=
- processor_bind
- (P_LWPID, id_t (T.Common.LL.LWP),
- T.Common.Task_Info.CPU, null);
- pragma Assert (Result = 0);
- end if;
- end if;
-
- -- Handle dispatching domains
-
- elsif T.Common.Domain /= null
- and then (T.Common.Domain /= ST.System_Domain
- or else T.Common.Domain.all /=
- (Multiprocessors.CPU'First ..
- Multiprocessors.Number_Of_CPUs => True))
- then
- declare
- CPU_Set : aliased psetid_t;
- Result : int;
-
- begin
- Result := pset_create (CPU_Set'Access);
- pragma Assert (Result = 0);
-
- -- Set the affinity to all the processors belonging to the
- -- dispatching domain.
-
- for Proc in T.Common.Domain'Range loop
-
- -- The Ada CPU numbering starts at 1 while the subprogram to
- -- set the affinity starts at 0, therefore we must substract 1.
-
- if T.Common.Domain (Proc) then
- Result :=
- pset_assign (CPU_Set, processorid_t (Proc) - 1, null);
- pragma Assert (Result = 0);
- end if;
- end loop;
-
- Result :=
- pset_bind (CPU_Set, P_LWPID, id_t (T.Common.LL.LWP), null);
- pragma Assert (Result = 0);
- end;
- end if;
- end Set_Task_Affinity;
-
-end System.Task_Primitives.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the VxWorks version of this package
-
--- This package contains all the GNULL primitives that interface directly with
--- the underlying OS.
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with Ada.Unchecked_Conversion;
-
-with Interfaces.C;
-
-with System.Multiprocessors;
-with System.Tasking.Debug;
-with System.Interrupt_Management;
-with System.Float_Control;
-with System.OS_Constants;
-
-with System.Soft_Links;
--- We use System.Soft_Links instead of System.Tasking.Initialization
--- because the later is a higher level package that we shouldn't depend
--- on. For example when using the restricted run time, it is replaced by
--- System.Tasking.Restricted.Stages.
-
-with System.Task_Info;
-with System.VxWorks.Ext;
-
-package body System.Task_Primitives.Operations is
-
- package OSC renames System.OS_Constants;
- package SSL renames System.Soft_Links;
-
- use System.Tasking.Debug;
- use System.Tasking;
- use System.OS_Interface;
- use System.Parameters;
- use type System.VxWorks.Ext.t_id;
- use type Interfaces.C.int;
- use type System.OS_Interface.unsigned;
-
- subtype int is System.OS_Interface.int;
- subtype unsigned is System.OS_Interface.unsigned;
-
- Relative : constant := 0;
-
- ----------------
- -- Local Data --
- ----------------
-
- -- The followings are logically constants, but need to be initialized at
- -- run time.
-
- Environment_Task_Id : Task_Id;
- -- A variable to hold Task_Id for the environment task
-
- -- The followings are internal configuration constants needed
-
- Dispatching_Policy : Character;
- pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
-
- Foreign_Task_Elaborated : aliased Boolean := True;
- -- Used to identified fake tasks (i.e., non-Ada Threads)
-
- Locking_Policy : Character;
- pragma Import (C, Locking_Policy, "__gl_locking_policy");
-
- Mutex_Protocol : Priority_Type;
-
- Single_RTS_Lock : aliased RTS_Lock;
- -- This is a lock to allow only one thread of control in the RTS at a
- -- time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-
- Time_Slice_Val : Integer;
- pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
-
- Null_Thread_Id : constant Thread_Id := 0;
- -- Constant to indicate that the thread identifier has not yet been
- -- initialized.
-
- --------------------
- -- Local Packages --
- --------------------
-
- package Specific is
-
- procedure Initialize;
- pragma Inline (Initialize);
- -- Initialize task specific data
-
- function Is_Valid_Task return Boolean;
- pragma Inline (Is_Valid_Task);
- -- Does executing thread have a TCB?
-
- procedure Set (Self_Id : Task_Id);
- pragma Inline (Set);
- -- Set the self id for the current task, unless Self_Id is null, in
- -- which case the task specific data is deleted.
-
- function Self return Task_Id;
- pragma Inline (Self);
- -- Return a pointer to the Ada Task Control Block of the calling task
-
- end Specific;
-
- package body Specific is separate;
- -- The body of this package is target specific
-
- ----------------------------------
- -- ATCB allocation/deallocation --
- ----------------------------------
-
- package body ATCB_Allocation is separate;
- -- The body of this package is shared across several targets
-
- ---------------------------------
- -- Support for foreign threads --
- ---------------------------------
-
- function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread
-
- function Register_Foreign_Thread
- (Thread : Thread_Id) return Task_Id is separate;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Abort_Handler (signo : Signal);
- -- Handler for the abort (SIGABRT) signal to handle asynchronous abort
-
- procedure Install_Signal_Handlers;
- -- Install the default signal handlers for the current task
-
- function Is_Task_Context return Boolean;
- -- This function returns True if the current execution is in the context of
- -- a task, and False if it is an interrupt context.
-
- type Set_Stack_Limit_Proc_Acc is access procedure;
- pragma Convention (C, Set_Stack_Limit_Proc_Acc);
-
- Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
- pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
- -- Procedure to be called when a task is created to set stack limit. Used
- -- only for VxWorks 5 and VxWorks MILS guest OS.
-
- function To_Address is
- new Ada.Unchecked_Conversion (Task_Id, System.Address);
-
- -------------------
- -- Abort_Handler --
- -------------------
-
- procedure Abort_Handler (signo : Signal) is
- pragma Unreferenced (signo);
-
- Self_ID : constant Task_Id := Self;
- Old_Set : aliased sigset_t;
- Unblocked_Mask : aliased sigset_t;
- Result : int;
- pragma Warnings (Off, Result);
-
- use System.Interrupt_Management;
-
- begin
- -- It is not safe to raise an exception when using ZCX and the GCC
- -- exception handling mechanism.
-
- if ZCX_By_Default then
- return;
- end if;
-
- if Self_ID.Deferral_Level = 0
- and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- and then not Self_ID.Aborting
- then
- Self_ID.Aborting := True;
-
- -- Make sure signals used for RTS internal purposes are unmasked
-
- Result := sigemptyset (Unblocked_Mask'Access);
- pragma Assert (Result = 0);
- Result :=
- sigaddset
- (Unblocked_Mask'Access,
- Signal (Abort_Task_Interrupt));
- pragma Assert (Result = 0);
- Result := sigaddset (Unblocked_Mask'Access, SIGBUS);
- pragma Assert (Result = 0);
- Result := sigaddset (Unblocked_Mask'Access, SIGFPE);
- pragma Assert (Result = 0);
- Result := sigaddset (Unblocked_Mask'Access, SIGILL);
- pragma Assert (Result = 0);
- Result := sigaddset (Unblocked_Mask'Access, SIGSEGV);
- pragma Assert (Result = 0);
-
- Result :=
- pthread_sigmask
- (SIG_UNBLOCK,
- Unblocked_Mask'Access,
- Old_Set'Access);
- pragma Assert (Result = 0);
-
- raise Standard'Abort_Signal;
- end if;
- end Abort_Handler;
-
- -----------------
- -- Stack_Guard --
- -----------------
-
- procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- pragma Unreferenced (T);
- pragma Unreferenced (On);
-
- begin
- -- Nothing needed (why not???)
-
- null;
- end Stack_Guard;
-
- -------------------
- -- Get_Thread_Id --
- -------------------
-
- function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
- begin
- return T.Common.LL.Thread;
- end Get_Thread_Id;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_Id renames Specific.Self;
-
- -----------------------------
- -- Install_Signal_Handlers --
- -----------------------------
-
- procedure Install_Signal_Handlers is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Tmp_Set : aliased sigset_t;
- Result : int;
-
- begin
- act.sa_flags := 0;
- act.sa_handler := Abort_Handler'Address;
-
- Result := sigemptyset (Tmp_Set'Access);
- pragma Assert (Result = 0);
- act.sa_mask := Tmp_Set;
-
- Result :=
- sigaction
- (Signal (Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
-
- Interrupt_Management.Initialize_Interrupts;
- end Install_Signal_Handlers;
-
- ---------------------
- -- Initialize_Lock --
- ---------------------
-
- procedure Initialize_Lock
- (Prio : System.Any_Priority;
- L : not null access Lock)
- is
- begin
- L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
- L.Prio_Ceiling := int (Prio);
- L.Protocol := Mutex_Protocol;
- pragma Assert (L.Mutex /= 0);
- end Initialize_Lock;
-
- procedure Initialize_Lock
- (L : not null access RTS_Lock;
- Level : Lock_Level)
- is
- pragma Unreferenced (Level);
- begin
- L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
- L.Prio_Ceiling := int (System.Any_Priority'Last);
- L.Protocol := Mutex_Protocol;
- pragma Assert (L.Mutex /= 0);
- end Initialize_Lock;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : not null access Lock) is
- Result : int;
- begin
- Result := semDelete (L.Mutex);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : not null access RTS_Lock) is
- Result : int;
- begin
- Result := semDelete (L.Mutex);
- pragma Assert (Result = 0);
- end Finalize_Lock;
-
- ----------------
- -- Write_Lock --
- ----------------
-
- procedure Write_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- Result : int;
-
- begin
- if L.Protocol = Prio_Protect
- and then int (Self.Common.Current_Priority) > L.Prio_Ceiling
- then
- Ceiling_Violation := True;
- return;
- else
- Ceiling_Violation := False;
- end if;
-
- Result := semTake (L.Mutex, WAIT_FOREVER);
- pragma Assert (Result = 0);
- end Write_Lock;
-
- procedure Write_Lock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : int;
- begin
- if not Single_Lock or else Global_Lock then
- Result := semTake (L.Mutex, WAIT_FOREVER);
- pragma Assert (Result = 0);
- end if;
- end Write_Lock;
-
- procedure Write_Lock (T : Task_Id) is
- Result : int;
- begin
- if not Single_Lock then
- Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
- pragma Assert (Result = 0);
- end if;
- end Write_Lock;
-
- ---------------
- -- Read_Lock --
- ---------------
-
- procedure Read_Lock
- (L : not null access Lock;
- Ceiling_Violation : out Boolean)
- is
- begin
- Write_Lock (L, Ceiling_Violation);
- end Read_Lock;
-
- ------------
- -- Unlock --
- ------------
-
- procedure Unlock (L : not null access Lock) is
- Result : int;
- begin
- Result := semGive (L.Mutex);
- pragma Assert (Result = 0);
- end Unlock;
-
- procedure Unlock
- (L : not null access RTS_Lock;
- Global_Lock : Boolean := False)
- is
- Result : int;
- begin
- if not Single_Lock or else Global_Lock then
- Result := semGive (L.Mutex);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- procedure Unlock (T : Task_Id) is
- Result : int;
- begin
- if not Single_Lock then
- Result := semGive (T.Common.LL.L.Mutex);
- pragma Assert (Result = 0);
- end if;
- end Unlock;
-
- -----------------
- -- Set_Ceiling --
- -----------------
-
- -- Dynamic priority ceilings are not supported by the underlying system
-
- procedure Set_Ceiling
- (L : not null access Lock;
- Prio : System.Any_Priority)
- is
- pragma Unreferenced (L, Prio);
- begin
- null;
- end Set_Ceiling;
-
- -----------
- -- Sleep --
- -----------
-
- procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
- pragma Unreferenced (Reason);
-
- Result : int;
-
- begin
- pragma Assert (Self_ID = Self);
-
- -- Release the mutex before sleeping
-
- Result :=
- semGive (if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex);
- pragma Assert (Result = 0);
-
- -- Perform a blocking operation to take the CV semaphore. Note that a
- -- blocking operation in VxWorks will reenable task scheduling. When we
- -- are no longer blocked and control is returned, task scheduling will
- -- again be disabled.
-
- Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER);
- pragma Assert (Result = 0);
-
- -- Take the mutex back
-
- Result :=
- semTake ((if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
- pragma Assert (Result = 0);
- end Sleep;
-
- -----------------
- -- Timed_Sleep --
- -----------------
-
- -- This is for use within the run-time system, so abort is assumed to be
- -- already deferred, and the caller should be holding its own ATCB lock.
-
- procedure Timed_Sleep
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes;
- Reason : System.Tasking.Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- pragma Unreferenced (Reason);
-
- Orig : constant Duration := Monotonic_Clock;
- Absolute : Duration;
- Ticks : int;
- Result : int;
- Wakeup : Boolean := False;
-
- begin
- Timedout := False;
- Yielded := True;
-
- if Mode = Relative then
- Absolute := Orig + Time;
-
- -- Systematically add one since the first tick will delay *at most*
- -- 1 / Rate_Duration seconds, so we need to add one to be on the
- -- safe side.
-
- Ticks := To_Clock_Ticks (Time);
-
- if Ticks > 0 and then Ticks < int'Last then
- Ticks := Ticks + 1;
- end if;
-
- else
- Absolute := Time;
- Ticks := To_Clock_Ticks (Time - Monotonic_Clock);
- end if;
-
- if Ticks > 0 then
- loop
- -- Release the mutex before sleeping
-
- Result :=
- semGive (if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex);
- pragma Assert (Result = 0);
-
- -- Perform a blocking operation to take the CV semaphore. Note
- -- that a blocking operation in VxWorks will reenable task
- -- scheduling. When we are no longer blocked and control is
- -- returned, task scheduling will again be disabled.
-
- Result := semTake (Self_ID.Common.LL.CV, Ticks);
-
- if Result = 0 then
-
- -- Somebody may have called Wakeup for us
-
- Wakeup := True;
-
- else
- if errno /= S_objLib_OBJ_TIMEOUT then
- Wakeup := True;
-
- else
- -- If Ticks = int'last, it was most probably truncated so
- -- let's make another round after recomputing Ticks from
- -- the absolute time.
-
- if Ticks /= int'Last then
- Timedout := True;
-
- else
- Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
-
- if Ticks < 0 then
- Timedout := True;
- end if;
- end if;
- end if;
- end if;
-
- -- Take the mutex back
-
- Result :=
- semTake ((if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
- pragma Assert (Result = 0);
-
- exit when Timedout or Wakeup;
- end loop;
-
- else
- Timedout := True;
-
- -- Should never hold a lock while yielding
-
- if Single_Lock then
- Result := semGive (Single_RTS_Lock.Mutex);
- Result := taskDelay (0);
- Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
-
- else
- Result := semGive (Self_ID.Common.LL.L.Mutex);
- Result := taskDelay (0);
- Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
- end if;
- end if;
- end Timed_Sleep;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- -- This is for use in implementing delay statements, so we assume the
- -- caller is holding no locks.
-
- procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Orig : constant Duration := Monotonic_Clock;
- Absolute : Duration;
- Ticks : int;
- Timedout : Boolean;
- Aborted : Boolean := False;
-
- Result : int;
- pragma Warnings (Off, Result);
-
- begin
- if Mode = Relative then
- Absolute := Orig + Time;
- Ticks := To_Clock_Ticks (Time);
-
- if Ticks > 0 and then Ticks < int'Last then
-
- -- First tick will delay anytime between 0 and 1 / sysClkRateGet
- -- seconds, so we need to add one to be on the safe side.
-
- Ticks := Ticks + 1;
- end if;
-
- else
- Absolute := Time;
- Ticks := To_Clock_Ticks (Time - Orig);
- end if;
-
- if Ticks > 0 then
-
- -- Modifying State, locking the TCB
-
- Result :=
- semTake ((if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
-
- pragma Assert (Result = 0);
-
- Self_ID.Common.State := Delay_Sleep;
- Timedout := False;
-
- loop
- Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-
- -- Release the TCB before sleeping
-
- Result :=
- semGive (if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex);
- pragma Assert (Result = 0);
-
- exit when Aborted;
-
- Result := semTake (Self_ID.Common.LL.CV, Ticks);
-
- if Result /= 0 then
-
- -- If Ticks = int'last, it was most probably truncated, so make
- -- another round after recomputing Ticks from absolute time.
-
- if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then
- Timedout := True;
- else
- Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
-
- if Ticks < 0 then
- Timedout := True;
- end if;
- end if;
- end if;
-
- -- Take back the lock after having slept, to protect further
- -- access to Self_ID.
-
- Result :=
- semTake
- ((if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex), WAIT_FOREVER);
-
- pragma Assert (Result = 0);
-
- exit when Timedout;
- end loop;
-
- Self_ID.Common.State := Runnable;
-
- Result :=
- semGive
- (if Single_Lock
- then Single_RTS_Lock.Mutex
- else Self_ID.Common.LL.L.Mutex);
-
- else
- Result := taskDelay (0);
- end if;
- end Timed_Delay;
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- function Monotonic_Clock return Duration is
- TS : aliased timespec;
- Result : int;
- begin
- Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
- pragma Assert (Result = 0);
- return To_Duration (TS);
- end Monotonic_Clock;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- begin
- return 1.0 / Duration (sysClkRateGet);
- end RT_Resolution;
-
- ------------
- -- Wakeup --
- ------------
-
- procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
- pragma Unreferenced (Reason);
- Result : int;
- begin
- Result := semGive (T.Common.LL.CV);
- pragma Assert (Result = 0);
- end Wakeup;
-
- -----------
- -- Yield --
- -----------
-
- procedure Yield (Do_Yield : Boolean := True) is
- pragma Unreferenced (Do_Yield);
- Result : int;
- pragma Unreferenced (Result);
- begin
- Result := taskDelay (0);
- end Yield;
-
- ------------------
- -- Set_Priority --
- ------------------
-
- procedure Set_Priority
- (T : Task_Id;
- Prio : System.Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- pragma Unreferenced (Loss_Of_Inheritance);
-
- Result : int;
-
- begin
- Result :=
- taskPrioritySet
- (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio)));
- pragma Assert (Result = 0);
-
- -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of
- -- the priority queue instead of the head. This is not the behavior
- -- required by Annex D (RM D.2.3(5/2)), but we consider it an acceptable
- -- variation (RM 1.1.3(6)), given this is the built-in behavior of the
- -- operating system. VxWorks versions starting from 6.7 implement the
- -- required Annex D semantics.
-
- -- In older versions we attempted to better approximate the Annex D
- -- required behavior, but this simulation was not entirely accurate,
- -- and it seems better to live with the standard VxWorks semantics.
-
- T.Common.Current_Priority := Prio;
- end Set_Priority;
-
- ------------------
- -- Get_Priority --
- ------------------
-
- function Get_Priority (T : Task_Id) return System.Any_Priority is
- begin
- return T.Common.Current_Priority;
- end Get_Priority;
-
- ----------------
- -- Enter_Task --
- ----------------
-
- procedure Enter_Task (Self_ID : Task_Id) is
- begin
- -- Store the user-level task id in the Thread field (to be used
- -- internally by the run-time system) and the kernel-level task id in
- -- the LWP field (to be used by the debugger).
-
- Self_ID.Common.LL.Thread := taskIdSelf;
- Self_ID.Common.LL.LWP := getpid;
-
- Specific.Set (Self_ID);
-
- -- Properly initializes the FPU for PPC/MIPS systems
-
- System.Float_Control.Reset;
-
- -- Install the signal handlers
-
- -- This is called for each task since there is no signal inheritance
- -- between VxWorks tasks.
-
- Install_Signal_Handlers;
-
- -- If stack checking is enabled, set the stack limit for this task
-
- if Set_Stack_Limit_Hook /= null then
- Set_Stack_Limit_Hook.all;
- end if;
- end Enter_Task;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
-
- -----------------------------
- -- Register_Foreign_Thread --
- -----------------------------
-
- function Register_Foreign_Thread return Task_Id is
- begin
- if Is_Valid_Task then
- return Self;
- else
- return Register_Foreign_Thread (taskIdSelf);
- end if;
- end Register_Foreign_Thread;
-
- --------------------
- -- Initialize_TCB --
- --------------------
-
- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- begin
- Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
- Self_ID.Common.LL.Thread := Null_Thread_Id;
-
- if Self_ID.Common.LL.CV = 0 then
- Succeeded := False;
-
- else
- Succeeded := True;
-
- if not Single_Lock then
- Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
- end if;
- end if;
- end Initialize_TCB;
-
- -----------------
- -- Create_Task --
- -----------------
-
- procedure Create_Task
- (T : Task_Id;
- Wrapper : System.Address;
- Stack_Size : System.Parameters.Size_Type;
- Priority : System.Any_Priority;
- Succeeded : out Boolean)
- is
- Adjusted_Stack_Size : size_t;
-
- use type System.Multiprocessors.CPU_Range;
-
- begin
- -- Check whether both Dispatching_Domain and CPU are specified for
- -- the task, and the CPU value is not contained within the range of
- -- processors for the domain.
-
- if T.Common.Domain /= null
- and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
- and then
- (T.Common.Base_CPU not in T.Common.Domain'Range
- or else not T.Common.Domain (T.Common.Base_CPU))
- then
- Succeeded := False;
- return;
- end if;
-
- -- Ask for four extra bytes of stack space so that the ATCB pointer can
- -- be stored below the stack limit, plus extra space for the frame of
- -- Task_Wrapper. This is so the user gets the amount of stack requested
- -- exclusive of the needs.
-
- -- We also have to allocate n more bytes for the task name storage and
- -- enough space for the Wind Task Control Block which is around 0x778
- -- bytes. VxWorks also seems to carve out additional space, so use 2048
- -- as a nice round number. We might want to increment to the nearest
- -- page size in case we ever support VxVMI.
-
- -- ??? - we should come back and visit this so we can set the task name
- -- to something appropriate.
-
- Adjusted_Stack_Size := size_t (Stack_Size) + 2048;
-
- -- Since the initial signal mask of a thread is inherited from the
- -- creator, and the Environment task has all its signals masked, we do
- -- not need to manipulate caller's signal mask at this point. All tasks
- -- in RTS will have All_Tasks_Mask initially.
-
- -- We now compute the VxWorks task name and options, then spawn ...
-
- declare
- Name : aliased String (1 .. T.Common.Task_Image_Len + 1);
- Name_Address : System.Address;
- -- Task name we are going to hand down to VxWorks
-
- function Get_Task_Options return int;
- pragma Import (C, Get_Task_Options, "__gnat_get_task_options");
- -- Function that returns the options to be set for the task that we
- -- are creating. We fetch the options assigned to the current task,
- -- so offering some user level control over the options for a task
- -- hierarchy, and force VX_FP_TASK because it is almost always
- -- required.
-
- begin
- -- If there is no Ada task name handy, let VxWorks choose one.
- -- Otherwise, tell VxWorks what the Ada task name is.
-
- if T.Common.Task_Image_Len = 0 then
- Name_Address := System.Null_Address;
- else
- Name (1 .. Name'Last - 1) :=
- T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
- Name (Name'Last) := ASCII.NUL;
- Name_Address := Name'Address;
- end if;
-
- -- Now spawn the VxWorks task for real
-
- T.Common.LL.Thread :=
- taskSpawn
- (Name_Address,
- To_VxWorks_Priority (int (Priority)),
- Get_Task_Options,
- Adjusted_Stack_Size,
- Wrapper,
- To_Address (T));
- end;
-
- -- Set processor affinity
-
- Set_Task_Affinity (T);
-
- -- Only case of failure is if taskSpawn returned 0 (aka Null_Thread_Id)
-
- if T.Common.LL.Thread = Null_Thread_Id then
- Succeeded := False;
- else
- Succeeded := True;
- Task_Creation_Hook (T.Common.LL.Thread);
- Set_Priority (T, Priority);
- end if;
- end Create_Task;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_Id) is
- Result : int;
-
- begin
- if not Single_Lock then
- Result := semDelete (T.Common.LL.L.Mutex);
- pragma Assert (Result = 0);
- end if;
-
- T.Common.LL.Thread := Null_Thread_Id;
-
- Result := semDelete (T.Common.LL.CV);
- pragma Assert (Result = 0);
-
- if T.Known_Tasks_Index /= -1 then
- Known_Tasks (T.Known_Tasks_Index) := null;
- end if;
-
- ATCB_Allocation.Free_ATCB (T);
- end Finalize_TCB;
-
- ---------------
- -- Exit_Task --
- ---------------
-
- procedure Exit_Task is
- begin
- Specific.Set (null);
- end Exit_Task;
-
- ----------------
- -- Abort_Task --
- ----------------
-
- procedure Abort_Task (T : Task_Id) is
- Result : int;
- begin
- Result :=
- kill
- (T.Common.LL.Thread,
- Signal (Interrupt_Management.Abort_Task_Interrupt));
- pragma Assert (Result = 0);
- end Abort_Task;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (S : in out Suspension_Object) is
- begin
- -- Initialize internal state (always to False (RM D.10(6)))
-
- S.State := False;
- S.Waiting := False;
-
- -- Initialize internal mutex
-
- -- Use simpler binary semaphore instead of VxWorks mutual exclusion
- -- semaphore, because we don't need the fancier semantics and their
- -- overhead.
-
- S.L := semBCreate (SEM_Q_FIFO, SEM_FULL);
-
- -- Initialize internal condition variable
-
- S.CV := semBCreate (SEM_Q_FIFO, SEM_EMPTY);
- end Initialize;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (S : in out Suspension_Object) is
- pragma Unmodified (S);
- -- S may be modified on other targets, but not on VxWorks
-
- Result : STATUS;
-
- begin
- -- Destroy internal mutex
-
- Result := semDelete (S.L);
- pragma Assert (Result = OK);
-
- -- Destroy internal condition variable
-
- Result := semDelete (S.CV);
- pragma Assert (Result = OK);
- end Finalize;
-
- -------------------
- -- Current_State --
- -------------------
-
- function Current_State (S : Suspension_Object) return Boolean is
- begin
- -- We do not want to use lock on this read operation. State is marked
- -- as Atomic so that we ensure that the value retrieved is correct.
-
- return S.State;
- end Current_State;
-
- ---------------
- -- Set_False --
- ---------------
-
- procedure Set_False (S : in out Suspension_Object) is
- Result : STATUS;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := semTake (S.L, WAIT_FOREVER);
- pragma Assert (Result = OK);
-
- S.State := False;
-
- Result := semGive (S.L);
- pragma Assert (Result = OK);
-
- SSL.Abort_Undefer.all;
- end Set_False;
-
- --------------
- -- Set_True --
- --------------
-
- procedure Set_True (S : in out Suspension_Object) is
- Result : STATUS;
-
- begin
- -- Set_True can be called from an interrupt context, in which case
- -- Abort_Defer is undefined.
-
- if Is_Task_Context then
- SSL.Abort_Defer.all;
- end if;
-
- Result := semTake (S.L, WAIT_FOREVER);
- pragma Assert (Result = OK);
-
- -- If there is already a task waiting on this suspension object then we
- -- resume it, leaving the state of the suspension object to False, as it
- -- is specified in (RM D.10 (9)). Otherwise, it just leaves the state to
- -- True.
-
- if S.Waiting then
- S.Waiting := False;
- S.State := False;
-
- Result := semGive (S.CV);
- pragma Assert (Result = OK);
- else
- S.State := True;
- end if;
-
- Result := semGive (S.L);
- pragma Assert (Result = OK);
-
- -- Set_True can be called from an interrupt context, in which case
- -- Abort_Undefer is undefined.
-
- if Is_Task_Context then
- SSL.Abort_Undefer.all;
- end if;
-
- end Set_True;
-
- ------------------------
- -- Suspend_Until_True --
- ------------------------
-
- procedure Suspend_Until_True (S : in out Suspension_Object) is
- Result : STATUS;
-
- begin
- SSL.Abort_Defer.all;
-
- Result := semTake (S.L, WAIT_FOREVER);
-
- if S.Waiting then
-
- -- Program_Error must be raised upon calling Suspend_Until_True
- -- if another task is already waiting on that suspension object
- -- (RM D.10(10)).
-
- Result := semGive (S.L);
- pragma Assert (Result = OK);
-
- SSL.Abort_Undefer.all;
-
- raise Program_Error;
-
- else
- -- Suspend the task if the state is False. Otherwise, the task
- -- continues its execution, and the state of the suspension object
- -- is set to False (RM D.10 (9)).
-
- if S.State then
- S.State := False;
-
- Result := semGive (S.L);
- pragma Assert (Result = 0);
-
- SSL.Abort_Undefer.all;
-
- else
- S.Waiting := True;
-
- -- Release the mutex before sleeping
-
- Result := semGive (S.L);
- pragma Assert (Result = OK);
-
- SSL.Abort_Undefer.all;
-
- Result := semTake (S.CV, WAIT_FOREVER);
- pragma Assert (Result = 0);
- end if;
- end if;
- end Suspend_Until_True;
-
- ----------------
- -- Check_Exit --
- ----------------
-
- -- Dummy version
-
- function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
- pragma Unreferenced (Self_ID);
- begin
- return True;
- end Check_Exit;
-
- --------------------
- -- Check_No_Locks --
- --------------------
-
- function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
- pragma Unreferenced (Self_ID);
- begin
- return True;
- end Check_No_Locks;
-
- ----------------------
- -- Environment_Task --
- ----------------------
-
- function Environment_Task return Task_Id is
- begin
- return Environment_Task_Id;
- end Environment_Task;
-
- --------------
- -- Lock_RTS --
- --------------
-
- procedure Lock_RTS is
- begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
- end Lock_RTS;
-
- ----------------
- -- Unlock_RTS --
- ----------------
-
- procedure Unlock_RTS is
- begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
- end Unlock_RTS;
-
- ------------------
- -- Suspend_Task --
- ------------------
-
- function Suspend_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- begin
- if T.Common.LL.Thread /= Null_Thread_Id
- and then T.Common.LL.Thread /= Thread_Self
- then
- return taskSuspend (T.Common.LL.Thread) = 0;
- else
- return True;
- end if;
- end Suspend_Task;
-
- -----------------
- -- Resume_Task --
- -----------------
-
- function Resume_Task
- (T : ST.Task_Id;
- Thread_Self : Thread_Id) return Boolean
- is
- begin
- if T.Common.LL.Thread /= Null_Thread_Id
- and then T.Common.LL.Thread /= Thread_Self
- then
- return taskResume (T.Common.LL.Thread) = 0;
- else
- return True;
- end if;
- end Resume_Task;
-
- --------------------
- -- Stop_All_Tasks --
- --------------------
-
- procedure Stop_All_Tasks
- is
- Thread_Self : constant Thread_Id := taskIdSelf;
- C : Task_Id;
-
- Dummy : int;
- Old : int;
-
- begin
- Old := Int_Lock;
-
- C := All_Tasks_List;
- while C /= null loop
- if C.Common.LL.Thread /= Null_Thread_Id
- and then C.Common.LL.Thread /= Thread_Self
- then
- Dummy := Task_Stop (C.Common.LL.Thread);
- end if;
-
- C := C.Common.All_Tasks_Link;
- end loop;
-
- Dummy := Int_Unlock (Old);
- end Stop_All_Tasks;
-
- ---------------
- -- Stop_Task --
- ---------------
-
- function Stop_Task (T : ST.Task_Id) return Boolean is
- begin
- if T.Common.LL.Thread /= Null_Thread_Id then
- return Task_Stop (T.Common.LL.Thread) = 0;
- else
- return True;
- end if;
- end Stop_Task;
-
- -------------------
- -- Continue_Task --
- -------------------
-
- function Continue_Task (T : ST.Task_Id) return Boolean
- is
- begin
- if T.Common.LL.Thread /= Null_Thread_Id then
- return Task_Cont (T.Common.LL.Thread) = 0;
- else
- return True;
- end if;
- end Continue_Task;
-
- ---------------------
- -- Is_Task_Context --
- ---------------------
-
- function Is_Task_Context return Boolean is
- begin
- return System.OS_Interface.Interrupt_Context /= 1;
- end Is_Task_Context;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- Result : int;
- pragma Unreferenced (Result);
-
- begin
- Environment_Task_Id := Environment_Task;
-
- Interrupt_Management.Initialize;
- Specific.Initialize;
-
- if Locking_Policy = 'C' then
- Mutex_Protocol := Prio_Protect;
- elsif Locking_Policy = 'I' then
- Mutex_Protocol := Prio_Inherit;
- else
- Mutex_Protocol := Prio_None;
- end if;
-
- if Time_Slice_Val > 0 then
- Result :=
- Set_Time_Slice
- (To_Clock_Ticks
- (Duration (Time_Slice_Val) / Duration (1_000_000.0)));
-
- elsif Dispatching_Policy = 'R' then
- Result := Set_Time_Slice (To_Clock_Ticks (0.01));
-
- end if;
-
- -- Initialize the lock used to synchronize chain of all ATCBs
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- -- Make environment task known here because it doesn't go through
- -- Activate_Tasks, which does it for all other tasks.
-
- Known_Tasks (Known_Tasks'First) := Environment_Task;
- Environment_Task.Known_Tasks_Index := Known_Tasks'First;
-
- Enter_Task (Environment_Task);
-
- -- Set processor affinity
-
- Set_Task_Affinity (Environment_Task);
- end Initialize;
-
- -----------------------
- -- Set_Task_Affinity --
- -----------------------
-
- procedure Set_Task_Affinity (T : ST.Task_Id) is
- Result : int := 0;
- pragma Unreferenced (Result);
-
- use System.Task_Info;
- use type System.Multiprocessors.CPU_Range;
-
- begin
- -- Do nothing if the underlying thread has not yet been created. If the
- -- thread has not yet been created then the proper affinity will be set
- -- during its creation.
-
- if T.Common.LL.Thread = Null_Thread_Id then
- null;
-
- -- pragma CPU
-
- elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
-
- -- Ada 2012 pragma CPU uses CPU numbers starting from 1, while on
- -- VxWorks the first CPU is identified by a 0, so we need to adjust.
-
- Result :=
- taskCpuAffinitySet
- (T.Common.LL.Thread, int (T.Common.Base_CPU) - 1);
-
- -- Task_Info
-
- elsif T.Common.Task_Info /= Unspecified_Task_Info then
- Result := taskCpuAffinitySet (T.Common.LL.Thread, T.Common.Task_Info);
-
- -- Handle dispatching domains
-
- elsif T.Common.Domain /= null
- and then (T.Common.Domain /= ST.System_Domain
- or else T.Common.Domain.all /=
- (Multiprocessors.CPU'First ..
- Multiprocessors.Number_Of_CPUs => True))
- then
- declare
- CPU_Set : unsigned := 0;
-
- begin
- -- Set the affinity to all the processors belonging to the
- -- dispatching domain.
-
- for Proc in T.Common.Domain'Range loop
- if T.Common.Domain (Proc) then
-
- -- The thread affinity mask is a bit vector in which each
- -- bit represents a logical processor.
-
- CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1);
- end if;
- end loop;
-
- Result := taskMaskAffinitySet (T.Common.LL.Thread, CPU_Set);
- end;
- end if;
- end Set_Task_Affinity;
-
-end System.Task_Primitives.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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: <none>");
- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- B o d y --
--- --
--- Copyright (C) 2009, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the GNU/Linux version of this module
-
-package body System.Task_Info is
-
- N_CPU : Natural := 0;
- pragma Atomic (N_CPU);
- -- Cache CPU number. Use pragma Atomic to avoid a race condition when
- -- setting N_CPU in Number_Of_Processors below.
-
- --------------------------
- -- Number_Of_Processors --
- --------------------------
-
- function Number_Of_Processors return Positive is
- begin
- if N_CPU = 0 then
- N_CPU := Natural
- (OS_Interface.sysconf (OS_Interface.SC_NPROCESSORS_ONLN));
- end if;
-
- return N_CPU;
- end Number_Of_Processors;
-
-end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- S p e c --
--- --
--- Copyright (C) 2007-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the definitions and routines associated with the
--- implementation and use of the Task_Info pragma. It is specialized
--- appropriately for targets that make use of this pragma.
-
--- Note: the compiler generates direct calls to this interface, via Rtsfind.
--- Any changes to this interface may require corresponding compiler changes.
-
--- The functionality in this unit is now provided by the predefined package
--- System.Multiprocessors and the CPU aspect. This package is obsolescent.
-
--- This is the GNU/Linux version of this module
-
-with System.OS_Interface;
-
-package System.Task_Info is
- pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
- pragma Preelaborate;
- pragma Elaborate_Body;
- -- To ensure that a body is allowed
-
- -- The Linux kernel provides a way to define the ideal processor to use for
- -- a given thread. The ideal processor is not necessarily the one that will
- -- be used by the OS but the OS will always try to schedule this thread to
- -- the specified processor if it is available.
-
- -- The Task_Info pragma:
-
- -- pragma Task_Info (EXPRESSION);
-
- -- allows the specification on a task by task basis of a value of type
- -- System.Task_Info.Task_Info_Type to be passed to a task when it is
- -- created. The specification of this type, and the effect on the task
- -- that is created is target dependent.
-
- -- The Task_Info pragma appears within a task definition (compare the
- -- definition and implementation of pragma Priority). If no such pragma
- -- appears, then the value Unspecified_Task_Info is passed. If a pragma
- -- is present, then it supplies an alternative value. If the argument of
- -- the pragma is a discriminant reference, then the value can be set on
- -- a task by task basis by supplying the appropriate discriminant value.
-
- -- Note that this means that the type used for Task_Info_Type must be
- -- suitable for use as a discriminant (i.e. a scalar or access type).
-
- -----------------------
- -- Thread Attributes --
- -----------------------
-
- subtype CPU_Set is System.OS_Interface.cpu_set_t;
-
- Any_CPU : constant CPU_Set := (bits => (others => True));
- No_CPU : constant CPU_Set := (bits => (others => False));
-
- Invalid_CPU_Number : exception;
- -- Raised when an invalid CPU mask has been specified
- -- i.e. An empty CPU set
-
- type Thread_Attributes is record
- CPU_Affinity : aliased CPU_Set := Any_CPU;
- end record;
-
- Default_Thread_Attributes : constant Thread_Attributes := (others => <>);
-
- type Task_Info_Type is access all Thread_Attributes;
-
- Unspecified_Task_Info : constant Task_Info_Type := null;
-
- function Number_Of_Processors return Positive;
- -- Returns the number of processors on the running host
-
-end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- B o d y --
--- --
--- Copyright (C) 2007-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Windows (native) version of this module
-
-with System.OS_Interface;
-pragma Unreferenced (System.OS_Interface);
--- System.OS_Interface is not used today, but the protocol between the
--- run-time and the binder is that any tasking application uses
--- System.OS_Interface, so notify the binder with this "with" clause.
-
-package body System.Task_Info is
-
- N_CPU : Natural := 0;
- pragma Atomic (N_CPU);
- -- Cache CPU number. Use pragma Atomic to avoid a race condition when
- -- setting N_CPU in Number_Of_Processors below.
-
- --------------------------
- -- Number_Of_Processors --
- --------------------------
-
- function Number_Of_Processors return Positive is
- begin
- if N_CPU = 0 then
- declare
- SI : aliased Win32.SYSTEM_INFO;
- begin
- Win32.GetSystemInfo (SI'Access);
- N_CPU := Positive (SI.dwNumberOfProcessors);
- end;
- end if;
-
- return N_CPU;
- end Number_Of_Processors;
-
-end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- S p e c --
--- --
--- Copyright (C) 2007-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the definitions and routines associated with the
--- implementation and use of the Task_Info pragma. It is specialized
--- appropriately for targets that make use of this pragma.
-
--- Note: the compiler generates direct calls to this interface, via Rtsfind.
--- Any changes to this interface may require corresponding compiler changes.
-
--- The functionality in this unit is now provided by the predefined package
--- System.Multiprocessors and the CPU aspect. This package is obsolescent.
-
--- This is the Windows (native) version of this module
-
-with System.Win32;
-
-package System.Task_Info is
- pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
- pragma Preelaborate;
- pragma Elaborate_Body;
- -- To ensure that a body is allowed
-
- use type System.Win32.ProcessorId;
-
- -- Windows provides a way to define the ideal processor to use for a given
- -- thread. The ideal processor is not necessarily the one that will be used
- -- by the OS but the OS will always try to schedule this thread to the
- -- specified processor if it is available.
-
- -- The Task_Info pragma:
-
- -- pragma Task_Info (EXPRESSION);
-
- -- allows the specification on a task by task basis of a value of type
- -- System.Task_Info.Task_Info_Type to be passed to a task when it is
- -- created. The specification of this type, and the effect on the task
- -- that is created is target dependent.
-
- -- The Task_Info pragma appears within a task definition (compare the
- -- definition and implementation of pragma Priority). If no such pragma
- -- appears, then the value Unspecified_Task_Info is passed. If a pragma
- -- is present, then it supplies an alternative value. If the argument of
- -- the pragma is a discriminant reference, then the value can be set on
- -- a task by task basis by supplying the appropriate discriminant value.
-
- -- Note that this means that the type used for Task_Info_Type must be
- -- suitable for use as a discriminant (i.e. a scalar or access type).
-
- -----------------------
- -- Thread Attributes --
- -----------------------
-
- subtype CPU_Number is System.Win32.ProcessorId;
-
- Any_CPU : constant CPU_Number := -1;
-
- Invalid_CPU_Number : exception;
- -- Raised when an invalid CPU number has been specified
- -- i.e. CPU > Number_Of_Processors.
-
- type Thread_Attributes is record
- CPU : CPU_Number := Any_CPU;
- end record;
-
- Default_Thread_Attributes : constant Thread_Attributes := (others => <>);
-
- type Task_Info_Type is access all Thread_Attributes;
-
- Unspecified_Task_Info : constant Task_Info_Type := null;
-
- function Number_Of_Processors return Positive;
- -- Returns the number of processors on the running host
-
-end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package body contains the routines associated with the implementation
--- of the Task_Info pragma.
-
--- This is the Solaris (native) version of this module
-
-package body System.Task_Info is
-
- -----------------------------
- -- Bound_Thread_Attributes --
- -----------------------------
-
- function Bound_Thread_Attributes return Thread_Attributes is
- begin
- return (False, True);
- end Bound_Thread_Attributes;
-
- function Bound_Thread_Attributes (CPU : CPU_Number)
- return Thread_Attributes is
- begin
- return (True, True, CPU);
- end Bound_Thread_Attributes;
-
- ---------------------------------
- -- New_Bound_Thread_Attributes --
- ---------------------------------
-
- function New_Bound_Thread_Attributes return Task_Info_Type is
- begin
- return new Thread_Attributes'(False, True);
- end New_Bound_Thread_Attributes;
-
- function New_Bound_Thread_Attributes (CPU : CPU_Number)
- return Task_Info_Type is
- begin
- return new Thread_Attributes'(True, True, CPU);
- end New_Bound_Thread_Attributes;
-
- -----------------------------------
- -- New_Unbound_Thread_Attributes --
- -----------------------------------
-
- function New_Unbound_Thread_Attributes return Task_Info_Type is
- begin
- return new Thread_Attributes'(False, False);
- end New_Unbound_Thread_Attributes;
-
- -------------------------------
- -- Unbound_Thread_Attributes --
- -------------------------------
-
- function Unbound_Thread_Attributes return Thread_Attributes is
- begin
- return (False, False);
- end Unbound_Thread_Attributes;
-
-end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the definitions and routines associated with the
--- implementation and use of the Task_Info pragma. It is specialized
--- appropriately for targets that make use of this pragma.
-
--- Note: the compiler generates direct calls to this interface, via Rtsfind.
--- Any changes to this interface may require corresponding compiler changes.
-
--- The functionality in this unit is now provided by the predefined package
--- System.Multiprocessors and the CPU aspect. This package is obsolescent.
-
--- This is the Solaris (native) version of this module
-
-with System.OS_Interface;
-
-package System.Task_Info is
- pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
- pragma Preelaborate;
- pragma Elaborate_Body;
- -- To ensure that a body is allowed
-
- -----------------------------------------------------
- -- Binding of Tasks to LWPs and LWPs to processors --
- -----------------------------------------------------
-
- -- The Solaris implementation of the GNU Low-Level Interface (GNULLI)
- -- implements each Ada task as a Solaris thread. The Solaris thread
- -- library distributes threads across one or more LWPs (Light Weight
- -- Process) that are members of the same process. Solaris distributes
- -- processes and LWPs across the available CPUs on a given machine. The
- -- pragma Task_Info provides the mechanism to control the distribution
- -- of tasks to LWPs, and LWPs to processors.
-
- -- Each thread has a number of attributes that dictate it's scheduling.
- -- These attributes are:
- --
- -- New_LWP: whether a new LWP is created for this thread.
- --
- -- Bound_To_LWP: whether the thread is bound to a specific LWP
- -- for its entire lifetime.
- --
- -- CPU: the CPU number associated to the LWP
- --
-
- -- The Task_Info pragma:
-
- -- pragma Task_Info (EXPRESSION);
-
- -- allows the specification on a task by task basis of a value of type
- -- System.Task_Info.Task_Info_Type to be passed to a task when it is
- -- created. The specification of this type, and the effect on the task
- -- that is created is target dependent.
-
- -- The Task_Info pragma appears within a task definition (compare the
- -- definition and implementation of pragma Priority). If no such pragma
- -- appears, then the value Unspecified_Task_Info is passed. If a pragma
- -- is present, then it supplies an alternative value. If the argument of
- -- the pragma is a discriminant reference, then the value can be set on
- -- a task by task basis by supplying the appropriate discriminant value.
-
- -- Note that this means that the type used for Task_Info_Type must be
- -- suitable for use as a discriminant (i.e. a scalar or access type).
-
- -----------------------
- -- Thread Attributes --
- -----------------------
-
- subtype CPU_Number is System.OS_Interface.processorid_t;
-
- CPU_UNCHANGED : constant CPU_Number := System.OS_Interface.PBIND_QUERY;
- -- Do not bind the LWP to a specific processor
-
- ANY_CPU : constant CPU_Number := System.OS_Interface.PBIND_NONE;
- -- Bind the LWP to any processor
-
- Invalid_CPU_Number : exception;
-
- type Thread_Attributes (New_LWP : Boolean) is record
- Bound_To_LWP : Boolean := True;
- case New_LWP is
- when False =>
- null;
- when True =>
- CPU : CPU_Number := CPU_UNCHANGED;
- end case;
- end record;
-
- Default_Thread_Attributes : constant Thread_Attributes := (False, True);
-
- function Unbound_Thread_Attributes
- return Thread_Attributes;
-
- function Bound_Thread_Attributes
- return Thread_Attributes;
-
- function Bound_Thread_Attributes (CPU : CPU_Number)
- return Thread_Attributes;
-
- type Task_Info_Type is access all Thread_Attributes;
-
- function New_Unbound_Thread_Attributes
- return Task_Info_Type;
-
- function New_Bound_Thread_Attributes
- return Task_Info_Type;
-
- function New_Bound_Thread_Attributes (CPU : CPU_Number)
- return Task_Info_Type;
-
- Unspecified_Task_Info : constant Task_Info_Type := null;
-
-end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the definitions and routines associated with the
--- implementation and use of the Task_Info pragma. It is specialized
--- appropriately for targets that make use of this pragma.
-
--- Note: the compiler generates direct calls to this interface, via Rtsfind.
--- Any changes to this interface may require corresponding compiler changes.
-
--- The functionality in this unit is now provided by the predefined package
--- System.Multiprocessors and the CPU aspect. This package is obsolescent.
-
--- This is the VxWorks version of this package
-
-with Interfaces.C;
-
-package System.Task_Info is
- pragma Obsolescent (Task_Info, "use System.Multiprocessors and CPU aspect");
- pragma Preelaborate;
- pragma Elaborate_Body;
- -- To ensure that a body is allowed
-
- -----------------------------------------
- -- Implementation of Task_Info Feature --
- -----------------------------------------
-
- -- The Task_Info pragma:
-
- -- pragma Task_Info (EXPRESSION);
-
- -- allows the specification on a task by task basis of a value of type
- -- System.Task_Info.Task_Info_Type to be passed to a task when it is
- -- created. The specification of this type, and the effect on the task
- -- that is created is target dependent.
-
- -- The Task_Info pragma appears within a task definition (compare the
- -- definition and implementation of pragma Priority). If no such pragma
- -- appears, then the value Unspecified_Task_Info is passed. If a pragma
- -- is present, then it supplies an alternative value. If the argument of
- -- the pragma is a discriminant reference, then the value can be set on
- -- a task by task basis by supplying the appropriate discriminant value.
-
- -- Note that this means that the type used for Task_Info_Type must be
- -- suitable for use as a discriminant (i.e. a scalar or access type).
-
- ------------------
- -- Declarations --
- ------------------
-
- subtype Task_Info_Type is Interfaces.C.int;
- -- This is a CPU number (natural - CPUs are 0-indexed on VxWorks)
-
- use type Interfaces.C.int;
-
- Unspecified_Task_Info : constant Task_Info_Type := -1;
- -- Value passed to task in the absence of a Task_Info pragma
- -- This value means do not try to set the CPU affinity
-
-end System.Task_Info;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- B o d y --
--- (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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T A S K _ I N F O --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the definitions and routines associated with the
--- implementation and use of the Task_Info pragma. It is specialized
--- appropriately for targets that make use of this pragma.
-
--- Note: the compiler generates direct calls to this interface, via Rtsfind.
--- Any changes to this interface may require corresponding compiler changes.
-
--- The functionality in this unit is now provided by the predefined package
--- System.Multiprocessors and the CPU aspect. This package is obsolescent.
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a no tasking version of this package
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is new Integer;
-
- type RTS_Lock is new Integer;
-
- type Suspension_Object is new Integer;
-
- type Task_Body_Access is access procedure;
-
- type Private_Data is limited record
- Thread : aliased Integer;
- CV : aliased Integer;
- L : aliased RTS_Lock;
- end record;
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a HP-UX version of this package
-
--- This package provides low-level support for most tasking features
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with System.OS_Interface;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- -- Should be used for implementation of protected objects
-
- type RTS_Lock is limited private;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the later one serves only as a semaphore so
- -- that do not check for ceiling violations.
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper
- -- declared local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
-private
- type Lock is record
- L : aliased System.OS_Interface.pthread_mutex_t;
- Priority : Integer;
- Owner_Priority : Integer;
- end record;
-
- type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased System.OS_Interface.pthread_mutex_t;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- type Private_Data is record
- Thread : aliased System.OS_Interface.pthread_t;
- -- pragma Atomic (Thread);
- -- Unfortunately, the above fails because Thread is 64 bits.
-
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the
- -- same value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they
- -- are updated in atomic fashion.
-
- CV : aliased System.OS_Interface.pthread_cond_t;
-
- L : aliased RTS_Lock;
- -- Protection for all components is lock L
- end record;
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a NT (native) version of this package
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with System.OS_Interface;
-with System.Win32;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- -- Should be used for implementation of protected objects
-
- type RTS_Lock is limited private;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the later one serves only as a semaphore so
- -- that do not check for ceiling violations.
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper
- -- declared local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
-private
-
- type Lock is record
- Mutex : aliased System.OS_Interface.CRITICAL_SECTION;
- Priority : Integer;
- Owner_Priority : Integer;
- end record;
-
- type Condition_Variable is new System.Win32.HANDLE;
-
- type RTS_Lock is new System.OS_Interface.CRITICAL_SECTION;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased System.OS_Interface.CRITICAL_SECTION;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased Win32.HANDLE;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- type Private_Data is limited record
- Thread : aliased Win32.HANDLE;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb).
- -- They put the same value (thr_self value). We do not want to
- -- use lock on those operations and the only thing we have to
- -- make sure is that they are updated in atomic fashion.
-
- Thread_Id : aliased Win32.DWORD;
- -- Used to provide a better tasking support in gdb
-
- CV : aliased Condition_Variable;
- -- Condition Variable used to implement Sleep/Wakeup
-
- L : aliased RTS_Lock;
- -- Protection for all components is lock L
- end record;
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a POSIX-like version of this package where no alternate stack
--- is needed for stack checking.
-
--- Note: this file can only be used for POSIX compliant systems
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with System.OS_Interface;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- -- Should be used for implementation of protected objects
-
- type RTS_Lock is limited private;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the later one serves only as a semaphore so
- -- that do not check for ceiling violations.
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper declared
- -- local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
-private
-
- type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
-
- type Lock is record
- WO : aliased RTS_Lock;
- RW : aliased System.OS_Interface.pthread_rwlock_t;
- end record;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased RTS_Lock;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- type Private_Data is limited record
- Thread : aliased System.OS_Interface.pthread_t;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
- -- value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they are
- -- updated in atomic fashion.
-
- LWP : aliased System.Address;
- -- The purpose of this field is to provide a better tasking support on
- -- gdb. The order of the two first fields (Thread and LWP) is important.
- -- On targets where lwp is not relevant, this is equivalent to Thread.
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Should be commented ??? (in all versions of taspri)
-
- L : aliased RTS_Lock;
- -- Protection for all components is lock L
- end record;
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a POSIX-like version of this package
-
--- Note: this file can only be used for POSIX compliant systems
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with System.OS_Interface;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- -- Should be used for implementation of protected objects
-
- type RTS_Lock is limited private;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the latter serves only as a semaphore so that
- -- we do not check for ceiling violations.
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper declared
- -- local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := System.OS_Interface.Alternate_Stack_Size;
- -- Import value from System.OS_Interface
-
-private
-
- type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
-
- type Lock is record
- RW : aliased System.OS_Interface.pthread_rwlock_t;
- WO : aliased RTS_Lock;
- end record;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased RTS_Lock;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- type Private_Data is limited record
- Thread : aliased System.OS_Interface.pthread_t;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
- -- value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they are
- -- updated in atomic fashion.
-
- LWP : aliased System.Address;
- -- The purpose of this field is to provide a better tasking support on
- -- gdb. The order of the two first fields (Thread and LWP) is important.
- -- On targets where lwp is not relevant, this is equivalent to Thread.
-
- CV : aliased System.OS_Interface.pthread_cond_t;
- -- Should be commented ??? (in all versions of taspri)
-
- L : aliased RTS_Lock;
- -- Protection for all components is lock L
- end record;
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a Solaris version of this package
-
--- This package provides low-level support for most tasking features
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with Ada.Unchecked_Conversion;
-
-with System.OS_Interface;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- type Lock_Ptr is access all Lock;
- -- Should be used for implementation of protected objects
-
- type RTS_Lock is limited private;
- type RTS_Lock_Ptr is access all RTS_Lock;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the later one serves only as a semaphore so
- -- that do not check for ceiling violations.
-
- function To_Lock_Ptr is
- new Ada.Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr);
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper
- -- declared local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
-private
-
- type Private_Task_Serial_Number is mod 2 ** Long_Long_Integer'Size;
- -- Used to give each task a unique serial number
-
- type Base_Lock is new System.OS_Interface.mutex_t;
-
- type Owner_Int is new Integer;
- for Owner_Int'Alignment use Standard'Maximum_Alignment;
-
- type Owner_ID is access all Owner_Int;
-
- function To_Owner_ID is
- new Ada.Unchecked_Conversion (System.Address, Owner_ID);
-
- type Lock is record
- L : aliased Base_Lock;
- Ceiling : System.Any_Priority := System.Any_Priority'First;
- Saved_Priority : System.Any_Priority := System.Any_Priority'First;
- Owner : Owner_ID;
- Next : Lock_Ptr;
- Level : Private_Task_Serial_Number := 0;
- Buddy : Owner_ID;
- Frozen : Boolean := False;
- end record;
-
- type RTS_Lock is new Lock;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased System.OS_Interface.mutex_t;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased System.OS_Interface.cond_t;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- -- Note that task support on gdb relies on the fact that the first two
- -- fields of Private_Data are Thread and LWP.
-
- type Private_Data is limited record
- Thread : aliased System.OS_Interface.thread_t;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the same
- -- value (thr_self value). We do not want to use lock on those
- -- operations and the only thing we have to make sure is that they are
- -- updated in atomic fashion.
-
- LWP : System.OS_Interface.lwpid_t;
- -- The LWP id of the thread. Set by self in Enter_Task
-
- CV : aliased System.OS_Interface.cond_t;
- L : aliased RTS_Lock;
- -- Protection for all components is lock L
-
- Active_Priority : System.Any_Priority := System.Any_Priority'First;
- -- Simulated active priority, used iff Priority_Ceiling_Support is True
-
- Locking : Lock_Ptr;
- Locks : Lock_Ptr;
- Wakeups : Natural := 0;
- end record;
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a VxWorks version of this package
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during tasking
--- operations. It causes infinite loops and other problems.
-
-with System.OS_Interface;
-
-package System.Task_Primitives is
- pragma Preelaborate;
-
- type Lock is limited private;
- -- Should be used for implementation of protected objects
-
- type RTS_Lock is limited private;
- -- Should be used inside the runtime system. The difference between Lock
- -- and the RTS_Lock is that the later one serves only as a semaphore so
- -- that do not check for ceiling violations.
-
- type Suspension_Object is limited private;
- -- Should be used for the implementation of Ada.Synchronous_Task_Control
-
- type Task_Body_Access is access procedure;
- -- Pointer to the task body's entry point (or possibly a wrapper
- -- declared local to the GNARL).
-
- type Private_Data is limited private;
- -- Any information that the GNULLI needs maintained on a per-task basis.
- -- A component of this type is guaranteed to be included in the
- -- Ada_Task_Control_Block.
-
- subtype Task_Address is System.Address;
- Task_Address_Size : constant := Standard'Address_Size;
- -- Type used for task addresses and its size
-
- Alternate_Stack_Size : constant := 0;
- -- No alternate signal stack is used on this platform
-
-private
-
- type Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit);
-
- type Lock is record
- Mutex : System.OS_Interface.SEM_ID;
- Protocol : Priority_Type;
-
- Prio_Ceiling : System.OS_Interface.int;
- -- Priority ceiling of lock
- end record;
-
- type RTS_Lock is new Lock;
-
- type Suspension_Object is record
- State : Boolean;
- pragma Atomic (State);
- -- Boolean that indicates whether the object is open. This field is
- -- marked Atomic to ensure that we can read its value without locking
- -- the access to the Suspension_Object.
-
- Waiting : Boolean;
- -- Flag showing if there is a task already suspended on this object
-
- L : aliased System.OS_Interface.SEM_ID;
- -- Protection for ensuring mutual exclusion on the Suspension_Object
-
- CV : aliased System.OS_Interface.SEM_ID;
- -- Condition variable used to queue threads until condition is signaled
- end record;
-
- type Private_Data is limited record
- Thread : aliased System.OS_Interface.t_id := 0;
- pragma Atomic (Thread);
- -- Thread field may be updated by two different threads of control.
- -- (See, Enter_Task and Create_Task in s-taprop.adb).
- -- They put the same value (thr_self value). We do not want to
- -- use lock on those operations and the only thing we have to
- -- make sure is that they are updated in atomic fashion.
-
- LWP : aliased System.OS_Interface.t_id := 0;
- -- The purpose of this field is to provide a better tasking support on
- -- gdb. The order of the two first fields (Thread and LWP) is important.
- -- On targets where lwp is not relevant, this is equivalent to Thread.
-
- CV : aliased System.OS_Interface.SEM_ID;
-
- L : aliased RTS_Lock;
- -- Protection for all components is lock L
- end record;
-
-end System.Task_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- 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;
- -- <<L61b>>
- -- 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...
- -- <<L31b>>
- -- 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;
- -- <<L1>>
- -- ...B...
- -- goto L3;
- -- <<L2>>
- -- ...C...
- -- goto L3;
- -- <<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;
- -- <<L26b>>
- -- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the parent package of the GNAT restricted tasking run time
-
-package System.Tasking.Restricted is
-end System.Tasking.Restricted;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
- -- <<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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a POSIX version of this package where foreign threads are
--- recognized.
-
-separate (System.Task_Primitives.Operations)
-package body Specific is
-
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_Id associated with a thread
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- pragma Warnings (Off, Environment_Task);
- Result : Interfaces.C.int;
-
- begin
- Result := pthread_key_create (ATCB_Key'Access, null);
- pragma Assert (Result = 0);
- end Initialize;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- begin
- return pthread_getspecific (ATCB_Key) /= System.Null_Address;
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
- pragma Assert (Result = 0);
- end Set;
-
- ----------
- -- Self --
- ----------
-
- -- To make Ada tasks and C threads interoperate better, we have added some
- -- functionality to Self. Suppose a C main program (with threads) calls an
- -- Ada procedure and the Ada procedure calls the tasking runtime system.
- -- Eventually, a call will be made to self. Since the call is not coming
- -- from an Ada task, there will be no corresponding ATCB.
-
- -- What we do in Self is to catch references that do not come from
- -- recognized Ada tasks, and create an ATCB for the calling thread.
-
- -- The new ATCB will be "detached" from the normal Ada task master
- -- hierarchy, much like the existing implicitly created signal-server
- -- tasks.
-
- function Self return Task_Id is
- Result : System.Address;
-
- begin
- Result := pthread_getspecific (ATCB_Key);
-
- -- If the key value is Null then it is a non-Ada task
-
- if Result /= System.Null_Address then
- return To_Task_Id (Result);
- else
- return Register_Foreign_Thread;
- end if;
- end Self;
-
-end Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a POSIX-like version of this package
-
-separate (System.Task_Primitives.Operations)
-package body Specific is
-
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_Id associated with a thread
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- pragma Warnings (Off, Environment_Task);
- Result : Interfaces.C.int;
- begin
- Result := pthread_key_create (ATCB_Key'Access, null);
- pragma Assert (Result = 0);
- end Initialize;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- begin
- return pthread_getspecific (ATCB_Key) /= System.Null_Address;
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- Result : Interfaces.C.int;
- begin
- Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
- pragma Assert (Result = 0);
- end Set;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_Id is
- begin
- return To_Task_Id (pthread_getspecific (ATCB_Key));
- end Self;
-
-end Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a version for Solaris native threads
-
-separate (System.Task_Primitives.Operations)
-package body Specific is
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- pragma Unreferenced (Environment_Task);
- Result : Interfaces.C.int;
- begin
- Result := thr_keycreate (ATCB_Key'Access, System.Null_Address);
- pragma Assert (Result = 0);
- end Initialize;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- Unknown_Task : aliased System.Address;
- Result : Interfaces.C.int;
- begin
- Result := thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access);
- pragma Assert (Result = 0);
- return Unknown_Task /= System.Null_Address;
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- Result : Interfaces.C.int;
- begin
- Result := thr_setspecific (ATCB_Key, To_Address (Self_Id));
- pragma Assert (Result = 0);
- end Set;
-
- ----------
- -- Self --
- ----------
-
- -- To make Ada tasks and C threads interoperate better, we have
- -- added some functionality to Self. Suppose a C main program
- -- (with threads) calls an Ada procedure and the Ada procedure
- -- calls the tasking run-time system. Eventually, a call will be
- -- made to self. Since the call is not coming from an Ada task,
- -- there will be no corresponding ATCB.
-
- -- What we do in Self is to catch references that do not come
- -- from recognized Ada tasks, and create an ATCB for the calling
- -- thread.
-
- -- The new ATCB will be "detached" from the normal Ada task
- -- master hierarchy, much like the existing implicitly created
- -- signal-server tasks.
-
- function Self return Task_Id is
- Result : Interfaces.C.int;
- Self_Id : aliased System.Address;
- begin
- Result := thr_getspecific (ATCB_Key, Self_Id'Unchecked_Access);
- pragma Assert (Result = 0);
-
- if Self_Id = System.Null_Address then
- return Register_Foreign_Thread;
- else
- return To_Task_Id (Self_Id);
- end if;
- end Self;
-
-end Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a version of this package using TLS and where foreign threads are
--- recognized.
-
-separate (System.Task_Primitives.Operations)
-package body Specific is
-
- ATCB : aliased Task_Id := null;
- pragma Thread_Local_Storage (ATCB);
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : Task_Id) is
- begin
- ATCB := Environment_Task;
- end Initialize;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- begin
- return ATCB /= null;
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- begin
- ATCB := Self_Id;
- end Set;
-
- ----------
- -- Self --
- ----------
-
- -- To make Ada tasks and C threads interoperate better, we have added some
- -- functionality to Self. Suppose a C main program (with threads) calls an
- -- Ada procedure and the Ada procedure calls the tasking runtime system.
- -- Eventually, a call will be made to self. Since the call is not coming
- -- from an Ada task, there will be no corresponding ATCB.
-
- -- What we do in Self is to catch references that do not come from
- -- recognized Ada tasks, and create an ATCB for the calling thread.
-
- -- The new ATCB will be "detached" from the normal Ada task master
- -- hierarchy, much like the existing implicitly created signal-server
- -- tasks.
-
- function Self return Task_Id is
- Result : constant Task_Id := ATCB;
- begin
- if Result /= null then
- return Result;
- else
- -- If the value is Null then it is a non-Ada task
-
- return Register_Foreign_Thread;
- end if;
- end Self;
-
-end Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a VxWorks version of this package where foreign threads are
--- recognized. The implementation is based on VxWorks taskVarLib.
-
-separate (System.Task_Primitives.Operations)
-package body Specific is
-
- ATCB_Key : aliased System.Address := System.Null_Address;
- -- Key used to find the Ada Task_Id associated with a thread
-
- ATCB_Key_Addr : System.Address := ATCB_Key'Address;
- pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr");
- -- Exported to support the temporary AE653 task registration
- -- implementation. This mechanism is used to minimize impact on other
- -- targets.
-
- Stack_Limit : aliased System.Address;
-
- pragma Import (C, Stack_Limit, "__gnat_stack_limit");
-
- type Set_Stack_Limit_Proc_Acc is access procedure;
- pragma Convention (C, Set_Stack_Limit_Proc_Acc);
-
- Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
- pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
- -- Procedure to be called when a task is created to set stack limit if
- -- limit checking is used.
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- null;
- end Initialize;
-
- -------------------
- -- Is_Valid_Task --
- -------------------
-
- function Is_Valid_Task return Boolean is
- begin
- return taskVarGet (taskIdSelf, ATCB_Key'Access) /= ERROR;
- end Is_Valid_Task;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (Self_Id : Task_Id) is
- Result : STATUS;
-
- begin
- -- If argument is null, destroy task specific data, to make API
- -- consistent with other platforms, and thus compatible with the
- -- shared version of s-tpoaal.adb.
-
- if Self_Id = null then
- Result := taskVarDelete (taskIdSelf, ATCB_Key'Access);
- pragma Assert (Result /= ERROR);
- return;
- end if;
-
- if not Is_Valid_Task then
- Result := taskVarAdd (Self_Id.Common.LL.Thread, ATCB_Key'Access);
- pragma Assert (Result = OK);
-
- if Stack_Check_Limits
- and then Result /= ERROR
- and then Set_Stack_Limit_Hook /= null
- then
- -- This will be initialized from taskInfoGet() once the task is
- -- is running.
-
- Result :=
- taskVarAdd (Self_Id.Common.LL.Thread, Stack_Limit'Access);
- pragma Assert (Result /= ERROR);
- end if;
- end if;
-
- Result :=
- taskVarSet
- (Self_Id.Common.LL.Thread,
- ATCB_Key'Access,
- To_Address (Self_Id));
- pragma Assert (Result /= ERROR);
- end Set;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_Id is
- begin
- return To_Task_Id (ATCB_Key);
- end Self;
-
-end Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S . E X T --
--- --
--- B o d y --
--- --
--- Copyright (C) 2008-2015, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides vxworks specific support functions needed
--- by System.OS_Interface.
-
--- This is the VxWorks <= 6.5 kernel version of this package
--- Also works for 6.6 uniprocessor
-
-package body System.VxWorks.Ext is
-
- ERROR : constant := -1;
-
- --------------
- -- Int_Lock --
- --------------
-
- function intLock return int;
- pragma Import (C, intLock, "intLock");
-
- function Int_Lock return int renames intLock;
-
- ----------------
- -- Int_Unlock --
- ----------------
-
- function intUnlock (Old : int) return int;
- pragma Import (C, intUnlock, "intUnlock");
-
- function Int_Unlock (Old : int) return int renames intUnlock;
-
- ---------------
- -- semDelete --
- ---------------
-
- function semDelete (Sem : SEM_ID) return int is
- function Os_Sem_Delete (Sem : SEM_ID) return int;
- pragma Import (C, Os_Sem_Delete, "semDelete");
- begin
- return Os_Sem_Delete (Sem);
- end semDelete;
-
- ------------------------
- -- taskCpuAffinitySet --
- ------------------------
-
- function taskCpuAffinitySet (tid : t_id; CPU : int) return int is
- pragma Unreferenced (tid, CPU);
- begin
- return ERROR;
- end taskCpuAffinitySet;
-
- -------------------------
- -- taskMaskAffinitySet --
- -------------------------
-
- function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is
- pragma Unreferenced (tid, CPU_Set);
- begin
- return ERROR;
- end taskMaskAffinitySet;
-
- --------------
- -- taskCont --
- --------------
-
- function Task_Cont (tid : t_id) return int is
- function taskCont (tid : t_id) return int;
- pragma Import (C, taskCont, "taskCont");
- begin
- return taskCont (tid);
- end Task_Cont;
-
- --------------
- -- taskStop --
- --------------
-
- function Task_Stop (tid : t_id) return int is
- function taskStop (tid : t_id) return int;
- pragma Import (C, taskStop, "taskStop");
- begin
- return taskStop (tid);
- end Task_Stop;
-
-end System.VxWorks.Ext;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S . E X T --
--- --
--- S p e c --
--- --
--- Copyright (C) 2008-2015, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides vxworks specific support functions needed
--- by System.OS_Interface.
-
--- This is the VxWorks 6 kernel version of this package
-
-with Interfaces.C;
-
-package System.VxWorks.Ext is
- pragma Preelaborate;
-
- subtype SEM_ID is Long_Integer;
- -- typedef struct semaphore *SEM_ID;
-
- type sigset_t is mod 2 ** Long_Long_Integer'Size;
-
- type t_id is new Long_Integer;
- subtype int is Interfaces.C.int;
- subtype unsigned is Interfaces.C.unsigned;
-
- type Interrupt_Handler is access procedure (parameter : System.Address);
- pragma Convention (C, Interrupt_Handler);
-
- type Interrupt_Vector is new System.Address;
-
- function Int_Lock return int;
- pragma Convention (C, Int_Lock);
-
- function Int_Unlock (Old : int) return int;
- pragma Convention (C, Int_Unlock);
-
- function Interrupt_Connect
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler;
- Parameter : System.Address := System.Null_Address) return int;
- pragma Import (C, Interrupt_Connect, "intConnect");
-
- function Interrupt_Context return int;
- pragma Import (C, Interrupt_Context, "intContext");
-
- function Interrupt_Number_To_Vector
- (intNum : int) return Interrupt_Vector;
- pragma Import (C, Interrupt_Number_To_Vector, "__gnat_inum_to_ivec");
-
- function semDelete (Sem : SEM_ID) return int;
- pragma Convention (C, semDelete);
-
- function Task_Cont (tid : t_id) return int;
- pragma Convention (C, Task_Cont);
-
- function Task_Stop (tid : t_id) return int;
- pragma Convention (C, Task_Stop);
-
- function kill (pid : t_id; sig : int) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return t_id;
- pragma Import (C, getpid, "taskIdSelf");
-
- function Set_Time_Slice (ticks : int) return int;
- pragma Import (C, Set_Time_Slice, "kernelTimeSlice");
-
- type UINT64 is mod 2 ** Long_Long_Integer'Size;
-
- function tickGet return UINT64;
- -- Needed for ravenscar-cert
- pragma Import (C, tickGet, "tick64Get");
-
- --------------------------------
- -- Processor Affinity for SMP --
- --------------------------------
-
- function taskCpuAffinitySet (tid : t_id; CPU : int) return int;
- pragma Convention (C, taskCpuAffinitySet);
- -- For SMP run-times set the CPU affinity.
- -- For uniprocessor systems return ERROR status.
-
- function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int;
- pragma Convention (C, taskMaskAffinitySet);
- -- For SMP run-times set the CPU mask affinity.
- -- For uniprocessor systems return ERROR status.
-
-end System.VxWorks.Ext;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S . E X T --
--- --
--- B o d y --
--- --
--- Copyright (C) 2008-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides VxWorks specific support functions needed
--- by System.OS_Interface.
-
--- This is the VxWorks 6 RTP version of this package
-
-package body System.VxWorks.Ext is
-
- ERROR : constant := -1;
-
- --------------
- -- Int_Lock --
- --------------
-
- function Int_Lock return int is
- begin
- return ERROR;
- end Int_Lock;
-
- ----------------
- -- Int_Unlock --
- ----------------
-
- function Int_Unlock (Old : int) return int is
- pragma Unreferenced (Old);
- begin
- return ERROR;
- end Int_Unlock;
-
- -----------------------
- -- Interrupt_Connect --
- -----------------------
-
- function Interrupt_Connect
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler;
- Parameter : System.Address := System.Null_Address) return int
- is
- pragma Unreferenced (Vector, Handler, Parameter);
- begin
- return ERROR;
- end Interrupt_Connect;
-
- -----------------------
- -- Interrupt_Context --
- -----------------------
-
- function Interrupt_Context return int is
- begin
- -- For RTPs, never in an interrupt context
-
- return 0;
- end Interrupt_Context;
-
- --------------------------------
- -- Interrupt_Number_To_Vector --
- --------------------------------
-
- function Interrupt_Number_To_Vector
- (intNum : int) return Interrupt_Vector
- is
- pragma Unreferenced (intNum);
- begin
- return 0;
- end Interrupt_Number_To_Vector;
-
- ---------------
- -- semDelete --
- ---------------
-
- function semDelete (Sem : SEM_ID) return int is
- function OS_semDelete (Sem : SEM_ID) return int;
- pragma Import (C, OS_semDelete, "semDelete");
- begin
- return OS_semDelete (Sem);
- end semDelete;
-
- --------------------
- -- Set_Time_Slice --
- --------------------
-
- function Set_Time_Slice (ticks : int) return int is
- pragma Unreferenced (ticks);
- begin
- return ERROR;
- end Set_Time_Slice;
-
- ------------------------
- -- taskCpuAffinitySet --
- ------------------------
-
- function taskCpuAffinitySet (tid : t_id; CPU : int) return int is
- pragma Unreferenced (tid, CPU);
- begin
- return ERROR;
- end taskCpuAffinitySet;
-
- -------------------------
- -- taskMaskAffinitySet --
- -------------------------
-
- function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is
- pragma Unreferenced (tid, CPU_Set);
- begin
- return ERROR;
- end taskMaskAffinitySet;
-
-end System.VxWorks.Ext;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S . E X T --
--- --
--- S p e c --
--- --
--- Copyright (C) 2008-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides vxworks specific support functions needed
--- by System.OS_Interface.
-
--- This is the VxWorks 6 RTP version of this package
-
-with Interfaces.C;
-
-package System.VxWorks.Ext is
- pragma Preelaborate;
-
- subtype SEM_ID is Long_Integer;
- -- typedef struct semaphore *SEM_ID;
-
- type sigset_t is mod 2 ** Long_Long_Integer'Size;
-
- type t_id is new Long_Integer;
- subtype int is Interfaces.C.int;
- subtype unsigned is Interfaces.C.unsigned;
-
- type Interrupt_Handler is access procedure (parameter : System.Address);
- pragma Convention (C, Interrupt_Handler);
-
- type Interrupt_Vector is new System.Address;
-
- function Int_Lock return int;
- pragma Inline (Int_Lock);
-
- function Int_Unlock (Old : int) return int;
- pragma Inline (Int_Unlock);
-
- function Interrupt_Connect
- (Vector : Interrupt_Vector;
- Handler : Interrupt_Handler;
- Parameter : System.Address := System.Null_Address) return int;
- pragma Convention (C, Interrupt_Connect);
-
- function Interrupt_Context return int;
- pragma Convention (C, Interrupt_Context);
-
- function Interrupt_Number_To_Vector
- (intNum : int) return Interrupt_Vector;
- pragma Convention (C, Interrupt_Number_To_Vector);
-
- function semDelete (Sem : SEM_ID) return int;
- pragma Convention (C, semDelete);
-
- function Task_Cont (tid : t_id) return int;
- pragma Import (C, Task_Cont, "taskResume");
-
- function Task_Stop (tid : t_id) return int;
- pragma Import (C, Task_Stop, "taskSuspend");
-
- function kill (pid : t_id; sig : int) return int;
- pragma Import (C, kill, "taskKill");
-
- function getpid return t_id;
- pragma Import (C, getpid, "getpid");
-
- function Set_Time_Slice (ticks : int) return int;
- pragma Inline (Set_Time_Slice);
-
- --------------------------------
- -- Processor Affinity for SMP --
- --------------------------------
-
- function taskCpuAffinitySet (tid : t_id; CPU : int) return int;
- pragma Convention (C, taskCpuAffinitySet);
- -- For SMP run-times set the CPU affinity.
- -- For uniprocessor systems return ERROR status.
-
- function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int;
- pragma Convention (C, taskMaskAffinitySet);
- -- For SMP run-times set the CPU mask affinity.
- -- For uniprocessor systems return ERROR status.
-
-end System.VxWorks.Ext;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S . E X T --
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S . E X T --
--- --
--- S p e c --
--- --
--- Copyright (C) 2008-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
-------------------------------------------------------------------------------
-
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1998-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the ARM VxWorks version of this package
-
-with Interfaces.C;
-
-package System.VxWorks is
- pragma Preelaborate (System.VxWorks);
-
- package IC renames Interfaces.C;
-
- -- Floating point context record. ARM version
-
- FP_SGPR_NUM_REGS : constant := 32;
- type Fpr_Sgpr_Array is array (1 .. FP_SGPR_NUM_REGS) of IC.unsigned;
-
- -- The record definition below matches what arch/arm/fppArmLib.h says
-
- type FP_CONTEXT is record
- fpsid : IC.unsigned; -- system ID register
- fpscr : IC.unsigned; -- status and control register
- fpexc : IC.unsigned; -- exception register
- fpinst : IC.unsigned; -- instruction register
- fpinst2 : IC.unsigned; -- instruction register 2
- mfvfr0 : IC.unsigned; -- media and VFP feature Register 0
- mfvfr1 : IC.unsigned; -- media and VFP feature Register 1
- pad : IC.unsigned;
- vfp_gpr : Fpr_Sgpr_Array;
- end record;
-
- for FP_CONTEXT'Alignment use 4;
- pragma Convention (C, FP_CONTEXT);
-
- Num_HW_Interrupts : constant := 256;
- -- Number of entries in hardware interrupt vector table
-
-end System.VxWorks;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1998-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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the PPC VxWorks version of this package
-
-with Interfaces.C;
-
-package System.VxWorks is
- pragma Preelaborate;
-
- package IC renames Interfaces.C;
-
- -- Floating point context record. PPC version
-
- FP_NUM_DREGS : constant := 32;
- type Fpr_Array is array (1 .. FP_NUM_DREGS) of IC.double;
-
- type FP_CONTEXT is record
- fpr : Fpr_Array;
- fpcsr : IC.int;
- fpcsrCopy : IC.int;
- end record;
- pragma Convention (C, FP_CONTEXT);
-
- Num_HW_Interrupts : constant := 256;
-
-end System.VxWorks;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . V X W O R K S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the x86 VxWorks version of this package
-
-package System.VxWorks is
- pragma Preelaborate;
-
- -- Floating point context record. x86 version
-
- -- There are two kinds of FP_CONTEXT for this architecture, corresponding
- -- to newer and older processors. The type is defined in fppI86lib.h as a
- -- union. The form used depends on the versions of the save and restore
- -- routines that are selected by the user (these versions are provided in
- -- vxwork.ads). Since we do not examine the contents of these objects, it
- -- is sufficient to declare the type as of the required size: 512 bytes.
-
- type FP_CONTEXT is array (1 .. 128) of Integer;
- for FP_CONTEXT'Alignment use 4;
- for FP_CONTEXT'Size use 512 * Storage_Unit;
- pragma Convention (C, FP_CONTEXT);
-
- Num_HW_Interrupts : constant := 256;
- -- Number of entries in hardware interrupt vector table
-
-end System.VxWorks;
+++ /dev/null
-/****************************************************************************
- * *
- * GNAT 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 *
- * <http://www.gnu.org/licenses/>. *
- * *
- * GNAT was originally developed by the GNAT team at New York University. *
- * Extensive contributions were provided by Ada Core Technologies Inc. *
- * *
- ****************************************************************************/
-
-/* This 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 <pthread.h>
-# include <time.h>
-
-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 <mach/mach.h>
-#include <mach/clock.h>
-#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;
-}
projects / gcc.git / commitdiff