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