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