gcc/ada/libgnarl/s-solita.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --             S Y S T E M . S O F T _ L I N K S . T A S K I N G            --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2018, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 pragma Style_Checks (All_Checks);
  33 --  Turn off subprogram alpha ordering check, since we group soft link bodies
  34 --  and dummy soft link bodies together separately in this unit.
  35
  36 pragma Polling (Off);
  37 --  Turn polling off for this package. We don't need polling during any of the
  38 --  routines in this package, and more to the point, if we try to poll it can
  39 --  cause infinite loops.
  40
  41 with Ada.Exceptions;
  42 with Ada.Exceptions.Is_Null_Occurrence;
  43
  44 with System.Task_Primitives.Operations;
  45 with System.Tasking;
  46 with System.Stack_Checking;
  47 with System.Secondary_Stack;
  48
  49 package body System.Soft_Links.Tasking is
  50
  51    package STPO renames System.Task_Primitives.Operations;
  52    package SSL  renames System.Soft_Links;
  53
  54    use Ada.Exceptions;
  55
  56    use type System.Secondary_Stack.SS_Stack_Ptr;
  57
  58    use type System.Tasking.Task_Id;
  59    use type System.Tasking.Termination_Handler;
  60
  61    ----------------
  62    -- Local Data --
  63    ----------------
  64
  65    Initialized : Boolean := False;
  66    --  Boolean flag that indicates whether the tasking soft links have
  67    --  already been set.
  68
  69    -----------------------------------------------------------------
  70    -- Tasking Versions of Services Needed by Non-Tasking Programs --
  71    -----------------------------------------------------------------
  72
  73    function  Get_Jmpbuf_Address return  Address;
  74    procedure Set_Jmpbuf_Address (Addr : Address);
  75    --  Get/Set Jmpbuf_Address for current task
  76
  77    function  Get_Sec_Stack return SST.SS_Stack_Ptr;
  78    procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr);
  79    --  Get/Set location of current task's secondary stack
  80
  81    procedure Timed_Delay_T (Time : Duration; Mode : Integer);
  82    --  Task-safe version of SSL.Timed_Delay
  83
  84    procedure Task_Termination_Handler_T  (Excep : SSL.EO);
  85    --  Task-safe version of the task termination procedure
  86
  87    function Get_Stack_Info return Stack_Checking.Stack_Access;
  88    --  Get access to the current task's Stack_Info
  89
  90    --------------------------
  91    -- Soft-Link Get Bodies --
  92    --------------------------
  93
  94    function Get_Jmpbuf_Address return  Address is
  95    begin
  96       return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
  97    end Get_Jmpbuf_Address;
  98
  99    function Get_Sec_Stack return SST.SS_Stack_Ptr is
 100    begin
 101       return Result : constant SST.SS_Stack_Ptr :=
 102         STPO.Self.Common.Compiler_Data.Sec_Stack_Ptr
 103       do
 104          pragma Assert (Result /= null);
 105       end return;
 106    end Get_Sec_Stack;
 107
 108    function Get_Stack_Info return Stack_Checking.Stack_Access is
 109    begin
 110       return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access;
 111    end Get_Stack_Info;
 112
 113    --------------------------
 114    -- Soft-Link Set Bodies --
 115    --------------------------
 116
 117    procedure Set_Jmpbuf_Address (Addr : Address) is
 118    begin
 119       STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
 120    end Set_Jmpbuf_Address;
 121
 122    procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr) is
 123    begin
 124       STPO.Self.Common.Compiler_Data.Sec_Stack_Ptr := Stack;
 125    end Set_Sec_Stack;
 126
 127    -------------------
 128    -- Timed_Delay_T --
 129    -------------------
 130
 131    procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
 132       Self_Id : constant System.Tasking.Task_Id := STPO.Self;
 133
 134    begin
 135       --  In case pragma Detect_Blocking is active then Program_Error
 136       --  must be raised if this potentially blocking operation
 137       --  is called from a protected operation.
 138
 139       if System.Tasking.Detect_Blocking
 140         and then Self_Id.Common.Protected_Action_Nesting > 0
 141       then
 142          raise Program_Error with "potentially blocking operation";
 143       else
 144          Abort_Defer.all;
 145          STPO.Timed_Delay (Self_Id, Time, Mode);
 146          Abort_Undefer.all;
 147       end if;
 148    end Timed_Delay_T;
 149
 150    --------------------------------
 151    -- Task_Termination_Handler_T --
 152    --------------------------------
 153
 154    procedure Task_Termination_Handler_T (Excep : SSL.EO) is
 155       Self_Id : constant System.Tasking.Task_Id := STPO.Self;
 156       Cause   : System.Tasking.Cause_Of_Termination;
 157       EO      : Ada.Exceptions.Exception_Occurrence;
 158
 159    begin
 160       --  We can only be here because we are terminating the environment task.
 161       --  Task termination for all other tasks is handled in the Task_Wrapper.
 162
 163       --  We do not want to enable this check and e.g. call System.OS_Lib.Abort
 164       --  here because some restricted run-times may not have System.OS_Lib
 165       --  and calling abort may do more harm than good to the main application.
 166
 167       pragma Assert (Self_Id = STPO.Environment_Task);
 168
 169       --  Normal task termination
 170
 171       if Is_Null_Occurrence (Excep) then
 172          Cause := System.Tasking.Normal;
 173          Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
 174
 175       --  Abnormal task termination
 176
 177       elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then
 178          Cause := System.Tasking.Abnormal;
 179          Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
 180
 181       --  Termination because of an unhandled exception
 182
 183       else
 184          Cause := System.Tasking.Unhandled_Exception;
 185          Ada.Exceptions.Save_Occurrence (EO, Excep);
 186       end if;
 187
 188       --  There is no need for explicit protection against race conditions for
 189       --  this part because it can only be executed by the environment task
 190       --  after all the other tasks have been finalized. Note that there is no
 191       --  fall-back handler which could apply to this environment task because
 192       --  it has no parents, and, as specified in ARM C.7.3 par. 9/2, "the
 193       --  fall-back handler applies only to the dependent tasks of the task".
 194
 195       if Self_Id.Common.Specific_Handler /= null then
 196          Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO);
 197       end if;
 198    end Task_Termination_Handler_T;
 199
 200    -----------------------------
 201    -- Init_Tasking_Soft_Links --
 202    -----------------------------
 203
 204    procedure Init_Tasking_Soft_Links is
 205    begin
 206       --  Set links only if not set already
 207
 208       if not Initialized then
 209
 210          --  Mark tasking soft links as initialized
 211
 212          Initialized := True;
 213
 214          --  The application being executed uses tasking so that the tasking
 215          --  version of the following soft links need to be used.
 216
 217          SSL.Get_Jmpbuf_Address       := Get_Jmpbuf_Address'Access;
 218          SSL.Set_Jmpbuf_Address       := Set_Jmpbuf_Address'Access;
 219          SSL.Get_Sec_Stack            := Get_Sec_Stack'Access;
 220          SSL.Get_Stack_Info           := Get_Stack_Info'Access;
 221          SSL.Set_Sec_Stack            := Set_Sec_Stack'Access;
 222          SSL.Timed_Delay              := Timed_Delay_T'Access;
 223          SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access;
 224
 225          --  No need to create a new secondary stack, since we will use the
 226          --  default one created in s-secsta.adb.
 227
 228          SSL.Set_Sec_Stack          (SSL.Get_Sec_Stack_NT);
 229          SSL.Set_Jmpbuf_Address     (SSL.Get_Jmpbuf_Address_NT);
 230       end if;
 231
 232       pragma Assert (Get_Sec_Stack /= null);
 233    end Init_Tasking_Soft_Links;
 234
 235 end System.Soft_Links.Tasking;