function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
Check_List : constant List_Id := New_List;
Alt_List : List_Id;
+ Decl : Node_Id;
+ Id : Entity_Id;
+ Names : Node_Id;
Statement_List : List_Id;
Stmts : List_Id;
+ Typ : Entity_Id;
+ Variant : Node_Id;
Per_Object_Constraint_Components : Boolean;
- Decl : Node_Id;
- Variant : Node_Id;
-
- Id : Entity_Id;
- Typ : Entity_Id;
-
function Has_Access_Constraint (E : Entity_Id) return Boolean;
-- Components with access discriminants that depend on the current
-- instance must be initialized after all other components.
Append_To (Statement_List, 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 (Statement_List, Names);
+ end if;
+ end if;
+
declare
Task_Type : constant Entity_Id :=
Corresponding_Concurrent_Type (Rec_Type);
if Is_Protected_Record_Type (Rec_Type) then
Append_List_To (Statement_List,
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 (Statement_List, Names);
+ end if;
+ end if;
end if;
-- If no initializations when generated for component declarations
end;
end if;
- -- If the type is controlled and not limited then the target is
- -- adjusted after the copy and attached to the finalization list.
- -- However, no adjustment is done in the case where the object was
- -- initialized by a call to a function whose result is built in
- -- place, since no copy occurred. (We eventually plan to support
- -- in-place function results for some nonlimited types. ???)
+ -- If the type is controlled and not inherently limited, then
+ -- the target is adjusted after the copy and attached to the
+ -- finalization list. However, no adjustment is done in the case
+ -- where the object was initialized by a call to a function whose
+ -- result is built in place, since no copy occurred. (Eventually
+ -- we plan to support in-place function results for some cases
+ -- of nonlimited types. ???)
if Controlled_Type (Typ)
- and then not Is_Limited_Type (Typ)
+ and then not Is_Inherently_Limited_Type (Typ)
and then not BIP_Call
then
Insert_Actions_After (Init_After,
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
+with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
return Ecount;
end Build_Entry_Count_Expression;
+ -----------------------
+ -- 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_Family_Name (Id : Entity_Id);
+ -- Generate:
+ -- for Lnn in Family_Low .. Family_High loop
+ -- Inn := Inn + 1;
+ -- Set_Entry_Name
+ -- (_init._object, Inn, new String ("<Entry name> " & Lnn'Img));
+ -- _init._task_id
+ -- 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 (Id : Entity_Id);
+ -- Generate:
+ -- Inn := Inn + 1;
+ -- Set_Entry_Name (_init._task_id, Inn, new String ("<Entry name>");
+ -- _init._object
+ -- The above construct is added directly to the statements of the block.
+
+ 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.
+
+ function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id;
+ -- Given a protected type or its corresponding record, find the type of
+ -- field _object.
+
+ 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_Defining_Identifier (Loc, New_Internal_Name ('L'));
+ L_Stmts : constant List_Id := New_List;
+ Val : Node_Id;
+
+ 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.
+
+ -----------------
+ -- Build_Range --
+ -----------------
+
+ function Build_Range (Def : Node_Id) return Node_Id is
+ High : Node_Id := Type_High_Bound (Etype (Def));
+ Low : Node_Id := Type_Low_Bound (Etype (Def));
+
+ begin
+ -- If a bound references a discriminant, generate an identifier
+ -- with the same name. Resolution will map it to the formals of
+ -- the init proc.
+
+ if Is_Entity_Name (Low)
+ and then Ekind (Entity (Low)) = E_Discriminant
+ then
+ Low := Make_Identifier (Loc, Chars (Low));
+ else
+ Low := New_Copy_Tree (Low);
+ end if;
+
+ if Is_Entity_Name (High)
+ and then Ekind (Entity (High)) = E_Discriminant
+ then
+ High := Make_Identifier (Loc, Chars (High));
+ else
+ High := New_Copy_Tree (High);
+ end if;
+
+ return
+ Make_Range (Loc,
+ Low_Bound => Low,
+ High_Bound => High);
+ end Build_Range;
+
+ -- Start of processing for Build_Entry_Family_Name
+
+ begin
+ Get_Name_String (Chars (Id));
+
+ if Is_Enumeration_Type (Etype (Def)) then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := ' ';
+ end if;
+
+ -- Generate:
+ -- new String'("<Entry name>" & Lnn'Img);
+
+ Val :=
+ Make_Allocator (Loc,
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark =>
+ New_Reference_To (Standard_String, Loc),
+ Expression =>
+ Make_Op_Concat (Loc,
+ Left_Opnd =>
+ Make_String_Literal (Loc,
+ String_From_Name_Buffer),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (L_Id, Loc),
+ Attribute_Name => Name_Img))));
+
+ Increment_Index (L_Stmts);
+ Append_To (L_Stmts, Build_Set_Entry_Name_Call (Val));
+
+ -- Generate:
+ -- for Lnn in Family_Low .. Family_High loop
+ -- Inn := Inn + 1;
+ -- Set_Entry_Name (_init._task_id, Inn, <Val>);
+ -- end loop;
+
+ 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;
+
+ ----------------------
+ -- Build_Entry_Name --
+ ----------------------
+
+ procedure Build_Entry_Name (Id : Entity_Id) is
+ Val : Node_Id;
+
+ begin
+ Get_Name_String (Chars (Id));
+ 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)));
+
+ Increment_Index (B_Stmts);
+ Append_To (B_Stmts, Build_Set_Entry_Name_Call (Val));
+ end Build_Entry_Name;
+
+ -------------------------------
+ -- Build_Set_Entry_Name_Call --
+ -------------------------------
+
+ function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id is
+ Arg1 : Name_Id;
+ Proc : RE_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;
+ end if;
+
+ -- Generate:
+ -- Set_Entry_Name (_init.Arg1, Inn, Arg3);
+
+ 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;
+
+ --------------------------
+ -- Find_Protection_Type --
+ --------------------------
+
+ function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
+ Comp : Entity_Id;
+ Typ : Entity_Id := Conc_Typ;
+
+ begin
+ if Is_Concurrent_Type (Typ) then
+ Typ := Corresponding_Record_Type (Typ);
+ end if;
+
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ if Chars (Comp) = Name_uObject then
+ return Base_Type (Etype (Comp));
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ -- The corresponding record of a protected type should always have an
+ -- _object field.
+
+ raise Program_Error;
+ end Find_Protection_Type;
+
+ ---------------------
+ -- Increment_Index --
+ ---------------------
+
+ procedure Increment_Index (Stmts : List_Id) is
+ begin
+ -- Generate:
+ -- Inn := Inn + 1;
+
+ 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;
+
+ -- Start of processing for Build_Entry_Names
+
+ begin
+ -- Retrieve the original concurrent type
+
+ if Is_Concurrent_Record_Type (Typ) then
+ Typ := Corresponding_Concurrent_Type (Typ);
+ end if;
+
+ pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
+
+ -- Nothing to do if the type has no entries
+
+ if not Has_Entries (Typ) then
+ return Empty;
+ 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)
+ then
+ return Empty;
+ end if;
+
+ Index := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+
+ -- 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
+ 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
+
+ return
+ Make_Block_Statement (Loc,
+ Declarations => B_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => B_Stmts));
+ end Build_Entry_Names;
+
---------------------------
-- Build_Parameter_Block --
---------------------------
or else Has_Abstract_Interfaces (Protect_Rec)
then
declare
- Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp);
-
+ Pkg_Id : constant RTU_Id :=
+ Corresponding_Runtime_Package (Ptyp);
Called_Subp : RE_Id;
begin
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 = System_Tasking_Protected_Objects_Single_Entry then
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,
function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Task_Rec);
+ Args : List_Id;
+ Ecount : Node_Id;
Name : Node_Id;
- Tdef : Node_Id;
Tdec : Node_Id;
- Ttyp : Node_Id;
+ Tdef : Node_Id;
Tnam : Name_Id;
- Args : List_Id;
- Ecount : Node_Id;
+ Ttyp : Node_Id;
begin
Ttyp := Corresponding_Concurrent_Type (Task_Rec);
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
+ if Has_Entries (Ttyp)
+ and then 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;
+
if Restricted_Profile then
Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc);
else
Name := New_Reference_To (RTE (RE_Create_Task), Loc);
end if;
- return Make_Procedure_Call_Statement (Loc,
- Name => Name, Parameter_Associations => Args);
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => Name,
+ Parameter_Associations => Args);
end Make_Task_Create_Call;
------------------------------
-- build record declaration. N is the type declaration, Ctyp is the
-- concurrent entity (task type or protected 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_Master_Entity (E : Entity_Id);
-- Given an entity E for the declaration of an object containing tasks
-- or of a type declaration for an allocator whose designated type is a
end if;
end Ensure_Defined;
+ --------------------
+ -- Entry_Names_OK --
+ --------------------
+
+ function Entry_Names_OK return Boolean is
+ begin
+ return
+ not Restricted_Profile
+ and then not Global_Discard_Names
+ and then not Restriction_Active (No_Implicit_Heap_Allocations)
+ and then not Restriction_Active (No_Local_Allocators);
+ end Entry_Names_OK;
+
---------------------
-- Evolve_And_Then --
---------------------
-- used to ensure that an Itype is properly defined outside a conditional
-- construct when it is referenced in more than one branch.
+ function Entry_Names_OK return Boolean;
+ -- Determine whether it is appropriate to dynamically allocate strings
+ -- which represent entry [family member] names. These strings are created
+ -- by the compiler and used by GDB.
+
procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id);
-- Rewrites Cond with the expression: Cond and then Cond1. If Cond is
-- Empty, then simply returns Cond1 (this allows the use of Empty to
RE_Lock_Entries, -- Tasking.Protected_Objects.Entries
RO_PE_Get_Ceiling, -- 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
+
RE_Communication_Block, -- Protected_Objects.Operations
RE_Protected_Entry_Call, -- Protected_Objects.Operations
RE_Service_Entries, -- Protected_Objects.Operations
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
System_Tasking_Protected_Objects_Entries,
RO_PE_Set_Ceiling =>
System_Tasking_Protected_Objects_Entries,
+ RO_PE_Set_Entry_Name =>
+ System_Tasking_Protected_Objects_Entries,
RE_Unlock_Entries =>
System_Tasking_Protected_Objects_Entries,
+
RE_Communication_Block =>
System_Tasking_Protected_Objects_Operations,
RE_Protected_Entry_Call =>
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);
--------------------------------
-- 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;
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 --
---------------------
type Task_Entry_Queue_Array is
array (Task_Entry_Index range <>) of Entry_Queue;
+ -- A data structure which contains the string names of entries and entry
+ -- family members.
+
+ type String_Access is access all String;
+
+ type Entry_Names_Array is
+ array (Entry_Index range <>) of String_Access;
+
+ type Entry_Names_Array_Access is access all 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 --
----------------------------------
-- and rendezvous.
--
-- Ada 95 notes: In Ada 95, this field will be transferred to the
- -- Priority field of an Entry_Calls component when an entry call
- -- is initiated. The Priority of the Entry_Calls component will not
- -- change for the duration of the call. The accepting task can
- -- use it to boost its own priority without fear of its changing in
- -- the meantime.
+ -- Priority field of an Entry_Calls component when an entry call is
+ -- initiated. The Priority of the Entry_Calls component will not change
+ -- for the duration of the call. The accepting task can use it to boost
+ -- its own priority without fear of its changing in the meantime.
--
- -- This can safely be used in the priority ordering
- -- of entry queues. Once a call is queued, its priority does not
- -- change.
+ -- This can safely be used in the priority ordering of entry queues.
+ -- Once a call is queued, its priority does not change.
--
- -- Since an entry call cannot be made while executing
- -- a protected action, the priority of a task will never reflect a
- -- priority ceiling change at the point of an entry call.
+ -- Since an entry call cannot be made while executing a protected
+ -- action, the priority of a task will never reflect a priority ceiling
+ -- change at the point of an entry call.
--
-- Protection: Only written by Self, and only accessed when Acceptor
-- accepts an entry or when Created activates, at which points Self is
-- can be read/written from protected interrupt handlers.
Task_Image : String (1 .. System.Parameters.Max_Task_Image_Length);
- -- Hold a string that provides a readable id for task,
- -- built from the variable of which it is a value or component.
+ -- Hold a string that provides a readable id for task, built from the
+ -- variable of which it is a value or component.
Task_Image_Len : Natural;
-- Actual length of Task_Image
Task_Arg : System.Address;
-- The argument to task procedure. Provide a handle for discriminant
- -- information
+ -- information.
--
-- Protection: Part of the synchronization between Self and Activator.
-- Activator writes it, once, before Self starts executing. Thereafter,
-- Restricted_Ada_Task_Control_Block --
---------------------------------------
- -- This type should only be used by the restricted GNARLI and by
- -- restricted GNULL implementations to allocate an ATCB (see
- -- System.Task_Primitives.Operations.New_ATCB) that will take
- -- significantly less memory.
+ -- This type should only be used by the restricted GNARLI and by restricted
+ -- GNULL implementations to allocate an ATCB (see System.Task_Primitives.
+ -- Operations.New_ATCB) that will take significantly less memory.
-- Note that the restricted GNARLI should only access fields that are
-- present in the Restricted_Ada_Task_Control_Block structure.
-- 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;
+ -- An array of string names which denotes entry [family member] names.
+ -- The structure is indexed by task entry index and contains Entry_Num
+ -- components.
+
New_Base_Priority : System.Any_Priority;
-- New value for Base_Priority (for dynamic priorities package)
--
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.
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
Task_Image : String;
- Created_Task : out Task_Id)
+ Created_Task : out Task_Id;
+ Build_Entry_Names : Boolean)
is
T, P : Task_Id;
Self_ID : constant Task_Id := STPO.Self;
T.Common.Task_Image_Len := Len;
end if;
+ if Build_Entry_Names then
+ T.Entry_Names :=
+ new Entry_Names_Array (1 .. Entry_Index (Num_Entries));
+ end if;
+
Unlock (Self_ID);
Unlock_RTS;
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 --
---------------
Initialization.Task_Unlock (Self_Id);
+ Free_Entry_Names (T);
System.Task_Primitives.Operations.Finalize_TCB (T);
-- If the task is not terminated, then we simply ignore the call. This
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 --
------------------
--------------------------------
procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is
- C : Task_Id;
- P : Task_Id;
- CM : constant Master_Level := Self_ID.Master_Within;
- T : aliased Task_Id;
+ C : Task_Id;
+ P : Task_Id;
+ CM : constant Master_Level := Self_ID.Master_Within;
+ T : aliased Task_Id;
To_Be_Freed : Task_Id;
- -- This is a list of ATCBs to be freed, after we have released
- -- all RTS locks. This is necessary because of the locking order
- -- rules, since the storage manager uses Global_Task_Lock.
+ -- This is a list of ATCBs to be freed, after we have released all RTS
+ -- locks. This is necessary because of the locking order rules, since
+ -- the storage manager uses Global_Task_Lock.
pragma Warnings (Off);
function Check_Unactivated_Tasks return Boolean;
Unlock_RTS;
end if;
+ Free_Entry_Names (T);
System.Task_Primitives.Operations.Finalize_TCB (T);
end Vulnerable_Free_Task;
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
Task_Image : String;
- Created_Task : out Task_Id);
+ Created_Task : out Task_Id;
+ Build_Entry_Names : Boolean);
-- Compiler interface only. Do not call from within the RTS.
-- This must be called to create a new task.
--
-- Task_Info is the task info associated with the created task, or
-- Unspecified_Task_Info if none.
-- Relative_Deadline is the relative deadline associated with the created
- -- task by means of a pragma Relative_Deadline, or 0.0 if none.
+ -- task by means of a pragma Relative_Deadline, or 0.0 if none.
-- State is the compiler generated task's procedure body
-- Discriminants is a pointer to a limited record whose discriminants
-- are those of the task to create. This parameter should be passed as
-- 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.
-- 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
-- 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;
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 --
----------------
end loop;
end loop;
+ Free_Entry_Names (Object);
+
Object.Finalized := True;
if Single_Lock then
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 --
-----------------
Ceiling_Priority : Integer;
Compiler_Info : System.Address;
Entry_Bodies : Protected_Entry_Body_Access;
- Find_Body_Index : Find_Body_Index_Access)
+ Find_Body_Index : Find_Body_Index_Access;
+ Build_Entry_Names : Boolean)
is
Init_Priority : Integer := Ceiling_Priority;
Self_ID : constant Task_Id := STPO.Self;
begin
if Init_Priority = Unspecified_Priority then
- Init_Priority := System.Priority'Last;
+ Init_Priority := System.Priority'Last;
end if;
if Locking_Policy = 'C'
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;
------------------
end Set_Ceiling;
--------------------
+ -- Set_Entry_Name --
+ --------------------
+
+ procedure Set_Entry_Name
+ (Object : Protection_Entries'Class;
+ Pos : Protected_Entry_Index;
+ Val : String_Access)
+ is
+ begin
+ pragma Assert (Object.Entry_Names /= null);
+
+ Object.Entry_Names (Entry_Index (Pos)) := Val;
+ end Set_Entry_Name;
+
+ --------------------
-- Unlock_Entries --
--------------------
Old_Base_Priority : System.Any_Priority;
-- Task's base priority when the protected operation was called
- Pending_Action : Boolean;
+ Pending_Action : Boolean;
-- Flag indicating that priority has been dipped temporarily in order
-- to avoid violating the priority ceiling of the lock associated with
-- this protected object, in Lock_Server. The flag tells Unlock_Server
-- Pointer to an array containing the executable code for all entry
-- bodies of a protected type.
- -- The following function maps the entry index in a call (which denotes
- -- the queue to the proper entry) into the body of the entry.
-
Find_Body_Index : Find_Body_Index_Access;
- Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries);
+ -- A function which maps the entry index in a call (which denotes the
+ -- queue of the proper entry) into the body of the entry.
+
+ Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries);
+
+ Entry_Names : Entry_Names_Array_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.
end record;
-- No default initial values for this type, since call records
-- 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);
+ (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);
-- Initialize the Object parameter so that it can be used by the runtime
-- to keep track of the runtime state of a protected object.
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 Unlock_Entries (Object : Protection_Entries_Access);
-- Relinquish ownership of the lock for the object represented by the
-- Object parameter. If this ownership was for write access, or if it was
OSDN Git Service
