| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME COMPONENTS -- |
| -- -- |
| -- A D A . T A S K _ A T T R I B U T E S -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2014-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
| -- -- |
| -- As a special exception under Section 7 of GPL version 3, you are granted -- |
| -- additional permissions described in the GCC Runtime Library Exception, -- |
| -- version 3.1, as published by the Free Software Foundation. -- |
| -- -- |
| -- You should have received a copy of the GNU General Public License and -- |
| -- a copy of the GCC Runtime Library Exception along with this program; -- |
| -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- |
| -- <http://www.gnu.org/licenses/>. -- |
| -- -- |
| -- GNARL was developed by the GNARL team at Florida State University. -- |
| -- Extensive contributions were provided by Ada Core Technologies, Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with System.Tasking; |
| with System.Tasking.Initialization; |
| with System.Tasking.Task_Attributes; |
| pragma Elaborate_All (System.Tasking.Task_Attributes); |
| |
| with System.Task_Primitives.Operations; |
| |
| with Ada.Finalization; use Ada.Finalization; |
| with Ada.Unchecked_Conversion; |
| with Ada.Unchecked_Deallocation; |
| |
| package body Ada.Task_Attributes is |
| |
| use System, |
| System.Tasking.Initialization, |
| System.Tasking, |
| System.Tasking.Task_Attributes; |
| |
| package STPO renames System.Task_Primitives.Operations; |
| |
| type Attribute_Cleanup is new Limited_Controlled with null record; |
| procedure Finalize (Cleanup : in out Attribute_Cleanup); |
| -- Finalize all tasks' attributes for this package |
| |
| Cleanup : Attribute_Cleanup; |
| pragma Unreferenced (Cleanup); |
| -- Will call Finalize when this instantiation gets out of scope |
| |
| --------------------------- |
| -- Unchecked Conversions -- |
| --------------------------- |
| |
| type Real_Attribute is record |
| Free : Deallocator; |
| Value : Attribute; |
| end record; |
| type Real_Attribute_Access is access all Real_Attribute; |
| pragma No_Strict_Aliasing (Real_Attribute_Access); |
| -- Each value in the task control block's Attributes array is either |
| -- mapped to the attribute value directly if Fast_Path is True, or |
| -- is in effect a Real_Attribute_Access. |
| -- |
| -- Note: the Deallocator field must be first, for compatibility with |
| -- System.Tasking.Task_Attributes.Attribute_Record and to allow unchecked |
| -- conversions between Attribute_Access and Real_Attribute_Access. |
| |
| function New_Attribute (Val : Attribute) return Atomic_Address; |
| -- Create a new Real_Attribute using Val, and return its address. The |
| -- returned value can be converted via To_Real_Attribute. |
| |
| procedure Deallocate (Ptr : Atomic_Address); |
| -- Free memory associated with Ptr, a Real_Attribute_Access in reality |
| |
| function To_Real_Attribute is new |
| Ada.Unchecked_Conversion (Atomic_Address, Real_Attribute_Access); |
| |
| pragma Warnings (Off); |
| -- Kill warning about possible size mismatch |
| |
| function To_Address is new |
| Ada.Unchecked_Conversion (Attribute, Atomic_Address); |
| function To_Attribute is new |
| Ada.Unchecked_Conversion (Atomic_Address, Attribute); |
| |
| type Unsigned is mod 2 ** Integer'Size; |
| function To_Address is new |
| Ada.Unchecked_Conversion (Attribute, System.Address); |
| function To_Unsigned is new |
| Ada.Unchecked_Conversion (Attribute, Unsigned); |
| |
| pragma Warnings (On); |
| |
| function To_Address is new |
| Ada.Unchecked_Conversion (Real_Attribute_Access, Atomic_Address); |
| |
| pragma Warnings (Off); |
| -- Kill warning about possible aliasing |
| |
| function To_Handle is new |
| Ada.Unchecked_Conversion (System.Address, Attribute_Handle); |
| |
| pragma Warnings (On); |
| |
| function To_Task_Id is new |
| Ada.Unchecked_Conversion (Task_Identification.Task_Id, Task_Id); |
| -- To access TCB of identified task |
| |
| procedure Free is new |
| Ada.Unchecked_Deallocation (Real_Attribute, Real_Attribute_Access); |
| |
| Fast_Path : constant Boolean := |
| (Attribute'Size = Integer'Size |
| and then Attribute'Alignment <= Atomic_Address'Alignment |
| and then To_Unsigned (Initial_Value) = 0) |
| or else (Attribute'Size = System.Address'Size |
| and then Attribute'Alignment <= Atomic_Address'Alignment |
| and then To_Address (Initial_Value) = System.Null_Address); |
| -- If the attribute fits in an Atomic_Address (both size and alignment) |
| -- and Initial_Value is 0 (or null), then we will map the attribute |
| -- directly into ATCB.Attributes (Index), otherwise we will create |
| -- a level of indirection and instead use Attributes (Index) as a |
| -- Real_Attribute_Access. |
| |
| Index : constant Integer := |
| Next_Index (Require_Finalization => not Fast_Path); |
| -- Index in the task control block's Attributes array |
| |
| -------------- |
| -- Finalize -- |
| -------------- |
| |
| procedure Finalize (Cleanup : in out Attribute_Cleanup) is |
| pragma Unreferenced (Cleanup); |
| |
| begin |
| STPO.Lock_RTS; |
| |
| declare |
| C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List; |
| |
| begin |
| while C /= null loop |
| STPO.Write_Lock (C); |
| |
| if C.Attributes (Index) /= 0 |
| and then Require_Finalization (Index) |
| then |
| Deallocate (C.Attributes (Index)); |
| C.Attributes (Index) := 0; |
| end if; |
| |
| STPO.Unlock (C); |
| C := C.Common.All_Tasks_Link; |
| end loop; |
| end; |
| |
| Finalize (Index); |
| STPO.Unlock_RTS; |
| end Finalize; |
| |
| ---------------- |
| -- Deallocate -- |
| ---------------- |
| |
| procedure Deallocate (Ptr : Atomic_Address) is |
| Obj : Real_Attribute_Access := To_Real_Attribute (Ptr); |
| begin |
| Free (Obj); |
| end Deallocate; |
| |
| ------------------- |
| -- New_Attribute -- |
| ------------------- |
| |
| function New_Attribute (Val : Attribute) return Atomic_Address is |
| Tmp : Real_Attribute_Access; |
| begin |
| Tmp := new Real_Attribute'(Free => Deallocate'Unrestricted_Access, |
| Value => Val); |
| return To_Address (Tmp); |
| end New_Attribute; |
| |
| --------------- |
| -- Reference -- |
| --------------- |
| |
| function Reference |
| (T : Task_Identification.Task_Id := Task_Identification.Current_Task) |
| return Attribute_Handle |
| is |
| Self_Id : Task_Id; |
| TT : constant Task_Id := To_Task_Id (T); |
| Error_Message : constant String := "trying to get the reference of a "; |
| Result : Attribute_Handle; |
| |
| begin |
| if TT = null then |
| raise Program_Error with Error_Message & "null task"; |
| end if; |
| |
| if TT.Common.State = Terminated then |
| raise Tasking_Error with Error_Message & "terminated task"; |
| end if; |
| |
| if Fast_Path then |
| -- Kill warning about possible alignment mismatch. If this happens, |
| -- Fast_Path will be False anyway |
| pragma Warnings (Off); |
| return To_Handle (TT.Attributes (Index)'Address); |
| pragma Warnings (On); |
| else |
| Self_Id := STPO.Self; |
| Task_Lock (Self_Id); |
| |
| if TT.Attributes (Index) = 0 then |
| TT.Attributes (Index) := New_Attribute (Initial_Value); |
| end if; |
| |
| Result := To_Handle |
| (To_Real_Attribute (TT.Attributes (Index)).Value'Address); |
| Task_Unlock (Self_Id); |
| |
| return Result; |
| end if; |
| end Reference; |
| |
| ------------------ |
| -- Reinitialize -- |
| ------------------ |
| |
| procedure Reinitialize |
| (T : Task_Identification.Task_Id := Task_Identification.Current_Task) |
| is |
| Self_Id : Task_Id; |
| TT : constant Task_Id := To_Task_Id (T); |
| Error_Message : constant String := "Trying to Reinitialize a "; |
| |
| begin |
| if TT = null then |
| raise Program_Error with Error_Message & "null task"; |
| end if; |
| |
| if TT.Common.State = Terminated then |
| raise Tasking_Error with Error_Message & "terminated task"; |
| end if; |
| |
| if Fast_Path then |
| |
| -- No finalization needed, simply reset to Initial_Value |
| |
| TT.Attributes (Index) := To_Address (Initial_Value); |
| |
| else |
| Self_Id := STPO.Self; |
| Task_Lock (Self_Id); |
| |
| declare |
| Attr : Atomic_Address renames TT.Attributes (Index); |
| begin |
| if Attr /= 0 then |
| Deallocate (Attr); |
| Attr := 0; |
| end if; |
| end; |
| |
| Task_Unlock (Self_Id); |
| end if; |
| end Reinitialize; |
| |
| --------------- |
| -- Set_Value -- |
| --------------- |
| |
| procedure Set_Value |
| (Val : Attribute; |
| T : Task_Identification.Task_Id := Task_Identification.Current_Task) |
| is |
| Self_Id : Task_Id; |
| TT : constant Task_Id := To_Task_Id (T); |
| Error_Message : constant String := "trying to set the value of a "; |
| |
| begin |
| if TT = null then |
| raise Program_Error with Error_Message & "null task"; |
| end if; |
| |
| if TT.Common.State = Terminated then |
| raise Tasking_Error with Error_Message & "terminated task"; |
| end if; |
| |
| if Fast_Path then |
| |
| -- No finalization needed, simply set to Val |
| |
| if Attribute'Size = Integer'Size then |
| TT.Attributes (Index) := Atomic_Address (To_Unsigned (Val)); |
| else |
| TT.Attributes (Index) := To_Address (Val); |
| end if; |
| |
| else |
| Self_Id := STPO.Self; |
| Task_Lock (Self_Id); |
| |
| declare |
| Attr : Atomic_Address renames TT.Attributes (Index); |
| |
| begin |
| if Attr /= 0 then |
| Deallocate (Attr); |
| end if; |
| |
| Attr := New_Attribute (Val); |
| end; |
| |
| Task_Unlock (Self_Id); |
| end if; |
| end Set_Value; |
| |
| ----------- |
| -- Value -- |
| ----------- |
| |
| function Value |
| (T : Task_Identification.Task_Id := Task_Identification.Current_Task) |
| return Attribute |
| is |
| Self_Id : Task_Id; |
| TT : constant Task_Id := To_Task_Id (T); |
| Error_Message : constant String := "trying to get the value of a "; |
| |
| begin |
| if TT = null then |
| raise Program_Error with Error_Message & "null task"; |
| end if; |
| |
| if TT.Common.State = Terminated then |
| raise Tasking_Error with Error_Message & "terminated task"; |
| end if; |
| |
| if Fast_Path then |
| return To_Attribute (TT.Attributes (Index)); |
| |
| else |
| Self_Id := STPO.Self; |
| Task_Lock (Self_Id); |
| |
| declare |
| Attr : Atomic_Address renames TT.Attributes (Index); |
| |
| begin |
| if Attr = 0 then |
| Task_Unlock (Self_Id); |
| return Initial_Value; |
| |
| else |
| declare |
| Result : constant Attribute := |
| To_Real_Attribute (Attr).Value; |
| begin |
| Task_Unlock (Self_Id); |
| return Result; |
| end; |
| end if; |
| end; |
| end if; |
| end Value; |
| |
| end Ada.Task_Attributes; |