gcc/ada/a-taster.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                 A D A . T A S K _ T E R M I N A T I O N                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2005-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 with System.Tasking;
  35 --  used for Task_Id
  36
  37 with System.Task_Primitives.Operations;
  38 --  used for Self
  39 --           Write_Lock
  40 --           Unlock
  41 --           Lock_RTS
  42 --           Unlock_RTS
  43
  44 with System.Parameters;
  45 --  used for Single_Lock
  46
  47 with System.Soft_Links;
  48 --  use for Abort_Defer
  49 --          Abort_Undefer
  50
  51 with Ada.Unchecked_Conversion;
  52
  53 package body Ada.Task_Termination is
  54
  55    use type Ada.Task_Identification.Task_Id;
  56
  57    package STPO renames System.Task_Primitives.Operations;
  58    package SSL  renames System.Soft_Links;
  59
  60    use System.Parameters;
  61
  62    -----------------------
  63    -- Local subprograms --
  64    -----------------------
  65
  66    function To_TT is new Ada.Unchecked_Conversion
  67      (System.Tasking.Termination_Handler, Termination_Handler);
  68
  69    function To_ST is new Ada.Unchecked_Conversion
  70      (Termination_Handler, System.Tasking.Termination_Handler);
  71
  72    function To_Task_Id is new Ada.Unchecked_Conversion
  73      (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id);
  74
  75    -----------------------------------
  76    -- Current_Task_Fallback_Handler --
  77    -----------------------------------
  78
  79    function Current_Task_Fallback_Handler return Termination_Handler is
  80    begin
  81       --  There is no need for explicit protection against race conditions
  82       --  for this function because this function can only be executed by
  83       --  Self, and the Fall_Back_Handler can only be modified by Self.
  84
  85       return To_TT (STPO.Self.Common.Fall_Back_Handler);
  86    end Current_Task_Fallback_Handler;
  87
  88    -------------------------------------
  89    -- Set_Dependents_Fallback_Handler --
  90    -------------------------------------
  91
  92    procedure Set_Dependents_Fallback_Handler
  93      (Handler : Termination_Handler)
  94    is
  95       Self : constant System.Tasking.Task_Id := STPO.Self;
  96
  97    begin
  98       SSL.Abort_Defer.all;
  99
 100       if Single_Lock then
 101          STPO.Lock_RTS;
 102       end if;
 103
 104       STPO.Write_Lock (Self);
 105
 106       Self.Common.Fall_Back_Handler := To_ST (Handler);
 107
 108       STPO.Unlock (Self);
 109
 110       if Single_Lock then
 111          STPO.Unlock_RTS;
 112       end if;
 113
 114       SSL.Abort_Undefer.all;
 115    end Set_Dependents_Fallback_Handler;
 116
 117    --------------------------
 118    -- Set_Specific_Handler --
 119    --------------------------
 120
 121    procedure Set_Specific_Handler
 122      (T       : Ada.Task_Identification.Task_Id;
 123       Handler : Termination_Handler)
 124    is
 125    begin
 126       --  Tasking_Error is raised if the task identified by T has already
 127       --  terminated. Program_Error is raised if the value of T is
 128       --  Null_Task_Id.
 129
 130       if T = Ada.Task_Identification.Null_Task_Id then
 131          raise Program_Error;
 132       elsif Ada.Task_Identification.Is_Terminated (T) then
 133          raise Tasking_Error;
 134       else
 135          declare
 136             Target : constant System.Tasking.Task_Id := To_Task_Id (T);
 137
 138          begin
 139             SSL.Abort_Defer.all;
 140
 141             if Single_Lock then
 142                STPO.Lock_RTS;
 143             end if;
 144
 145             STPO.Write_Lock (Target);
 146
 147             Target.Common.Specific_Handler := To_ST (Handler);
 148
 149             STPO.Unlock (Target);
 150
 151             if Single_Lock then
 152                STPO.Unlock_RTS;
 153             end if;
 154
 155             SSL.Abort_Undefer.all;
 156          end;
 157       end if;
 158    end Set_Specific_Handler;
 159
 160    ----------------------
 161    -- Specific_Handler --
 162    ----------------------
 163
 164    function Specific_Handler
 165      (T : Ada.Task_Identification.Task_Id) return Termination_Handler
 166    is
 167    begin
 168       --  Tasking_Error is raised if the task identified by T has already
 169       --  terminated. Program_Error is raised if the value of T is
 170       --  Null_Task_Id.
 171
 172       if T = Ada.Task_Identification.Null_Task_Id then
 173          raise Program_Error;
 174       elsif Ada.Task_Identification.Is_Terminated (T) then
 175          raise Tasking_Error;
 176       else
 177          declare
 178             Target : constant System.Tasking.Task_Id := To_Task_Id (T);
 179             TH     : Termination_Handler;
 180
 181          begin
 182             SSL.Abort_Defer.all;
 183
 184             if Single_Lock then
 185                STPO.Lock_RTS;
 186             end if;
 187
 188             STPO.Write_Lock (Target);
 189
 190             TH := To_TT (Target.Common.Specific_Handler);
 191
 192             STPO.Unlock (Target);
 193
 194             if Single_Lock then
 195                STPO.Unlock_RTS;
 196             end if;
 197
 198             SSL.Abort_Undefer.all;
 199
 200             return TH;
 201          end;
 202       end if;
 203    end Specific_Handler;
 204
 205 end Ada.Task_Termination;