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 32with System.Tasking; 33with System.Tasking.Initialization; 34with System.Tasking.Task_Attributes; 35pragma Elaborate_All (System.Tasking.Task_Attributes); 36 37with System.Task_Primitives.Operations; 38 39with Ada.Finalization; use Ada.Finalization; 40with Ada.Unchecked_Conversion; 41with Ada.Unchecked_Deallocation; 42 43package 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 367end Ada.Task_Attributes; 368