gcc/ada/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-2007, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 pragma Style_Checks (All_Checks);
  35 --  Turn off subprogram alpha ordering check, since we group soft link
  36 --  bodies and dummy soft link bodies together separately in this unit.
  37
  38 pragma Polling (Off);
  39 --  Turn polling off for this package. We don't need polling during any
  40 --  of the routines in this package, and more to the point, if we try
  41 --  to poll it can cause infinite loops.
  42
  43 with System.Task_Primitives.Operations;
  44 --  Used for Self
  45 --           Timed_Delay
  46
  47 with System.Tasking;
  48 --  Used for Task_Id
  49 --           Cause_Of_Termination
  50
  51 with System.Stack_Checking;
  52 --  Used for Stack_Access
  53
  54 with Ada.Exceptions;
  55 --  Used for Exception_Id
  56 --           Exception_Occurrence
  57 --           Save_Occurrence
  58
  59 with Ada.Exceptions.Is_Null_Occurrence;
  60
  61 package body System.Soft_Links.Tasking is
  62
  63    package STPO renames System.Task_Primitives.Operations;
  64    package SSL  renames System.Soft_Links;
  65
  66    use Ada.Exceptions;
  67
  68    use type System.Tasking.Task_Id;
  69    use type System.Tasking.Termination_Handler;
  70
  71    ----------------
  72    -- Local Data --
  73    ----------------
  74
  75    Initialized : Boolean := False;
  76    --  Boolean flag that indicates whether the tasking soft links have
  77    --  already been set.
  78
  79    -----------------------------------------------------------------
  80    -- Tasking Versions of Services Needed by Non-Tasking Programs --
  81    -----------------------------------------------------------------
  82
  83    function  Get_Jmpbuf_Address return  Address;
  84    procedure Set_Jmpbuf_Address (Addr : Address);
  85    --  Get/Set Jmpbuf_Address for current task
  86
  87    function  Get_Sec_Stack_Addr return  Address;
  88    procedure Set_Sec_Stack_Addr (Addr : Address);
  89    --  Get/Set location of current task's secondary stack
  90
  91    procedure Timed_Delay_T (Time : Duration; Mode : Integer);
  92    --  Task-safe version of SSL.Timed_Delay
  93
  94    procedure Task_Termination_Handler_T  (Excep : SSL.EO);
  95    --  Task-safe version of the task termination procedure
  96
  97    function Get_Stack_Info return Stack_Checking.Stack_Access;
  98    --  Get access to the current task's Stack_Info
  99
 100    --------------------------
 101    -- Soft-Link Get Bodies --
 102    --------------------------
 103
 104    function Get_Jmpbuf_Address return  Address is
 105    begin
 106       return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
 107    end Get_Jmpbuf_Address;
 108
 109    function Get_Sec_Stack_Addr return  Address is
 110    begin
 111       return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
 112    end Get_Sec_Stack_Addr;
 113
 114    function Get_Stack_Info return Stack_Checking.Stack_Access is
 115    begin
 116       return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access;
 117    end Get_Stack_Info;
 118
 119    --------------------------
 120    -- Soft-Link Set Bodies --
 121    --------------------------
 122
 123    procedure Set_Jmpbuf_Address (Addr : Address) is
 124    begin
 125       STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
 126    end Set_Jmpbuf_Address;
 127
 128    procedure Set_Sec_Stack_Addr (Addr : Address) is
 129    begin
 130       STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
 131    end Set_Sec_Stack_Addr;
 132
 133    -------------------
 134    -- Timed_Delay_T --
 135    -------------------
 136
 137    procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
 138       Self_Id : constant System.Tasking.Task_Id := STPO.Self;
 139
 140    begin
 141       --  In case pragma Detect_Blocking is active then Program_Error
 142       --  must be raised if this potentially blocking operation
 143       --  is called from a protected operation.
 144
 145       if System.Tasking.Detect_Blocking
 146         and then Self_Id.Common.Protected_Action_Nesting > 0
 147       then
 148          raise Program_Error with "potentially blocking operation";
 149       else
 150          Abort_Defer.all;
 151          STPO.Timed_Delay (Self_Id, Time, Mode);
 152          Abort_Undefer.all;
 153       end if;
 154    end Timed_Delay_T;
 155
 156    --------------------------------
 157    -- Task_Termination_Handler_T --
 158    --------------------------------
 159
 160    procedure Task_Termination_Handler_T (Excep : SSL.EO) is
 161       Self_Id : constant System.Tasking.Task_Id := STPO.Self;
 162       Cause   : System.Tasking.Cause_Of_Termination;
 163       EO      : Ada.Exceptions.Exception_Occurrence;
 164
 165    begin
 166       --  We can only be here because we are terminating the environment task.
 167       --  Task termination for the rest of the tasks is handled in the
 168       --  Task_Wrapper.
 169
 170       pragma Assert (Self_Id = STPO.Environment_Task);
 171
 172       --  Normal task termination
 173
 174       if Is_Null_Occurrence (Excep) then
 175          Cause := System.Tasking.Normal;
 176          Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
 177
 178       --  Abnormal task termination
 179
 180       elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then
 181          Cause := System.Tasking.Abnormal;
 182          Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
 183
 184       --  Termination because of an unhandled exception
 185
 186       else
 187          Cause := System.Tasking.Unhandled_Exception;
 188          Ada.Exceptions.Save_Occurrence (EO, Excep);
 189       end if;
 190
 191       --  There is no need for explicit protection against race conditions
 192       --  for this part because it can only be executed by the environment
 193       --  task after all the other tasks have been finalized.
 194
 195       if Self_Id.Common.Specific_Handler /= null then
 196          Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO);
 197       elsif Self_Id.Common.Fall_Back_Handler /= null then
 198          Self_Id.Common.Fall_Back_Handler.all (Cause, Self_Id, EO);
 199       end if;
 200    end Task_Termination_Handler_T;
 201
 202    -----------------------------
 203    -- Init_Tasking_Soft_Links --
 204    -----------------------------
 205
 206    procedure Init_Tasking_Soft_Links is
 207    begin
 208       --  Set links only if not set already
 209
 210       if not Initialized then
 211
 212          --  Mark tasking soft links as initialized
 213
 214          Initialized := True;
 215
 216          --  The application being executed uses tasking so that the tasking
 217          --  version of the following soft links need to be used.
 218
 219          SSL.Get_Jmpbuf_Address       := Get_Jmpbuf_Address'Access;
 220          SSL.Set_Jmpbuf_Address       := Set_Jmpbuf_Address'Access;
 221          SSL.Get_Sec_Stack_Addr       := Get_Sec_Stack_Addr'Access;
 222          SSL.Get_Stack_Info           := Get_Stack_Info'Access;
 223          SSL.Set_Sec_Stack_Addr       := Set_Sec_Stack_Addr'Access;
 224          SSL.Timed_Delay              := Timed_Delay_T'Access;
 225          SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access;
 226
 227          --  No need to create a new Secondary Stack, since we will use the
 228          --  default one created in s-secsta.adb
 229
 230          SSL.Set_Sec_Stack_Addr     (SSL.Get_Sec_Stack_Addr_NT);
 231          SSL.Set_Jmpbuf_Address     (SSL.Get_Jmpbuf_Address_NT);
 232       end if;
 233    end Init_Tasking_Soft_Links;
 234
 235 end System.Soft_Links.Tasking;