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-2016, 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    function To_Address is new
  97      Ada.Unchecked_Conversion (Attribute, System.Address);
  98    function To_Int is new
  99      Ada.Unchecked_Conversion (Attribute, Integer);
 100
 101    pragma Warnings (On);
 102
 103    function To_Address is new
 104      Ada.Unchecked_Conversion (Real_Attribute_Access, Atomic_Address);
 105
 106    pragma Warnings (Off);
 107    --  Kill warning about possible aliasing
 108
 109    function To_Handle is new
 110      Ada.Unchecked_Conversion (System.Address, Attribute_Handle);
 111
 112    pragma Warnings (On);
 113
 114    function To_Task_Id is new
 115      Ada.Unchecked_Conversion (Task_Identification.Task_Id, Task_Id);
 116    --  To access TCB of identified task
 117
 118    procedure Free is new
 119      Ada.Unchecked_Deallocation (Real_Attribute, Real_Attribute_Access);
 120
 121    Fast_Path : constant Boolean :=
 122                  (Attribute'Size = Integer'Size
 123                    and then Attribute'Alignment <= Atomic_Address'Alignment
 124                    and then To_Int (Initial_Value) = 0)
 125                  or else (Attribute'Size = System.Address'Size
 126                    and then Attribute'Alignment <= Atomic_Address'Alignment
 127                    and then To_Address (Initial_Value) = System.Null_Address);
 128    --  If the attribute fits in an Atomic_Address (both size and alignment)
 129    --  and Initial_Value is 0 (or null), then we will map the attribute
 130    --  directly into ATCB.Attributes (Index), otherwise we will create
 131    --  a level of indirection and instead use Attributes (Index) as a
 132    --  Real_Attribute_Access.
 133
 134    Index : constant Integer :=
 135              Next_Index (Require_Finalization => not Fast_Path);
 136    --  Index in the task control block's Attributes array
 137
 138    --------------
 139    -- Finalize --
 140    --------------
 141
 142    procedure Finalize (Cleanup : in out Attribute_Cleanup) is
 143       pragma Unreferenced (Cleanup);
 144
 145    begin
 146       STPO.Lock_RTS;
 147
 148       declare
 149          C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List;
 150
 151       begin
 152          while C /= null loop
 153             STPO.Write_Lock (C);
 154
 155             if C.Attributes (Index) /= 0
 156               and then Require_Finalization (Index)
 157             then
 158                Deallocate (C.Attributes (Index));
 159                C.Attributes (Index) := 0;
 160             end if;
 161
 162             STPO.Unlock (C);
 163             C := C.Common.All_Tasks_Link;
 164          end loop;
 165       end;
 166
 167       Finalize (Index);
 168       STPO.Unlock_RTS;
 169    end Finalize;
 170
 171    ----------------
 172    -- Deallocate --
 173    ----------------
 174
 175    procedure Deallocate (Ptr : Atomic_Address) is
 176       Obj : Real_Attribute_Access := To_Real_Attribute (Ptr);
 177    begin
 178       Free (Obj);
 179    end Deallocate;
 180
 181    -------------------
 182    -- New_Attribute --
 183    -------------------
 184
 185    function New_Attribute (Val : Attribute) return Atomic_Address is
 186       Tmp : Real_Attribute_Access;
 187    begin
 188       Tmp := new Real_Attribute'(Free  => Deallocate'Unrestricted_Access,
 189                                  Value => Val);
 190       return To_Address (Tmp);
 191    end New_Attribute;
 192
 193    ---------------
 194    -- Reference --
 195    ---------------
 196
 197    function Reference
 198      (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
 199       return Attribute_Handle
 200    is
 201       Self_Id       : Task_Id;
 202       TT            : constant Task_Id := To_Task_Id (T);
 203       Error_Message : constant String  := "trying to get the reference of a ";
 204       Result        : Attribute_Handle;
 205
 206    begin
 207       if TT = null then
 208          raise Program_Error with Error_Message & "null task";
 209       end if;
 210
 211       if TT.Common.State = Terminated then
 212          raise Tasking_Error with Error_Message & "terminated task";
 213       end if;
 214
 215       if Fast_Path then
 216          --  Kill warning about possible alignment mismatch. If this happens,
 217          --  Fast_Path will be False anyway
 218          pragma Warnings (Off);
 219          return To_Handle (TT.Attributes (Index)'Address);
 220          pragma Warnings (On);
 221       else
 222          Self_Id := STPO.Self;
 223          Task_Lock (Self_Id);
 224
 225          if TT.Attributes (Index) = 0 then
 226             TT.Attributes (Index) := New_Attribute (Initial_Value);
 227          end if;
 228
 229          Result := To_Handle
 230            (To_Real_Attribute (TT.Attributes (Index)).Value'Address);
 231          Task_Unlock (Self_Id);
 232
 233          return Result;
 234       end if;
 235    end Reference;
 236
 237    ------------------
 238    -- Reinitialize --
 239    ------------------
 240
 241    procedure Reinitialize
 242      (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
 243    is
 244       Self_Id       : Task_Id;
 245       TT            : constant Task_Id := To_Task_Id (T);
 246       Error_Message : constant String  := "Trying to Reinitialize a ";
 247
 248    begin
 249       if TT = null then
 250          raise Program_Error with Error_Message & "null task";
 251       end if;
 252
 253       if TT.Common.State = Terminated then
 254          raise Tasking_Error with Error_Message & "terminated task";
 255       end if;
 256
 257       if Fast_Path then
 258
 259          --  No finalization needed, simply reset to Initial_Value
 260
 261          TT.Attributes (Index) := To_Address (Initial_Value);
 262
 263       else
 264          Self_Id := STPO.Self;
 265          Task_Lock (Self_Id);
 266
 267          declare
 268             Attr : Atomic_Address renames TT.Attributes (Index);
 269          begin
 270             if Attr /= 0 then
 271                Deallocate (Attr);
 272                Attr := 0;
 273             end if;
 274          end;
 275
 276          Task_Unlock (Self_Id);
 277       end if;
 278    end Reinitialize;
 279
 280    ---------------
 281    -- Set_Value --
 282    ---------------
 283
 284    procedure Set_Value
 285      (Val : Attribute;
 286       T   : Task_Identification.Task_Id := Task_Identification.Current_Task)
 287    is
 288       Self_Id       : Task_Id;
 289       TT            : constant Task_Id := To_Task_Id (T);
 290       Error_Message : constant String  := "trying to set the value of a ";
 291
 292    begin
 293       if TT = null then
 294          raise Program_Error with Error_Message & "null task";
 295       end if;
 296
 297       if TT.Common.State = Terminated then
 298          raise Tasking_Error with Error_Message & "terminated task";
 299       end if;
 300
 301       if Fast_Path then
 302
 303          --  No finalization needed, simply set to Val
 304
 305          TT.Attributes (Index) := To_Address (Val);
 306
 307       else
 308          Self_Id := STPO.Self;
 309          Task_Lock (Self_Id);
 310
 311          declare
 312             Attr : Atomic_Address renames TT.Attributes (Index);
 313
 314          begin
 315             if Attr /= 0 then
 316                Deallocate (Attr);
 317             end if;
 318
 319             Attr := New_Attribute (Val);
 320          end;
 321
 322          Task_Unlock (Self_Id);
 323       end if;
 324    end Set_Value;
 325
 326    -----------
 327    -- Value --
 328    -----------
 329
 330    function Value
 331      (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
 332       return Attribute
 333    is
 334       Self_Id       : Task_Id;
 335       TT            : constant Task_Id := To_Task_Id (T);
 336       Error_Message : constant String  := "trying to get the value of a ";
 337
 338    begin
 339       if TT = null then
 340          raise Program_Error with Error_Message & "null task";
 341       end if;
 342
 343       if TT.Common.State = Terminated then
 344          raise Tasking_Error with Error_Message & "terminated task";
 345       end if;
 346
 347       if Fast_Path then
 348          return To_Attribute (TT.Attributes (Index));
 349
 350       else
 351          Self_Id := STPO.Self;
 352          Task_Lock (Self_Id);
 353
 354          declare
 355             Attr : Atomic_Address renames TT.Attributes (Index);
 356
 357          begin
 358             if Attr = 0 then
 359                Task_Unlock (Self_Id);
 360                return Initial_Value;
 361
 362             else
 363                declare
 364                   Result : constant Attribute :=
 365                              To_Real_Attribute (Attr).Value;
 366                begin
 367                   Task_Unlock (Self_Id);
 368                   return Result;
 369                end;
 370             end if;
 371          end;
 372       end if;
 373    end Value;
 374
 375 end Ada.Task_Attributes;