368 lines
12 KiB
Ada
368 lines
12 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- 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, 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);
|
|
|
|
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 <= Atomic_Address'Size
|
|
and then Attribute'Alignment <= Atomic_Address'Alignment
|
|
and then To_Address (Initial_Value) = 0;
|
|
-- 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
|
|
|
|
TT.Attributes (Index) := To_Address (Val);
|
|
|
|
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;
|