From: Hristian Kirtchev Date: Mon, 26 May 2008 09:39:19 +0000 (+0200) Subject: exp_ch3.adb (Build_Init_Statements): Alphabetize local variables. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=c42e6724e10f71991cc5e01a4013d77036b06099;p=gcc.git exp_ch3.adb (Build_Init_Statements): Alphabetize local variables. 2008-05-26 Hristian Kirtchev * exp_ch3.adb (Build_Init_Statements): Alphabetize local variables. Create the statements which map a string name to protected or task entry indix. * exp_ch9.adb: Add with and use clause for Stringt. Minor code reformatting. (Build_Entry_Names): New routine. (Make_Initialize_Protection, Make_Task_Create_Call): Generate a value for flag Build_Entry_Names which controls the allocation of the data structure for the string names of entries. * exp_ch9.ads (Build_Entry_Names): New subprogram. * exp_util.adb (Entry_Names_OK): New function. * exp_util.ads (Entry_Names_OK): New function. * rtsfind.ads: Add RO_PE_Set_Entry_Name and RO_TS_Set_Entry_Name to enumerations RE_Id and RE_Unit_Table. * s-taskin.adb Add with and use clause for Ada.Unchecked_Deallocation. (Free_Entry_Names_Array): New routine. * s-taskin.ads: Comment reformatting. Add types String_Access, Entry_Names_Array, Entry_Names_Array_Access. Add component Entry_Names to record Ada_Task_Control_Block. (Free_Entry_Names_Array): New routine. * s-tassta.adb (Create_Task): If flag Build_Entry_Names is set, dynamically allocate an array of string pointers. This structure holds string entry names. (Free_Entry_Names): New routine. (Free_Task, Vulnerable_Free_Task): Deallocate the entry names array. (Set_Entry_Names): New routine. * s-tassta.ads: (Create_Task): Add formal Build_Entry_Names. The flag is used to control the allocation of the data structure which stores entry names. (Set_Entry_Name): New routine. * s-tpoben.adb: Add with and use clause for Ada.Unchecked_Conversion. (Finalize): Deallocate the entry names array. (Free_Entry_Names): New routine. (Initialize_Protection_Entries): When flag Build_Entry_Names is set, create an array of string pointers to hold the entry names. (Set_Entry_Name): New routine. * s-tpoben.ads: Add field Entry_Names to record Protection_Entries. (Initialize_Protection_Entries): Add formal Build_Entry_Names. (Set_Entry_Name): New routine. From-SVN: r135896 --- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 1ed0703f251..89ae08fdcdc 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2477,17 +2477,16 @@ package body Exp_Ch3 is 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. @@ -2711,6 +2710,17 @@ package body Exp_Ch3 is 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); @@ -2761,6 +2771,18 @@ package body Exp_Ch3 is 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 @@ -4494,15 +4516,16 @@ package body Exp_Ch3 is 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, diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index ca4d70b2c02..33d129c3996 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -56,6 +56,7 @@ with Sem_Util; use Sem_Util; 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; @@ -1106,6 +1107,334 @@ package body Exp_Ch9 is 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 (" " & 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 (""); + -- _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'("" & 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, ); + -- 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 -- --------------------------- @@ -11250,8 +11579,8 @@ package body Exp_Ch9 is 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 @@ -11302,6 +11631,20 @@ package body Exp_Ch9 is 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 @@ -11310,6 +11653,7 @@ package body Exp_Ch9 is 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, @@ -11422,13 +11766,13 @@ package body Exp_Ch9 is 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); @@ -11682,14 +12026,29 @@ package body Exp_Ch9 is 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; ------------------------------ diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 0e9715dde0d..a4c618a61cb 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -58,6 +58,11 @@ package Exp_Ch9 is -- 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 diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index fd9fe26dd15..c6b61d551a0 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1116,6 +1116,19 @@ package body Exp_Util is 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 -- --------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 73277afe16b..30d417f2c4f 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -314,6 +314,11 @@ package Exp_Util is -- 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 diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 83f745499e2..2c16961c009 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1516,7 +1516,9 @@ package Rtsfind is 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 @@ -1590,6 +1592,7 @@ package Rtsfind is 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 @@ -2652,8 +2655,11 @@ package Rtsfind is 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 => @@ -2754,6 +2760,7 @@ package Rtsfind is 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); -------------------------------- diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index 7d78f5112a7..822dc9320fc 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -35,6 +35,8 @@ pragma Polling (Off); -- 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,6 +44,19 @@ package body System.Tasking is 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 -- --------------------- diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index 70e755da016..87afc802e54 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -237,6 +237,19 @@ package System.Tasking is 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 -- ---------------------------------- @@ -441,19 +454,17 @@ package System.Tasking is -- 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 @@ -467,8 +478,8 @@ package System.Tasking 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 @@ -489,7 +500,7 @@ package System.Tasking is 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, @@ -605,10 +616,9 @@ package System.Tasking is -- 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. @@ -855,6 +865,11 @@ package System.Tasking is -- 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) -- diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index d3c6739fb3d..09d9070cd4e 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -88,6 +88,9 @@ package body System.Tasking.Stages is 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. @@ -465,7 +468,8 @@ package body System.Tasking.Stages is 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; @@ -605,6 +609,11 @@ package body System.Tasking.Stages is 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; @@ -816,6 +825,26 @@ package body System.Tasking.Stages is 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 -- --------------- @@ -837,6 +866,7 @@ package body System.Tasking.Stages is 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 @@ -895,6 +925,23 @@ package body System.Tasking.Stages is 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 -- ------------------ @@ -1419,15 +1466,15 @@ package body System.Tasking.Stages is -------------------------------- 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; @@ -1877,6 +1924,7 @@ package body System.Tasking.Stages is Unlock_RTS; end if; + Free_Entry_Names (T); System.Task_Primitives.Operations.Finalize_TCB (T); end Vulnerable_Free_Task; diff --git a/gcc/ada/s-tassta.ads b/gcc/ada/s-tassta.ads index 36f0fbfc3f2..cee2d3b958e 100644 --- a/gcc/ada/s-tassta.ads +++ b/gcc/ada/s-tassta.ads @@ -180,7 +180,8 @@ package System.Tasking.Stages is 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. -- @@ -190,7 +191,7 @@ package System.Tasking.Stages is -- 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 @@ -205,6 +206,8 @@ package System.Tasking.Stages is -- 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. @@ -276,6 +279,13 @@ package System.Tasking.Stages is -- 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 diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb index 986a30af9e8..38126956b9e 100644 --- a/gcc/ada/s-tpoben.adb +++ b/gcc/ada/s-tpoben.adb @@ -43,6 +43,8 @@ -- 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,6 +60,13 @@ package body System.Tasking.Protected_Objects.Entries is 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 -- ---------------- @@ -134,6 +143,8 @@ package body System.Tasking.Protected_Objects.Entries is end loop; end loop; + Free_Entry_Names (Object); + Object.Finalized := True; if Single_Lock then @@ -145,6 +156,26 @@ package body System.Tasking.Protected_Objects.Entries is 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 -- ----------------- @@ -177,14 +208,15 @@ package body System.Tasking.Protected_Objects.Entries is 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' @@ -213,6 +245,11 @@ package body System.Tasking.Protected_Objects.Entries is 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; ------------------ @@ -357,6 +394,21 @@ package body System.Tasking.Protected_Objects.Entries is Object.New_Ceiling := Prio; 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 -- -------------------- diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads index 9feba091396..b3dea7b03d2 100644 --- a/gcc/ada/s-tpoben.ads +++ b/gcc/ada/s-tpoben.ads @@ -113,7 +113,7 @@ package System.Tasking.Protected_Objects.Entries is 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 @@ -132,11 +132,16 @@ package System.Tasking.Protected_Objects.Entries is -- 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 @@ -164,11 +169,12 @@ package System.Tasking.Protected_Objects.Entries is -- 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. @@ -202,6 +208,13 @@ package System.Tasking.Protected_Objects.Entries is 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