===================================================================
@@ -1363,59 +1363,54 @@
-- Build_Entry_Names --
-----------------------
- function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id is
- Loc : constant Source_Ptr := Sloc (Conc_Typ);
- B_Decls : List_Id;
- B_Stmts : List_Id;
- Comp : Node_Id;
- Index : Entity_Id;
- Index_Typ : RE_Id;
- Typ : Entity_Id := Conc_Typ;
+ procedure Build_Entry_Names
+ (Obj_Ref : Node_Id;
+ Obj_Typ : Entity_Id;
+ Stmts : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Obj_Ref);
+ Data : Entity_Id := Empty;
+ Index : Entity_Id := Empty;
+ Typ : Entity_Id := Obj_Typ;
- procedure Build_Entry_Family_Name (Id : Entity_Id);
- -- Generate:
- -- for Lnn in Family_Low .. Family_High loop
- -- Inn := Inn + 1;
- -- Set_Entry_Name
- -- (_init._object <or> _init._task_id,
- -- Inn,
- -- new String ("<Entry name>(" & Lnn'Img & ")"));
- -- end loop;
- -- Note that the bounds of the range may reference discriminants. The
- -- above construct is added directly to the statements of the block.
+ procedure Build_Entry_Name (Comp_Id : Entity_Id);
+ -- Given an entry [family], create a static string which denotes the
+ -- name of Comp_Id and assign it to the underlying data structure which
+ -- contains the entry names of a concurrent object.
- procedure Build_Entry_Name (Id : Entity_Id);
- -- Generate:
- -- Inn := Inn + 1;
- -- Set_Entry_Name
- -- (_init._object <or>_init._task_id,
- -- Inn,
- -- new String ("<Entry name>");
- -- The above construct is added directly to the statements of the block.
+ function Object_Reference return Node_Id;
+ -- Return a reference to field _object or _task_id depending on the
+ -- concurrent object being processed.
- function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id;
- -- Generate the call to the runtime routine Set_Entry_Name with actuals
- -- _init._task_id or _init._object, Inn and Arg3.
+ ----------------------
+ -- Build_Entry_Name --
+ ----------------------
- procedure Increment_Index (Stmts : List_Id);
- -- Generate the following and add it to Stmts
- -- Inn := Inn + 1;
-
- -----------------------------
- -- Build_Entry_Family_Name --
- -----------------------------
-
- procedure Build_Entry_Family_Name (Id : Entity_Id) is
- Def : constant Node_Id :=
- Discrete_Subtype_Definition (Parent (Id));
- L_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
- L_Stmts : constant List_Id := New_List;
- Val : Node_Id;
-
+ procedure Build_Entry_Name (Comp_Id : Entity_Id) is
function Build_Range (Def : Node_Id) return Node_Id;
-- Given a discrete subtype definition of an entry family, generate a
-- range node which covers the range of Def's type.
+ procedure Create_Index_And_Data;
+ -- Generate the declarations of variables Index and Data. Subsequent
+ -- calls do nothing.
+
+ function Increment_Index return Node_Id;
+ -- Increment the index used in the assignment of string names to the
+ -- Data array.
+
+ function Name_Declaration (Def_Id : Entity_Id) return Node_Id;
+ -- Given the name of a temporary variable, create the following
+ -- declaration for it:
+ --
+ -- Def_Id : aliased constant String := <String_Name_From_Buffer>;
+
+ function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id;
+ -- Given the name of a temporary variable, place it in the array of
+ -- string names. Generate:
+ --
+ -- Data (Index) := Def_Id'Unchecked_Access;
+
-----------------
-- Build_Range --
-----------------
@@ -1432,7 +1427,10 @@
if Is_Entity_Name (Low)
and then Ekind (Entity (Low)) = E_Discriminant
then
- Low := Make_Identifier (Loc, Chars (Low));
+ Low :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Obj_Ref),
+ Selector_Name => Make_Identifier (Loc, Chars (Low)));
else
Low := New_Copy_Tree (Low);
end if;
@@ -1440,7 +1438,10 @@
if Is_Entity_Name (High)
and then Ekind (Entity (High)) = E_Discriminant
then
- High := Make_Identifier (Loc, Chars (High));
+ High :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Obj_Ref),
+ Selector_Name => Make_Identifier (Loc, Chars (High)));
else
High := New_Copy_Tree (High);
end if;
@@ -1451,150 +1452,239 @@
High_Bound => High);
end Build_Range;
- -- Start of processing for Build_Entry_Family_Name
+ ---------------------------
+ -- Create_Index_And_Data --
+ ---------------------------
- begin
- Get_Name_String (Chars (Id));
+ procedure Create_Index_And_Data is
+ begin
+ if No (Index) and then No (Data) then
+ declare
+ Count : RE_Id;
+ Data_Typ : RE_Id;
+ Index_Typ : RE_Id;
+ Size : Entity_Id;
- -- Add a leading '('
+ begin
+ if Is_Protected_Type (Typ) then
+ Count := RO_PE_Number_Of_Entries;
+ Data_Typ := RE_Protected_Entry_Names_Array;
+ Index_Typ := RE_Protected_Entry_Index;
+ else
+ Count := RO_ST_Number_Of_Entries;
+ Data_Typ := RE_Task_Entry_Names_Array;
+ Index_Typ := RE_Task_Entry_Index;
+ end if;
- Add_Char_To_Name_Buffer ('(');
+ -- Step 1: Generate the declaration of the index variable:
- -- Generate:
- -- new String'("<Entry name>(" & Lnn'Img & ")");
+ -- Index : <Index_Typ> := 1;
- -- This is an implicit heap allocation, and Comes_From_Source is
- -- False, which ensures that it will get flagged as a violation of
- -- No_Implicit_Heap_Allocations when that restriction applies.
+ Index := Make_Temporary (Loc, 'I');
- Val :=
- Make_Allocator (Loc,
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Reference_To (Standard_String, Loc),
- Expression =>
- Make_Op_Concat (Loc,
- Left_Opnd =>
- Make_Op_Concat (Loc,
- Left_Opnd =>
- Make_String_Literal (Loc,
- Strval => String_From_Name_Buffer),
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Reference_To (L_Id, Loc),
- Attribute_Name => Name_Img)),
- Right_Opnd =>
- Make_String_Literal (Loc,
- Strval => ")"))));
+ Append_To (Stmts,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Index,
+ Object_Definition =>
+ New_Reference_To (RTE (Index_Typ), Loc),
+ Expression => Make_Integer_Literal (Loc, 1)));
- Increment_Index (L_Stmts);
- Append_To (L_Stmts, Build_Set_Entry_Name_Call (Val));
+ -- Step 2: Generate the declaration of an array to house all
+ -- names:
- -- Generate:
- -- for Lnn in Family_Low .. Family_High loop
- -- Inn := Inn + 1;
- -- Set_Entry_Name
- -- (_init._object <or> _init._task_id, Inn, <Val>);
- -- end loop;
+ -- Size : constant <Index_Typ> := <Count> (Obj_Ref);
+ -- Data : aliased <Data_Typ> := (1 .. Size => null);
- Append_To (B_Stmts,
- Make_Loop_Statement (Loc,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => L_Id,
- Discrete_Subtype_Definition => Build_Range (Def))),
- Statements => L_Stmts,
- End_Label => Empty));
- end Build_Entry_Family_Name;
+ Size := Make_Temporary (Loc, 'S');
- ----------------------
- -- Build_Entry_Name --
- ----------------------
+ Append_To (Stmts,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Size,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (Index_Typ), Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (Count), Loc),
+ Parameter_Associations =>
+ New_List (Object_Reference))));
- procedure Build_Entry_Name (Id : Entity_Id) is
- Val : Node_Id;
+ Data := Make_Temporary (Loc, 'A');
+ Append_To (Stmts,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Data,
+ Aliased_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (Data_Typ), Loc),
+ Expression =>
+ Make_Aggregate (Loc,
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => New_Reference_To (Size, Loc))),
+ Expression => Make_Null (Loc))))));
+ end;
+ end if;
+ end Create_Index_And_Data;
+
+ ---------------------
+ -- Increment_Index --
+ ---------------------
+
+ function Increment_Index return Node_Id is
+ begin
+ return
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Index, Loc),
+ Expression =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Reference_To (Index, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)));
+ end Increment_Index;
+
+ ----------------------
+ -- Name_Declaration --
+ ----------------------
+
+ function Name_Declaration (Def_Id : Entity_Id) return Node_Id is
+ begin
+ return
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Aliased_Present => True,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc, String_From_Name_Buffer));
+ end Name_Declaration;
+
+ --------------------
+ -- Set_Entry_Name --
+ --------------------
+
+ function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id is
+ begin
+ return
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Reference_To (Data, Loc),
+ Expressions => New_List (New_Reference_To (Index, Loc))),
+
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Def_Id, Loc),
+ Attribute_Name => Name_Unchecked_Access));
+ end Set_Entry_Name;
+
+ -- Local variables
+
+ Temp_Id : Entity_Id;
+ Subt_Def : Node_Id;
+
+ -- Start of processing for Build_Entry_Name
+
begin
- Get_Name_String (Chars (Id));
+ if Ekind (Comp_Id) = E_Entry_Family then
+ Subt_Def := Discrete_Subtype_Definition (Parent (Comp_Id));
- -- This is an implicit heap allocation, and Comes_From_Source is
- -- False, which ensures that it will get flagged as a violation of
- -- No_Implicit_Heap_Allocations when that restriction applies.
+ Create_Index_And_Data;
- Val :=
- Make_Allocator (Loc,
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Reference_To (Standard_String, Loc),
- Expression =>
- Make_String_Literal (Loc,
- String_From_Name_Buffer)));
+ -- Step 1: Create the string name of the entry family.
+ -- Generate:
+ -- Temp : aliased constant String := "name ()";
- Increment_Index (B_Stmts);
- Append_To (B_Stmts, Build_Set_Entry_Name_Call (Val));
+ Temp_Id := Make_Temporary (Loc, 'S');
+ Get_Name_String (Chars (Comp_Id));
+ Add_Char_To_Name_Buffer (' ');
+ Add_Char_To_Name_Buffer ('(');
+ Add_Char_To_Name_Buffer (')');
+
+ Append_To (Stmts, Name_Declaration (Temp_Id));
+
+ -- Generate:
+ -- for Member in Family_Low .. Family_High loop
+ -- Set_Entry_Name (...);
+ -- Index := Index + 1;
+ -- end loop;
+
+ Append_To (Stmts,
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Temporary (Loc, 'L'),
+ Discrete_Subtype_Definition =>
+ Build_Range (Subt_Def))),
+
+ Statements => New_List (
+ Set_Entry_Name (Temp_Id),
+ Increment_Index),
+ End_Label => Empty));
+
+ -- Entry
+
+ else
+ Create_Index_And_Data;
+
+ -- Step 1: Create the string name of the entry. Generate:
+ -- Temp : aliased constant String := "name";
+
+ Temp_Id := Make_Temporary (Loc, 'S');
+ Get_Name_String (Chars (Comp_Id));
+
+ Append_To (Stmts, Name_Declaration (Temp_Id));
+
+ -- Step 2: Associate the string name with the underlying data
+ -- structure.
+
+ Append_To (Stmts, Set_Entry_Name (Temp_Id));
+ Append_To (Stmts, Increment_Index);
+ end if;
end Build_Entry_Name;
- -------------------------------
- -- Build_Set_Entry_Name_Call --
- -------------------------------
+ ----------------------
+ -- Object_Reference --
+ ----------------------
- function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id is
- Arg1 : Name_Id;
- Proc : RE_Id;
+ function Object_Reference return Node_Id is
+ Conc_Typ : constant Entity_Id := Corresponding_Record_Type (Typ);
+ Field : Name_Id;
+ Ref : Node_Id;
begin
- -- Determine the proper name for the first argument and the RTS
- -- routine to call.
-
if Is_Protected_Type (Typ) then
- Arg1 := Name_uObject;
- Proc := RO_PE_Set_Entry_Name;
-
- else pragma Assert (Is_Task_Type (Typ));
- Arg1 := Name_uTask_Id;
- Proc := RO_TS_Set_Entry_Name;
+ Field := Name_uObject;
+ else
+ Field := Name_uTask_Id;
end if;
- -- Generate:
- -- Set_Entry_Name (_init.Arg1, Inn, Arg3);
+ Ref :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Conc_Typ, New_Copy_Tree (Obj_Ref)),
+ Selector_Name => Make_Identifier (Loc, Field));
- return
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (Proc), Loc),
- Parameter_Associations => New_List (
- Make_Selected_Component (Loc, -- _init._object
- Prefix => -- _init._task_id
- Make_Identifier (Loc, Name_uInit),
- Selector_Name =>
- Make_Identifier (Loc, Arg1)),
- New_Reference_To (Index, Loc), -- Inn
- Arg3)); -- Val
- end Build_Set_Entry_Name_Call;
+ if Is_Protected_Type (Typ) then
+ Ref :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Ref,
+ Attribute_Name => Name_Unchecked_Access);
+ end if;
- ---------------------
- -- Increment_Index --
- ---------------------
+ return Ref;
+ end Object_Reference;
- procedure Increment_Index (Stmts : List_Id) is
- begin
- -- Generate:
- -- Inn := Inn + 1;
+ -- Local variables
- Append_To (Stmts,
- Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To (Index, Loc),
- Expression =>
- Make_Op_Add (Loc,
- Left_Opnd =>
- New_Reference_To (Index, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc, 1))));
- end Increment_Index;
+ Comp : Node_Id;
+ Proc : RE_Id;
-- Start of processing for Build_Entry_Names
@@ -1605,67 +1695,57 @@
Typ := Corresponding_Concurrent_Type (Typ);
end if;
- pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
+ pragma Assert (Is_Concurrent_Type (Typ));
-- Nothing to do if the type has no entries
if not Has_Entries (Typ) then
- return Empty;
+ return;
end if;
-- Avoid generating entry names for a protected type with only one entry
if Is_Protected_Type (Typ)
- and then Find_Protection_Type (Typ) /= RTE (RE_Protection_Entries)
+ and then Find_Protection_Type (Base_Type (Typ)) /=
+ RTE (RE_Protection_Entries)
then
- return Empty;
+ return;
end if;
- Index := Make_Temporary (Loc, 'I');
+ -- Step 1: Populate the array with statically generated strings denoting
+ -- entries and entry family names.
- -- Step 1: Generate the declaration of the index variable:
- -- Inn : Protected_Entry_Index := 0;
- -- or
- -- Inn : Task_Entry_Index := 0;
-
- if Is_Protected_Type (Typ) then
- Index_Typ := RE_Protected_Entry_Index;
- else
- Index_Typ := RE_Task_Entry_Index;
- end if;
-
- B_Decls := New_List;
- Append_To (B_Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Index,
- Object_Definition => New_Reference_To (RTE (Index_Typ), Loc),
- Expression => Make_Integer_Literal (Loc, 0)));
-
- B_Stmts := New_List;
-
- -- Step 2: Generate a call to Set_Entry_Name for each entry and entry
- -- family member.
-
Comp := First_Entity (Typ);
while Present (Comp) loop
- if Ekind (Comp) = E_Entry then
+ if Comes_From_Source (Comp)
+ and then Ekind_In (Comp, E_Entry, E_Entry_Family)
+ then
Build_Entry_Name (Comp);
-
- elsif Ekind (Comp) = E_Entry_Family then
- Build_Entry_Family_Name (Comp);
end if;
Next_Entity (Comp);
end loop;
- -- Step 3: Wrap the statements in a block
+ -- Step 2: Associate the array with the related concurrent object:
- return
- Make_Block_Statement (Loc,
- Declarations => B_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => B_Stmts));
+ -- Set_Entry_Names (Obj_Ref, <Data>'Unchecked_Access);
+
+ if Present (Data) then
+ if Is_Protected_Type (Typ) then
+ Proc := RO_PE_Set_Entry_Names;
+ else
+ Proc := RO_ST_Set_Entry_Names;
+ end if;
+
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (Proc), Loc),
+ Parameter_Associations => New_List (
+ Object_Reference,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Data, Loc),
+ Attribute_Name => Name_Unchecked_Access))));
+ end if;
end Build_Entry_Names;
---------------------------
@@ -13505,20 +13585,6 @@
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (P_Arr, Loc),
Attribute_Name => Name_Unrestricted_Access));
-
- -- Build_Entry_Names generation flag. When set to true,
- -- the runtime will allocate an array to hold the string
- -- names of protected entries.
-
- if not Restricted_Profile then
- if Entry_Names_OK then
- Append_To (Args,
- New_Reference_To (Standard_True, Loc));
- else
- Append_To (Args,
- New_Reference_To (Standard_False, Loc));
- end if;
- end if;
end if;
elsif Pkg_Id =
@@ -13529,7 +13595,6 @@
elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
Append_To (Args, Make_Null (Loc));
Append_To (Args, Make_Null (Loc));
- Append_To (Args, New_Reference_To (Standard_False, Loc));
end if;
Append_To (L,
@@ -13953,16 +14018,6 @@
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)));
- -- Build_Entry_Names generation flag. When set to true, the runtime
- -- will allocate an array to hold the string names of task entries.
-
- if not Restricted_Profile then
- Append_To (Args,
- New_Reference_To
- (Boolean_Literals (Has_Entries (Ttyp) and then Entry_Names_OK),
- Loc));
- end if;
-
if Restricted_Profile then
Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc);
else
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2012, 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- --
@@ -55,10 +55,15 @@
-- interface, ensure that the designated type has a _master and generate
-- a renaming of the said master to service the access type.
- function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id;
- -- Create the statements which populate the entry names array of a task or
- -- protected type. The statements are wrapped inside a block due to a local
- -- declaration.
+ procedure Build_Entry_Names
+ (Obj_Ref : Node_Id;
+ Obj_Typ : Entity_Id;
+ Stmts : List_Id);
+ -- Given a concurrent object, create static string names for all entries
+ -- and entry families. Associate each name with the Protection_Entries or
+ -- ATCB field of the object. Obj_Ref is a reference to the concurrent
+ -- object. Obj_Typ is the type of the object. Stmts is the list where all
+ -- generated code is attached.
procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id);
-- Given the name of an object or a type which is either a task, contains
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1998-2012, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@@ -41,8 +41,6 @@
-- Note: the compiler generates direct calls to this interface, via Rtsfind
-with Ada.Unchecked_Deallocation;
-
with System.Task_Primitives.Operations;
with System.Restrictions;
with System.Parameters;
@@ -58,13 +56,6 @@
use Parameters;
use Task_Primitives.Operations;
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Free_Entry_Names (Object : Protection_Entries);
- -- Deallocate all string names associated with protected entries
-
----------------
-- Local Data --
----------------
@@ -141,8 +132,6 @@
end loop;
end loop;
- Free_Entry_Names (Object);
-
Object.Finalized := True;
if Single_Lock then
@@ -154,26 +143,6 @@
STPO.Finalize_Lock (Object.L'Unrestricted_Access);
end Finalize;
- ----------------------
- -- Free_Entry_Names --
- ----------------------
-
- procedure Free_Entry_Names (Object : Protection_Entries) is
- Names : Entry_Names_Array_Access := Object.Entry_Names;
-
- procedure Free_Entry_Names_Array_Access is new
- Ada.Unchecked_Deallocation
- (Entry_Names_Array, Entry_Names_Array_Access);
-
- begin
- if Names = null then
- return;
- end if;
-
- Free_Entry_Names_Array (Names.all);
- Free_Entry_Names_Array_Access (Names);
- end Free_Entry_Names;
-
-----------------
-- Get_Ceiling --
-----------------
@@ -202,12 +171,11 @@
-----------------------------------
procedure Initialize_Protection_Entries
- (Object : Protection_Entries_Access;
- Ceiling_Priority : Integer;
- Compiler_Info : System.Address;
- Entry_Bodies : Protected_Entry_Body_Access;
- Find_Body_Index : Find_Body_Index_Access;
- Build_Entry_Names : Boolean)
+ (Object : Protection_Entries_Access;
+ Ceiling_Priority : Integer;
+ Compiler_Info : System.Address;
+ Entry_Bodies : Protected_Entry_Body_Access;
+ Find_Body_Index : Find_Body_Index_Access)
is
Init_Priority : Integer := Ceiling_Priority;
Self_ID : constant Task_Id := STPO.Self;
@@ -250,11 +218,6 @@
Object.Entry_Queues (E).Head := null;
Object.Entry_Queues (E).Tail := null;
end loop;
-
- if Build_Entry_Names then
- Object.Entry_Names :=
- new Entry_Names_Array (1 .. Entry_Index (Object.Num_Entries));
- end if;
end Initialize_Protection_Entries;
------------------
@@ -391,6 +354,17 @@
end if;
end Lock_Read_Only_Entries;
+ -----------------------
+ -- Number_Of_Entries --
+ -----------------------
+
+ function Number_Of_Entries
+ (Object : Protection_Entries_Access) return Protected_Entry_Index
+ is
+ begin
+ return Object.Num_Entries;
+ end Number_Of_Entries;
+
-----------------
-- Set_Ceiling --
-----------------
@@ -402,21 +376,18 @@
Object.New_Ceiling := Prio;
end Set_Ceiling;
- --------------------
- -- Set_Entry_Name --
- --------------------
+ ---------------------
+ -- Set_Entry_Names --
+ ---------------------
- procedure Set_Entry_Name
- (Object : Protection_Entries'Class;
- Pos : Protected_Entry_Index;
- Val : String_Access)
+ procedure Set_Entry_Names
+ (Object : Protection_Entries_Access;
+ Names : Protected_Entry_Names_Access)
is
begin
- pragma Assert (Object.Entry_Names /= null);
+ Object.Entry_Names := Names;
+ end Set_Entry_Names;
- Object.Entry_Names (Entry_Index (Pos)) := Val;
- end Set_Entry_Name;
-
--------------------
-- Unlock_Entries --
--------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@@ -67,6 +67,14 @@
type Protected_Entry_Queue_Array is
array (Protected_Entry_Index range <>) of Entry_Queue;
+ -- A data structure which contains the string names of entries and entry
+ -- family members.
+
+ type Protected_Entry_Names_Array is
+ array (Protected_Entry_Index range <>) of String_Access;
+
+ type Protected_Entry_Names_Access is access all Protected_Entry_Names_Array;
+
-- This type contains the GNARL state of a protected object. The
-- application-defined portion of the state (i.e. private objects)
-- is maintained by the compiler-generated code.
@@ -136,7 +144,7 @@
Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries);
- Entry_Names : Entry_Names_Array_Access := null;
+ Entry_Names : Protected_Entry_Names_Access := null;
-- An array of string names which denotes entry [family member] names.
-- The structure is indexed by protected entry index and contains Num_
-- Entries components.
@@ -167,12 +175,11 @@
-- System.Tasking.Protected_Objects.Initialize_Protection.
procedure Initialize_Protection_Entries
- (Object : Protection_Entries_Access;
- Ceiling_Priority : Integer;
- Compiler_Info : System.Address;
- Entry_Bodies : Protected_Entry_Body_Access;
- Find_Body_Index : Find_Body_Index_Access;
- Build_Entry_Names : Boolean);
+ (Object : Protection_Entries_Access;
+ Ceiling_Priority : Integer;
+ Compiler_Info : System.Address;
+ Entry_Bodies : Protected_Entry_Body_Access;
+ Find_Body_Index : Find_Body_Index_Access);
-- Initialize the Object parameter so that it can be used by the runtime
-- to keep track of the runtime state of a protected object.
@@ -201,17 +208,20 @@
-- possible future use. At the current time, everyone uses Lock for both
-- read and write locks.
+ function Number_Of_Entries
+ (Object : Protection_Entries_Access) return Protected_Entry_Index;
+ -- Return the number of entries of a protected object
+
procedure Set_Ceiling
(Object : Protection_Entries_Access;
Prio : System.Any_Priority);
-- Sets the new ceiling priority of the protected object
- procedure Set_Entry_Name
- (Object : Protection_Entries'Class;
- Pos : Protected_Entry_Index;
- Val : String_Access);
- -- This is called by the compiler to map a string which denotes an entry
- -- name to a protected entry index.
+ procedure Set_Entry_Names
+ (Object : Protection_Entries_Access;
+ Names : Protected_Entry_Names_Access);
+ -- Associate an array of string that denote entry [family] names with a
+ -- protected object.
procedure Unlock_Entries (Object : Protection_Entries_Access);
-- Relinquish ownership of the lock for the object represented by the
===================================================================
@@ -91,9 +91,6 @@
procedure Free is new
Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
- procedure Free_Entry_Names (T : Task_Id);
- -- Deallocate all string names associated with task entries
-
procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id);
-- This procedure outputs the task specific message for exception
-- tracing purposes.
@@ -487,8 +484,7 @@
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
Task_Image : String;
- Created_Task : out Task_Id;
- Build_Entry_Names : Boolean)
+ Created_Task : out Task_Id)
is
T, P : Task_Id;
Self_ID : constant Task_Id := STPO.Self;
@@ -706,14 +702,6 @@
Dispatching_Domain_Tasks (Base_CPU) + 1;
end if;
- -- Note: we should not call 'new' while holding locks since new may use
- -- locks (e.g. RTS_Lock under Windows) itself and cause a deadlock.
-
- if Build_Entry_Names then
- T.Entry_Names :=
- new Entry_Names_Array (1 .. Entry_Index (Num_Entries));
- end if;
-
-- Create TSD as early as possible in the creation of a task, since it
-- may be used by the operation of Ada code within the task.
@@ -942,26 +930,6 @@
end Finalize_Global_Tasks;
- ----------------------
- -- Free_Entry_Names --
- ----------------------
-
- procedure Free_Entry_Names (T : Task_Id) is
- Names : Entry_Names_Array_Access := T.Entry_Names;
-
- procedure Free_Entry_Names_Array_Access is new
- Ada.Unchecked_Deallocation
- (Entry_Names_Array, Entry_Names_Array_Access);
-
- begin
- if Names = null then
- return;
- end if;
-
- Free_Entry_Names_Array (Names.all);
- Free_Entry_Names_Array_Access (Names);
- end Free_Entry_Names;
-
---------------
-- Free_Task --
---------------
@@ -983,7 +951,6 @@
Initialization.Task_Unlock (Self_Id);
- Free_Entry_Names (T);
System.Task_Primitives.Operations.Finalize_TCB (T);
else
@@ -1041,23 +1008,6 @@
Initialization.Undefer_Abort (Self_ID);
end Move_Activation_Chain;
- -- Compiler interface only. Do not call from within the RTS
-
- --------------------
- -- Set_Entry_Name --
- --------------------
-
- procedure Set_Entry_Name
- (T : Task_Id;
- Pos : Task_Entry_Index;
- Val : String_Access)
- is
- begin
- pragma Assert (T.Entry_Names /= null);
-
- T.Entry_Names (Entry_Index (Pos)) := Val;
- end Set_Entry_Name;
-
------------------
-- Task_Wrapper --
------------------
@@ -2119,7 +2069,6 @@
Unlock_RTS;
end if;
- Free_Entry_Names (T);
System.Task_Primitives.Operations.Finalize_TCB (T);
end Vulnerable_Free_Task;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@@ -180,8 +180,7 @@
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
Task_Image : String;
- Created_Task : out Task_Id;
- Build_Entry_Names : Boolean);
+ Created_Task : out Task_Id);
-- Compiler interface only. Do not call from within the RTS.
-- This must be called to create a new task.
--
@@ -212,8 +211,6 @@
-- run time can store to ease the debugging and the
-- Ada.Task_Identification facility.
-- Created_Task is the resulting task.
- -- Build_Entry_Names is a flag which controls the allocation of the data
- -- structure which stores all entry names.
--
-- This procedure can raise Storage_Error if the task creation failed.
@@ -285,13 +282,6 @@
-- that doesn't happen, they will never be activated, and will become
-- terminated on leaving the return statement.
- procedure Set_Entry_Name
- (T : Task_Id;
- Pos : Task_Entry_Index;
- Val : String_Access);
- -- This is called by the compiler to map a string which denotes an entry
- -- name to a task entry index.
-
function Terminated (T : Task_Id) return Boolean;
-- This is called by the compiler to implement the 'Terminated attribute.
-- Though is not required to be so by the ARM, we choose to synchronize
===================================================================
@@ -1502,6 +1502,9 @@
RE_Unspecified_Task_Info, -- System.Task_Info
RE_Task_Procedure_Access, -- System.Tasking
+ RE_Task_Entry_Names_Array, -- System.Tasking
+ RO_ST_Number_Of_Entries, -- System.Tasking
+ RO_ST_Set_Entry_Names, -- System.Tasking
RO_ST_Task_Id, -- System.Tasking
RO_ST_Null_Task, -- System.Tasking
@@ -1687,14 +1690,16 @@
RE_Dispatching_Domain, -- Dispatching_Domains
RE_Protected_Entry_Body_Array, -- Tasking.Protected_Objects.Entries
+ RE_Protected_Entry_Names_Array, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries_Access, -- Tasking.Protected_Objects.Entries
RE_Initialize_Protection_Entries, -- Tasking.Protected_Objects.Entries
RE_Lock_Entries, -- Tasking.Protected_Objects.Entries
+ RE_Unlock_Entries, -- Tasking.Protected_Objects.Entries
RO_PE_Get_Ceiling, -- Tasking.Protected_Objects.Entries
+ RO_PE_Number_Of_Entries, -- Tasking.Protected_Objects.Entries
RO_PE_Set_Ceiling, -- Tasking.Protected_Objects.Entries
- RO_PE_Set_Entry_Name, -- Tasking.Protected_Objects.Entries
- RE_Unlock_Entries, -- Tasking.Protected_Objects.Entries
+ RO_PE_Set_Entry_Names, -- Tasking.Protected_Objects.Entries
RE_Communication_Block, -- Protected_Objects.Operations
RE_Protected_Entry_Call, -- Protected_Objects.Operations
@@ -1769,7 +1774,6 @@
RE_Free_Task, -- System.Tasking.Stages
RE_Expunge_Unactivated_Tasks, -- System.Tasking.Stages
RE_Move_Activation_Chain, -- System_Tasking_Stages
- RO_TS_Set_Entry_Name, -- System.Tasking.Stages
RE_Terminated); -- System.Tasking.Stages
-- The following declarations build a table that is indexed by the RTE
@@ -2749,6 +2753,9 @@
RE_Unspecified_Task_Info => System_Task_Info,
RE_Task_Procedure_Access => System_Tasking,
+ RE_Task_Entry_Names_Array => System_Tasking,
+ RO_ST_Number_Of_Entries => System_Tasking,
+ RO_ST_Set_Entry_Names => System_Tasking,
RO_ST_Task_Id => System_Tasking,
RO_ST_Null_Task => System_Tasking,
@@ -2937,6 +2944,8 @@
RE_Protected_Entry_Body_Array =>
System_Tasking_Protected_Objects_Entries,
+ RE_Protected_Entry_Names_Array =>
+ System_Tasking_Protected_Objects_Entries,
RE_Protection_Entries =>
System_Tasking_Protected_Objects_Entries,
RE_Protection_Entries_Access =>
@@ -2945,14 +2954,16 @@
System_Tasking_Protected_Objects_Entries,
RE_Lock_Entries =>
System_Tasking_Protected_Objects_Entries,
+ RE_Unlock_Entries =>
+ System_Tasking_Protected_Objects_Entries,
RO_PE_Get_Ceiling =>
System_Tasking_Protected_Objects_Entries,
+ RO_PE_Number_Of_Entries =>
+ System_Tasking_Protected_Objects_Entries,
RO_PE_Set_Ceiling =>
System_Tasking_Protected_Objects_Entries,
- RO_PE_Set_Entry_Name =>
+ RO_PE_Set_Entry_Names =>
System_Tasking_Protected_Objects_Entries,
- RE_Unlock_Entries =>
- System_Tasking_Protected_Objects_Entries,
RE_Communication_Block =>
System_Tasking_Protected_Objects_Operations,
@@ -3054,7 +3065,6 @@
RE_Free_Task => System_Tasking_Stages,
RE_Expunge_Unactivated_Tasks => System_Tasking_Stages,
RE_Move_Activation_Chain => System_Tasking_Stages,
- RO_TS_Set_Entry_Name => System_Tasking_Stages,
RE_Terminated => System_Tasking_Stages);
--------------------------------
===================================================================
@@ -33,8 +33,6 @@
-- Turn off polling, we do not want ATC polling to take place during tasking
-- operations. It causes infinite loops and other problems.
-with Ada.Unchecked_Deallocation;
-
with System.Task_Primitives.Operations;
with System.Storage_Elements;
@@ -42,19 +40,6 @@
package STPO renames System.Task_Primitives.Operations;
- ----------------------------
- -- Free_Entry_Names_Array --
- ----------------------------
-
- procedure Free_Entry_Names_Array (Obj : in out Entry_Names_Array) is
- procedure Free_String is new
- Ada.Unchecked_Deallocation (String, String_Access);
- begin
- for Index in Obj'Range loop
- Free_String (Obj (Index));
- end loop;
- end Free_Entry_Names_Array;
-
---------------------
-- Detect_Blocking --
---------------------
@@ -70,6 +55,15 @@
return GL_Detect_Blocking = 1;
end Detect_Blocking;
+ -----------------------
+ -- Number_Of_Entries --
+ -----------------------
+
+ function Number_Of_Entries (Self_Id : Task_Id) return Task_Entry_Index is
+ begin
+ return Self_Id.Entry_Num;
+ end Number_Of_Entries;
+
----------
-- Self --
----------
@@ -257,4 +251,16 @@
T.Entry_Calls (1).Self := T;
end Initialize;
+ ---------------------
+ -- Set_Entry_Names --
+ ---------------------
+
+ procedure Set_Entry_Names
+ (Self_Id : Task_Id;
+ Names : Task_Entry_Names_Access)
+ is
+ begin
+ Self_Id.Entry_Names := Names;
+ end Set_Entry_Names;
+
end System.Tasking;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@@ -252,14 +252,11 @@
type String_Access is access all String;
- type Entry_Names_Array is
- array (Entry_Index range <>) of String_Access;
+ type Task_Entry_Names_Array is
+ array (Task_Entry_Index range <>) of String_Access;
- type Entry_Names_Array_Access is access all Entry_Names_Array;
+ type Task_Entry_Names_Access is access all Task_Entry_Names_Array;
- procedure Free_Entry_Names_Array (Obj : in out Entry_Names_Array);
- -- Deallocate all string names contained in an entry names array
-
----------------------------------
-- Entry_Call_Record definition --
----------------------------------
@@ -968,10 +965,13 @@
-- associated with protected objects or task entries, and are protected
-- by the protected object lock or Acceptor.L, respectively.
- Entry_Names : Entry_Names_Array_Access := null;
+ Entry_Names : Task_Entry_Names_Access := null;
-- An array of string names which denotes entry [family member] names.
-- The structure is indexed by task entry index and contains Entry_Num
-- components.
+ --
+ -- Protection: The array is populated during task initialization, before
+ -- the task has been activated. No protection is required in this case.
New_Base_Priority : System.Any_Priority;
-- New value for Base_Priority (for dynamic priorities package)
@@ -1203,4 +1203,13 @@
-- registered for removal (Expunge_Unactivated_Tasks). The "limited" forces
-- Activation_Chain to be a by-reference type; see RM-6.2(4).
+ function Number_Of_Entries (Self_Id : Task_Id) return Task_Entry_Index;
+ -- Given a task, return the number of entries it contains
+
+ procedure Set_Entry_Names
+ (Self_Id : Task_Id;
+ Names : Task_Entry_Names_Access);
+ -- Associate an array of string that denote entry [family] names with a
+ -- task.
+
end System.Tasking;
===================================================================
@@ -1704,6 +1704,18 @@
end if;
end if;
+ -- When the object is either protected or a task, create static strings
+ -- which denote the names of entries and families. Associate the strings
+ -- with the concurrent object's Protection_Entries or ATCB. This is a
+ -- VMS Debug feature.
+
+ if OpenVMS_On_Target
+ and then Is_Concurrent_Type (Typ)
+ and then Entry_Names_OK
+ then
+ Build_Entry_Names (Id_Ref, Typ, Res);
+ end if;
+
return Res;
exception
@@ -2665,7 +2677,6 @@
Decl : Node_Id;
Has_POC : Boolean;
Id : Entity_Id;
- Names : Node_Id;
Stmts : List_Id;
Typ : Entity_Id;
@@ -3009,17 +3020,6 @@
Append_To (Stmts, Make_Task_Create_Call (Rec_Type));
- -- Generate the statements which map a string entry name to a
- -- task entry index. Note that the task may not have entries.
-
- if Entry_Names_OK then
- Names := Build_Entry_Names (Rec_Type);
-
- if Present (Names) then
- Append_To (Stmts, Names);
- end if;
- end if;
-
declare
Task_Type : constant Entity_Id :=
Corresponding_Concurrent_Type (Rec_Type);
@@ -3073,18 +3073,6 @@
if Is_Protected_Record_Type (Rec_Type) then
Append_List_To (Stmts,
Make_Initialize_Protection (Rec_Type));
-
- -- Generate the statements which map a string entry name to a
- -- protected entry index. Note that the protected type may not
- -- have entries.
-
- if Entry_Names_OK then
- Names := Build_Entry_Names (Rec_Type);
-
- if Present (Names) then
- Append_To (Stmts, Names);
- end if;
- end if;
end if;
-- Second pass: components with per-object constraints