gcc/ada/a-tasatt.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                        GNAT RUN-TIME COMPONENTS                          --
   4 --                                                                          --
   5 --                  A D A . T A S K _ A T T R I B U T E S                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2014, 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 -- GNARL was developed by the GNARL team at Florida State University.       --
  28 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with System.Tasking;
  33 with System.Tasking.Initialization;
  34 with System.Tasking.Task_Attributes;
  35 pragma Elaborate_All (System.Tasking.Task_Attributes);
  36
  37 with System.Task_Primitives.Operations;
  38
  39 with Ada.Finalization; use Ada.Finalization;
  40 with Ada.Unchecked_Conversion;
  41 with Ada.Unchecked_Deallocation;
  42
  43 package body Ada.Task_Attributes is
  44
  45    use System,
  46        System.Tasking.Initialization,
  47        System.Tasking,
  48        System.Tasking.Task_Attributes;
  49
  50    package STPO renames System.Task_Primitives.Operations;
  51
  52    type Attribute_Cleanup is new Limited_Controlled with null record;
  53    procedure Finalize (Cleanup : in out Attribute_Cleanup);
  54    --  Finalize all tasks' attributes for this package
  55
  56    Cleanup : Attribute_Cleanup;
  57    pragma Unreferenced (Cleanup);
  58    --  Will call Finalize when this instantiation gets out of scope
  59
  60    ---------------------------
  61    -- Unchecked Conversions --
  62    ---------------------------
  63
  64    type Real_Attribute is record
  65       Free  : Deallocator;
  66       Value : Attribute;
  67    end record;
  68    type Real_Attribute_Access is access all Real_Attribute;
  69    pragma No_Strict_Aliasing (Real_Attribute_Access);
  70    --  Each value in the task control block's Attributes array is either
  71    --  mapped to the attribute value directly if Fast_Path is True, or
  72    --  is in effect a Real_Attribute_Access.
  73    --
  74    --  Note: the Deallocator field must be first, for compatibility with
  75    --  System.Tasking.Task_Attributes.Attribute_Record and to allow unchecked
  76    --  conversions between Attribute_Access and Real_Attribute_Access.
  77
  78    function New_Attribute (Val : Attribute) return Atomic_Address;
  79    --  Create a new Real_Attribute using Val, and return its address. The
  80    --  returned value can be converted via To_Real_Attribute.
  81
  82    procedure Deallocate (Ptr : Atomic_Address);
  83    --  Free memory associated with Ptr, a Real_Attribute_Access in reality
  84
  85    function To_Real_Attribute is new
  86      Ada.Unchecked_Conversion (Atomic_Address, Real_Attribute_Access);
  87
  88    pragma Warnings (Off);
  89    --  Kill warning about possible size mismatch
  90
  91    function To_Address is new
  92      Ada.Unchecked_Conversion (Attribute, Atomic_Address);
  93    function To_Attribute is new
  94      Ada.Unchecked_Conversion (Atomic_Address, Attribute);
  95
  96    pragma Warnings (On);
  97
  98    function To_Address is new
  99      Ada.Unchecked_Conversion (Real_Attribute_Access, Atomic_Address);
 100
 101    pragma Warnings (Off);
 102    --  Kill warning about possible aliasing
 103
 104    function To_Handle is new
 105      Ada.Unchecked_Conversion (System.Address, Attribute_Handle);
 106
 107    pragma Warnings (On);
 108
 109    function To_Task_Id is new
 110      Ada.Unchecked_Conversion (Task_Identification.Task_Id, Task_Id);
 111    --  To access TCB of identified task
 112
 113    procedure Free is new
 114      Ada.Unchecked_Deallocation (Real_Attribute, Real_Attribute_Access);
 115
 116    Fast_Path : constant Boolean :=
 117                  Attribute'Size <= Atomic_Address'Size
 118                    and then Attribute'Alignment <= Atomic_Address'Alignment
 119                    and then To_Address (Initial_Value) = 0;
 120    --  If the attribute fits in an Atomic_Address (both size and alignment)
 121    --  and Initial_Value is 0 (or null), then we will map the attribute
 122    --  directly into ATCB.Attributes (Index), otherwise we will create
 123    --  a level of indirection and instead use Attributes (Index) as a
 124    --  Real_Attribute_Access.
 125
 126    Index : constant Integer :=
 127              Next_Index (Require_Finalization => not Fast_Path);
 128    --  Index in the task control block's Attributes array
 129
 130    --------------
 131    -- Finalize --
 132    --------------
 133
 134    procedure Finalize (Cleanup : in out Attribute_Cleanup) is
 135       pragma Unreferenced (Cleanup);
 136
 137    begin
 138       STPO.Lock_RTS;
 139
 140       declare
 141          C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List;
 142
 143       begin
 144          while C /= null loop
 145             STPO.Write_Lock (C);
 146
 147             if C.Attributes (Index) /= 0
 148               and then Require_Finalization (Index)
 149             then
 150                Deallocate (C.Attributes (Index));
 151                C.Attributes (Index) := 0;
 152             end if;
 153
 154             STPO.Unlock (C);
 155             C := C.Common.All_Tasks_Link;
 156          end loop;
 157       end;
 158
 159       Finalize (Index);
 160       STPO.Unlock_RTS;
 161    end Finalize;
 162
 163    ----------------
 164    -- Deallocate --
 165    ----------------
 166
 167    procedure Deallocate (Ptr : Atomic_Address) is
 168       Obj : Real_Attribute_Access := To_Real_Attribute (Ptr);
 169    begin
 170       Free (Obj);
 171    end Deallocate;
 172
 173    -------------------
 174    -- New_Attribute --
 175    -------------------
 176
 177    function New_Attribute (Val : Attribute) return Atomic_Address is
 178       Tmp : Real_Attribute_Access;
 179    begin
 180       Tmp := new Real_Attribute'(Free  => Deallocate'Unrestricted_Access,
 181                                  Value => Val);
 182       return To_Address (Tmp);
 183    end New_Attribute;
 184
 185    ---------------
 186    -- Reference --
 187    ---------------
 188
 189    function Reference
 190      (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
 191       return Attribute_Handle
 192    is
 193       Self_Id       : Task_Id;
 194       TT            : constant Task_Id := To_Task_Id (T);
 195       Error_Message : constant String  := "trying to get the reference of a ";
 196       Result        : Attribute_Handle;
 197
 198    begin
 199       if TT = null then
 200          raise Program_Error with Error_Message & "null task";
 201       end if;
 202
 203       if TT.Common.State = Terminated then
 204          raise Tasking_Error with Error_Message & "terminated task";
 205       end if;
 206
 207       if Fast_Path then
 208          --  Kill warning about possible alignment mismatch. If this happens,
 209          --  Fast_Path will be False anyway
 210          pragma Warnings (Off);
 211          return To_Handle (TT.Attributes (Index)'Address);
 212          pragma Warnings (On);
 213       else
 214          Self_Id := STPO.Self;
 215          Task_Lock (Self_Id);
 216
 217          if TT.Attributes (Index) = 0 then
 218             TT.Attributes (Index) := New_Attribute (Initial_Value);
 219          end if;
 220
 221          Result := To_Handle
 222            (To_Real_Attribute (TT.Attributes (Index)).Value'Address);
 223          Task_Unlock (Self_Id);
 224
 225          return Result;
 226       end if;
 227    end Reference;
 228
 229    ------------------
 230    -- Reinitialize --
 231    ------------------
 232
 233    procedure Reinitialize
 234      (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
 235    is
 236       Self_Id       : Task_Id;
 237       TT            : constant Task_Id := To_Task_Id (T);
 238       Error_Message : constant String  := "Trying to Reinitialize a ";
 239
 240    begin
 241       if TT = null then
 242          raise Program_Error with Error_Message & "null task";
 243       end if;
 244
 245       if TT.Common.State = Terminated then
 246          raise Tasking_Error with Error_Message & "terminated task";
 247       end if;
 248
 249       if Fast_Path then
 250
 251          --  No finalization needed, simply reset to Initial_Value
 252
 253          TT.Attributes (Index) := To_Address (Initial_Value);
 254
 255       else
 256          Self_Id := STPO.Self;
 257          Task_Lock (Self_Id);
 258
 259          declare
 260             Attr : Atomic_Address renames TT.Attributes (Index);
 261          begin
 262             if Attr /= 0 then
 263                Deallocate (Attr);
 264                Attr := 0;
 265             end if;
 266          end;
 267
 268          Task_Unlock (Self_Id);
 269       end if;
 270    end Reinitialize;
 271
 272    ---------------
 273    -- Set_Value --
 274    ---------------
 275
 276    procedure Set_Value
 277      (Val : Attribute;
 278       T   : Task_Identification.Task_Id := Task_Identification.Current_Task)
 279    is
 280       Self_Id       : Task_Id;
 281       TT            : constant Task_Id := To_Task_Id (T);
 282       Error_Message : constant String  := "trying to set the value of a ";
 283
 284    begin
 285       if TT = null then
 286          raise Program_Error with Error_Message & "null task";
 287       end if;
 288
 289       if TT.Common.State = Terminated then
 290          raise Tasking_Error with Error_Message & "terminated task";
 291       end if;
 292
 293       if Fast_Path then
 294
 295          --  No finalization needed, simply set to Val
 296
 297          TT.Attributes (Index) := To_Address (Val);
 298
 299       else
 300          Self_Id := STPO.Self;
 301          Task_Lock (Self_Id);
 302
 303          declare
 304             Attr : Atomic_Address renames TT.Attributes (Index);
 305
 306          begin
 307             if Attr /= 0 then
 308                Deallocate (Attr);
 309             end if;
 310
 311             Attr := New_Attribute (Val);
 312          end;
 313
 314          Task_Unlock (Self_Id);
 315       end if;
 316    end Set_Value;
 317
 318    -----------
 319    -- Value --
 320    -----------
 321
 322    function Value
 323      (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
 324       return Attribute
 325    is
 326       Self_Id       : Task_Id;
 327       TT            : constant Task_Id := To_Task_Id (T);
 328       Error_Message : constant String  := "trying to get the value of a ";
 329
 330    begin
 331       if TT = null then
 332          raise Program_Error with Error_Message & "null task";
 333       end if;
 334
 335       if TT.Common.State = Terminated then
 336          raise Tasking_Error with Error_Message & "terminated task";
 337       end if;
 338
 339       if Fast_Path then
 340          return To_Attribute (TT.Attributes (Index));
 341
 342       else
 343          Self_Id := STPO.Self;
 344          Task_Lock (Self_Id);
 345
 346          declare
 347             Attr : Atomic_Address renames TT.Attributes (Index);
 348
 349          begin
 350             if Attr = 0 then
 351                Task_Unlock (Self_Id);
 352                return Initial_Value;
 353
 354             else
 355                declare
 356                   Result : constant Attribute :=
 357                              To_Real_Attribute (Attr).Value;
 358                begin
 359                   Task_Unlock (Self_Id);
 360                   return Result;
 361                end;
 362             end if;
 363          end;
 364       end if;
 365    end Value;
 366
 367 end Ada.Task_Attributes;