gcc/ada/libgnarl/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-2024, 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.Storage_Elements;
  33 with System.Tasking;
  34 with System.Tasking.Initialization;
  35 with System.Tasking.Task_Attributes;
  36 pragma Elaborate_All (System.Tasking.Task_Attributes);
  37
  38 with System.Task_Primitives.Operations;
  39
  40 with Ada.Finalization; use Ada.Finalization;
  41 with Ada.Unchecked_Conversion;
  42 with Ada.Unchecked_Deallocation;
  43
  44 package body Ada.Task_Attributes is
  45
  46    use System,
  47        System.Storage_Elements,
  48        System.Tasking.Initialization,
  49        System.Tasking,
  50        System.Tasking.Task_Attributes;
  51
  52    package STPO renames System.Task_Primitives.Operations;
  53
  54    type Attribute_Cleanup is new Limited_Controlled with null record;
  55    procedure Finalize (Cleanup : in out Attribute_Cleanup);
  56    --  Finalize all tasks' attributes for this package
  57
  58    Cleanup : Attribute_Cleanup;
  59    pragma Unreferenced (Cleanup);
  60    --  Will call Finalize when this instantiation gets out of scope
  61
  62    ---------------------------
  63    -- Unchecked Conversions --
  64    ---------------------------
  65
  66    type Real_Attribute is record
  67       Free  : Deallocator;
  68       Value : Attribute;
  69    end record;
  70    type Real_Attribute_Access is access all Real_Attribute;
  71    pragma No_Strict_Aliasing (Real_Attribute_Access);
  72    --  Each value in the task control block's Attributes array is either
  73    --  mapped to the attribute value directly if Fast_Path is True, or
  74    --  is in effect a Real_Attribute_Access.
  75    --
  76    --  Note: the Deallocator field must be first, for compatibility with
  77    --  System.Tasking.Task_Attributes.Attribute_Record and to allow unchecked
  78    --  conversions between Attribute_Access and Real_Attribute_Access.
  79
  80    function New_Attribute (Val : Attribute) return System.Address;
  81    --  Create a new Real_Attribute using Val, and return its address. The
  82    --  returned value can be converted via To_Real_Attribute.
  83
  84    procedure Deallocate (Ptr : System.Address);
  85    --  Free memory associated with Ptr, a Real_Attribute_Access in reality
  86
  87    function To_Real_Attribute is new
  88      Ada.Unchecked_Conversion (System.Address, Real_Attribute_Access);
  89
  90    pragma Warnings (Off);
  91    --  Kill warning about possible size mismatch
  92
  93    function To_Address is new
  94      Ada.Unchecked_Conversion (Attribute, System.Address);
  95    function To_Attribute is new
  96      Ada.Unchecked_Conversion (System.Address, Attribute);
  97
  98    type Unsigned is mod 2 ** Integer'Size;
  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, System.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 <= System.Address'Alignment
 125                    and then To_Unsigned (Initial_Value) = 0)
 126                  or else (Attribute'Size = System.Address'Size
 127                    and then Attribute'Alignment <= System.Address'Alignment
 128                    and then To_Address (Initial_Value) = Null_Address);
 129    --  If the attribute fits in a System.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) /= Null_Address
 157               and then Require_Finalization (Index)
 158             then
 159                Deallocate (C.Attributes (Index));
 160                C.Attributes (Index) := Null_Address;
 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 : System.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 System.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) = Null_Address 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 : System.Address renames TT.Attributes (Index);
 270          begin
 271             if Attr /= Null_Address then
 272                Deallocate (Attr);
 273                Attr := Null_Address;
 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) :=
 308               To_Address (Integer_Address (To_Unsigned (Val)));
 309          else
 310             TT.Attributes (Index) := To_Address (Val);
 311          end if;
 312
 313       else
 314          Self_Id := STPO.Self;
 315          Task_Lock (Self_Id);
 316
 317          declare
 318             Attr : System.Address renames TT.Attributes (Index);
 319
 320          begin
 321             if Attr /= Null_Address then
 322                Deallocate (Attr);
 323             end if;
 324
 325             Attr := New_Attribute (Val);
 326          end;
 327
 328          Task_Unlock (Self_Id);
 329       end if;
 330    end Set_Value;
 331
 332    -----------
 333    -- Value --
 334    -----------
 335
 336    function Value
 337      (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
 338       return Attribute
 339    is
 340       Self_Id       : Task_Id;
 341       TT            : constant Task_Id := To_Task_Id (T);
 342       Error_Message : constant String  := "trying to get the value of a ";
 343
 344    begin
 345       if TT = null then
 346          raise Program_Error with Error_Message & "null task";
 347       end if;
 348
 349       if TT.Common.State = Terminated then
 350          raise Tasking_Error with Error_Message & "terminated task";
 351       end if;
 352
 353       if Fast_Path then
 354          return To_Attribute (TT.Attributes (Index));
 355
 356       else
 357          Self_Id := STPO.Self;
 358          Task_Lock (Self_Id);
 359
 360          declare
 361             Attr : System.Address renames TT.Attributes (Index);
 362
 363          begin
 364             if Attr = Null_Address then
 365                Task_Unlock (Self_Id);
 366                return Initial_Value;
 367
 368             else
 369                declare
 370                   Result : constant Attribute :=
 371                              To_Real_Attribute (Attr).Value;
 372                begin
 373                   Task_Unlock (Self_Id);
 374                   return Result;
 375                end;
 376             end if;
 377          end;
 378       end if;
 379    end Value;
 380
 381 end Ada.Task_Attributes;