diff options
Diffstat (limited to 'gcc/ada/exp_ch9.adb')
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 890 |
1 files changed, 344 insertions, 546 deletions
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 9d21af2..1f9f458 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -25,7 +25,6 @@ with Atree; use Atree; with Checks; use Checks; -with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; @@ -52,6 +51,7 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Ch9; use Sem_Ch9; with Sem_Ch11; use Sem_Ch11; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; @@ -61,7 +61,6 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; -with Table; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -77,37 +76,6 @@ package body Exp_Ch9 is Entry_Family_Bound : constant Int := 2**16; - ------------------------------ - -- Lock Free Data Structure -- - ------------------------------ - - -- A lock-free subprogram is a protected routine which references a unique - -- protected scalar component and does not contain statements that cause - -- side effects. Due to this restricted behavior, all references to shared - -- data from within the subprogram can be synchronized through the use of - -- atomic operations rather than relying on locks. - - type Lock_Free_Subprogram is record - Sub_Body : Node_Id; - -- Reference to the body of a protected subprogram which meets the lock- - -- free requirements. - - Comp_Id : Entity_Id; - -- Reference to the scalar component referenced from within Sub_Body - end record; - - -- This table establishes a relation between a protected subprogram body - -- and a unique component it references. The table is used when building - -- the lock-free versions of a protected subprogram body. - - package Lock_Free_Subprogram_Table is new Table.Table ( - Table_Component_Type => Lock_Free_Subprogram, - Table_Index_Type => Nat, - Table_Low_Bound => 1, - Table_Initial => 5, - Table_Increment => 5, - Table_Name => "Lock_Free_Subprogram_Table"); - ----------------------- -- Local Subprograms -- ----------------------- @@ -142,20 +110,6 @@ package body Exp_Ch9 is -- Decls is the list of declarations to be enhanced. -- Ent is the entity for the original entry body. - function Allows_Lock_Free_Implementation (N : Node_Id) return Boolean; - -- Given a protected body N, return True if N satisfies the following list - -- of lock-free restrictions: - -- - -- 1) Protected type - -- May not contain entries - -- May contain only scalar components - -- Component types must support atomic compare and exchange - -- - -- 2) Protected subprograms - -- May not have side effects - -- May not contain loop statements or procedure calls - -- Function calls and attribute references must be static - function Build_Accept_Body (Astat : Node_Id) return Node_Id; -- Transform accept statement into a block with added exception handler. -- Used both for simple accept statements and for accept alternatives in @@ -828,220 +782,6 @@ package body Exp_Ch9 is Prepend_To (Decls, Decl); end Add_Object_Pointer; - ------------------------------------- - -- Allows_Lock_Free_Implementation -- - ------------------------------------- - - function Allows_Lock_Free_Implementation (N : Node_Id) return Boolean is - Spec : constant Entity_Id := Corresponding_Spec (N); - Prot_Def : constant Node_Id := Protected_Definition (Parent (Spec)); - Priv_Decls : constant List_Id := Private_Declarations (Prot_Def); - - function Satisfies_Lock_Free_Requirements - (Sub_Body : Node_Id) return Boolean; - -- Return True if protected subprogram body Sub_Body satisfies all - -- requirements of a lock-free implementation. - - -------------------------------------- - -- Satisfies_Lock_Free_Requirements -- - -------------------------------------- - - function Satisfies_Lock_Free_Requirements - (Sub_Body : Node_Id) return Boolean - is - Comp : Entity_Id := Empty; - -- Track the current component which the body references - - function Check_Node (N : Node_Id) return Traverse_Result; - -- Check that node N meets the lock free restrictions - - ---------------- - -- Check_Node -- - ---------------- - - function Check_Node (N : Node_Id) return Traverse_Result is - begin - -- Function calls and attribute references must be static - -- ??? what about side-effects - - if Nkind_In (N, N_Attribute_Reference, N_Function_Call) - and then not Is_Static_Expression (N) - then - return Abandon; - - -- Loop statements and procedure calls are prohibited - - elsif Nkind_In (N, N_Loop_Statement, - N_Procedure_Call_Statement) - then - return Abandon; - - -- References - - elsif Nkind (N) = N_Identifier - and then Present (Entity (N)) - then - declare - Id : constant Entity_Id := Entity (N); - Sub_Id : constant Entity_Id := Corresponding_Spec (Sub_Body); - - begin - -- Prohibit references to non-constant entities outside the - -- protected subprogram scope. - - if Ekind (Id) in Assignable_Kind - and then not Scope_Within_Or_Same (Scope (Id), Sub_Id) - and then not Scope_Within_Or_Same (Scope (Id), - Protected_Body_Subprogram (Sub_Id)) - then - return Abandon; - - -- A protected subprogram may reference only one component - -- of the protected type. - - elsif Ekind_In (Id, E_Constant, E_Variable) - and then Present (Prival_Link (Id)) - then - declare - Comp_Decl : constant Node_Id := - Parent (Prival_Link (Id)); - begin - if Nkind (Comp_Decl) = N_Component_Declaration - and then Is_List_Member (Comp_Decl) - and then List_Containing (Comp_Decl) = Priv_Decls - then - if No (Comp) then - Comp := Prival_Link (Id); - - -- Check if another protected component has already - -- been accessed by the subprogram body. - - elsif Comp /= Prival_Link (Id) then - return Abandon; - end if; - end if; - end; - end if; - end; - end if; - - return OK; - end Check_Node; - - function Check_All_Nodes is new Traverse_Func (Check_Node); - - -- Start of processing for Satisfies_Lock_Free_Requirements - - begin - if Check_All_Nodes (Sub_Body) = OK then - - -- Establish a relation between the subprogram body and the unique - -- protected component it references. - - if Present (Comp) then - Lock_Free_Subprogram_Table.Append - (Lock_Free_Subprogram'(Sub_Body, Comp)); - end if; - - return True; - else - return False; - end if; - end Satisfies_Lock_Free_Requirements; - - -- Local variables - - Decls : constant List_Id := Declarations (N); - Vis_Decls : constant List_Id := Visible_Declarations (Prot_Def); - - Comp_Id : Entity_Id; - Comp_Size : Int; - Comp_Type : Entity_Id; - Decl : Node_Id; - Has_Component : Boolean := False; - - -- Start of processing for Allows_Lock_Free_Implementation - - begin - -- The lock-free implementation is currently enabled through a debug - -- flag. - - if not Debug_Flag_9 then - return False; - end if; - - -- Examine the visible declarations. Entries and entry families are not - -- allowed by the lock-free restrictions. - - Decl := First (Vis_Decls); - while Present (Decl) loop - if Nkind (Decl) = N_Entry_Declaration then - return False; - end if; - - Next (Decl); - end loop; - - -- Examine the private declarations - - Decl := First (Priv_Decls); - while Present (Decl) loop - - -- The protected type must define at least one scalar component - - if Nkind (Decl) = N_Component_Declaration then - Has_Component := True; - - Comp_Id := Defining_Identifier (Decl); - Comp_Type := Etype (Comp_Id); - - if not Is_Scalar_Type (Comp_Type) then - return False; - end if; - - Comp_Size := UI_To_Int (Esize (Base_Type (Comp_Type))); - - -- Check that the size of the component is 8, 16, 32 or 64 bits - - case Comp_Size is - when 8 | 16 | 32 | 64 => - null; - when others => - return False; - end case; - - -- Entries and entry families are not allowed - - elsif Nkind (Decl) = N_Entry_Declaration then - return False; - end if; - - Next (Decl); - end loop; - - -- At least one scalar component must be present - - if not Has_Component then - return False; - end if; - - -- Ensure that all protected subprograms meet the restrictions of the - -- lock-free implementation. - - Decl := First (Decls); - while Present (Decl) loop - if Nkind (Decl) = N_Subprogram_Body - and then not Satisfies_Lock_Free_Requirements (Decl) - then - return False; - end if; - - Next (Decl); - end loop; - - return True; - end Allows_Lock_Free_Implementation; - ----------------------- -- Build_Accept_Body -- ----------------------- @@ -3228,7 +2968,8 @@ package body Exp_Ch9 is -- begin -- loop -- declare - -- Saved_Comp : constant ... := Atomic_Load (Comp'Address); + -- Saved_Comp : constant ... := + -- Atomic_Load (Comp'Address, Relaxed); -- Current_Comp : ... := Saved_Comp; -- begin -- <original statements> @@ -3496,19 +3237,33 @@ package body Exp_Ch9 is if Present (Comp) then declare - Comp_Typ : constant Entity_Id := Etype (Comp); - Typ_Size : constant Int := UI_To_Int (Esize (Comp_Typ)); + Comp_Type : constant Entity_Id := Etype (Comp); Block_Decls : List_Id; Compare : Entity_Id; Current_Comp : Entity_Id; Decl : Node_Id; Label : Node_Id; Load : Entity_Id; + Load_Params : List_Id; Saved_Comp : Entity_Id; Stmt : Node_Id; + Typ_Size : Int; Unsigned : Entity_Id; begin + -- Get the type size + + if Known_Esize (Comp_Type) then + Typ_Size := UI_To_Int (Esize (Comp_Type)); + + -- If the Esize (Object_Size) is unknown at compile-time, look at + -- the RM_Size (Value_Size) since it may have been set by an + -- explicit representation clause. + + else + Typ_Size := UI_To_Int (RM_Size (Comp_Type)); + end if; + -- Retrieve all relevant atomic routines and types case Typ_Size is @@ -3537,26 +3292,43 @@ package body Exp_Ch9 is end case; -- Generate: - -- Saved_Comp : constant Comp_Typ := - -- Comp_Typ (Atomic_Load (Comp'Address)); + -- For functions: + + -- Saved_Comp : constant Comp_Type := + -- Comp_Type (Atomic_Load (Comp'Address)); + + -- For procedures: + + -- Saved_Comp : constant Comp_Type := + -- Comp_Type (Atomic_Load (Comp'Address), + -- Relaxed); Saved_Comp := Make_Defining_Identifier (Loc, New_External_Name (Chars (Comp), Suffix => "_saved")); + Load_Params := New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Comp, Loc), + Attribute_Name => Name_Address)); + + -- For protected procedures, set the memory model to be relaxed + + if Is_Procedure then + Append_To (Load_Params, + New_Reference_To (RTE (RE_Relaxed), Loc)); + end if; + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Saved_Comp, Constant_Present => True, - Object_Definition => New_Reference_To (Comp_Typ, Loc), + Object_Definition => New_Reference_To (Comp_Type, Loc), Expression => - Unchecked_Convert_To (Comp_Typ, + Unchecked_Convert_To (Comp_Type, Make_Function_Call (Loc, Name => New_Reference_To (Load, Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Comp, Loc), - Attribute_Name => Name_Address))))); + Parameter_Associations => Load_Params))); -- Protected procedures @@ -3564,7 +3336,7 @@ package body Exp_Ch9 is Block_Decls := New_List (Decl); -- Generate: - -- Current_Comp : Comp_Typ := Saved_Comp; + -- Current_Comp : Comp_Type := Saved_Comp; Current_Comp := Make_Defining_Identifier (Loc, @@ -3573,7 +3345,7 @@ package body Exp_Ch9 is Append_To (Block_Decls, Make_Object_Declaration (Loc, Defining_Identifier => Current_Comp, - Object_Definition => New_Reference_To (Comp_Typ, Loc), + Object_Definition => New_Reference_To (Comp_Type, Loc), Expression => New_Reference_To (Saved_Comp, Loc))); -- Protected function @@ -3645,6 +3417,9 @@ package body Exp_Ch9 is if Is_Procedure then Stmts := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Atomic_Synchronize), Loc)), Make_Loop_Statement (Loc, Statements => New_List ( Make_Block_Statement (Loc, @@ -8423,7 +8198,7 @@ package body Exp_Ch9 is Loc : constant Source_Ptr := Sloc (N); Pid : constant Entity_Id := Corresponding_Spec (N); - Lock_Free_On : constant Boolean := Allows_Lock_Free_Implementation (N); + Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid); -- This flag indicates whether the lock free implementation is active Current_Node : Node_Id; @@ -8554,7 +8329,7 @@ package body Exp_Ch9 is if not Is_Eliminated (Defining_Entity (Op_Body)) and then not Is_Eliminated (Corresponding_Spec (Op_Body)) then - if Lock_Free_On then + if Lock_Free_Active then New_Op_Body := Build_Lock_Free_Unprotected_Subprogram_Body (Op_Body, Pid); @@ -8581,7 +8356,7 @@ package body Exp_Ch9 is -- declaration in the protected body itself. if Present (Corresponding_Spec (Op_Body)) then - if Lock_Free_On then + if Lock_Free_Active then New_Op_Body := Build_Lock_Free_Protected_Subprogram_Body (Op_Body, Pid, Specification (New_Op_Body)); @@ -8765,10 +8540,13 @@ package body Exp_Ch9 is -- the specs refer to this type. procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Prot_Typ : constant Entity_Id := Defining_Identifier (N); + Loc : constant Source_Ptr := Sloc (N); + Prot_Typ : constant Entity_Id := Defining_Identifier (N); + + Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ); + -- This flag indicates whether the lock free implementation is active - Pdef : constant Node_Id := Protected_Definition (N); + Pdef : constant Node_Id := Protected_Definition (N); -- This contains two lists; one for visible and one for private decls Rec_Decl : Node_Id; @@ -8926,108 +8704,6 @@ package body Exp_Ch9 is Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ); - -- Prepend the _Object field with the right type to the component list. - -- We need to compute the number of entries, and in some cases the - -- number of Attach_Handler pragmas. - - declare - Ritem : Node_Id; - Num_Attach_Handler : Int := 0; - Protection_Subtype : Node_Id; - Entry_Count_Expr : constant Node_Id := - Build_Entry_Count_Expression - (Prot_Typ, Cdecls, Loc); - - begin - -- Could this be simplified using Corresponding_Runtime_Package??? - - if Has_Attach_Handler (Prot_Typ) then - Ritem := First_Rep_Item (Prot_Typ); - while Present (Ritem) loop - if Nkind (Ritem) = N_Pragma - and then Pragma_Name (Ritem) = Name_Attach_Handler - then - Num_Attach_Handler := Num_Attach_Handler + 1; - end if; - - Next_Rep_Item (Ritem); - end loop; - - if Restricted_Profile then - if Has_Entries (Prot_Typ) then - Protection_Subtype := - New_Reference_To (RTE (RE_Protection_Entry), Loc); - else - Protection_Subtype := - New_Reference_To (RTE (RE_Protection), Loc); - end if; - else - Protection_Subtype := - Make_Subtype_Indication - (Sloc => Loc, - Subtype_Mark => - New_Reference_To - (RTE (RE_Static_Interrupt_Protection), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint ( - Sloc => Loc, - Constraints => New_List ( - Entry_Count_Expr, - Make_Integer_Literal (Loc, Num_Attach_Handler)))); - end if; - - elsif Has_Interrupt_Handler (Prot_Typ) - and then not Restriction_Active (No_Dynamic_Attachment) - then - Protection_Subtype := - Make_Subtype_Indication ( - Sloc => Loc, - Subtype_Mark => New_Reference_To - (RTE (RE_Dynamic_Interrupt_Protection), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint ( - Sloc => Loc, - Constraints => New_List (Entry_Count_Expr))); - - -- Type has explicit entries or generated primitive entry wrappers - - elsif Has_Entries (Prot_Typ) - or else (Ada_Version >= Ada_2005 - and then Present (Interface_List (N))) - then - case Corresponding_Runtime_Package (Prot_Typ) is - when System_Tasking_Protected_Objects_Entries => - Protection_Subtype := - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Reference_To (RTE (RE_Protection_Entries), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint ( - Sloc => Loc, - Constraints => New_List (Entry_Count_Expr))); - - when System_Tasking_Protected_Objects_Single_Entry => - Protection_Subtype := - New_Reference_To (RTE (RE_Protection_Entry), Loc); - - when others => - raise Program_Error; - end case; - - else - Protection_Subtype := New_Reference_To (RTE (RE_Protection), Loc); - end if; - - Object_Comp := - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uObject), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => True, - Subtype_Indication => Protection_Subtype)); - end; - pragma Assert (Present (Pdef)); -- Add private field components @@ -9144,10 +8820,117 @@ package body Exp_Ch9 is end loop; end if; - -- Put the _Object component after the private component so that it - -- be finalized early as required by 9.4 (20) + -- Except for the lock-free implementation, prepend the _Object field + -- with the right type to the component list. We need to compute the + -- number of entries, and in some cases the number of Attach_Handler + -- pragmas. + + if not Lock_Free_Active then + declare + Ritem : Node_Id; + Num_Attach_Handler : Int := 0; + Protection_Subtype : Node_Id; + Entry_Count_Expr : constant Node_Id := + Build_Entry_Count_Expression + (Prot_Typ, Cdecls, Loc); + + begin + -- Could this be simplified using Corresponding_Runtime_Package??? + + if Has_Attach_Handler (Prot_Typ) then + Ritem := First_Rep_Item (Prot_Typ); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Pragma_Name (Ritem) = Name_Attach_Handler + then + Num_Attach_Handler := Num_Attach_Handler + 1; + end if; + + Next_Rep_Item (Ritem); + end loop; + + if Restricted_Profile then + if Has_Entries (Prot_Typ) then + Protection_Subtype := + New_Reference_To (RTE (RE_Protection_Entry), Loc); + else + Protection_Subtype := + New_Reference_To (RTE (RE_Protection), Loc); + end if; + else + Protection_Subtype := + Make_Subtype_Indication + (Sloc => Loc, + Subtype_Mark => + New_Reference_To + (RTE (RE_Static_Interrupt_Protection), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint ( + Sloc => Loc, + Constraints => New_List ( + Entry_Count_Expr, + Make_Integer_Literal (Loc, Num_Attach_Handler)))); + end if; + + elsif Has_Interrupt_Handler (Prot_Typ) + and then not Restriction_Active (No_Dynamic_Attachment) + then + Protection_Subtype := + Make_Subtype_Indication ( + Sloc => Loc, + Subtype_Mark => New_Reference_To + (RTE (RE_Dynamic_Interrupt_Protection), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint ( + Sloc => Loc, + Constraints => New_List (Entry_Count_Expr))); + + -- Type has explicit entries or generated primitive entry wrappers - Append_To (Cdecls, Object_Comp); + elsif Has_Entries (Prot_Typ) + or else (Ada_Version >= Ada_2005 + and then Present (Interface_List (N))) + then + case Corresponding_Runtime_Package (Prot_Typ) is + when System_Tasking_Protected_Objects_Entries => + Protection_Subtype := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Protection_Entries), + Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint ( + Sloc => Loc, + Constraints => New_List (Entry_Count_Expr))); + + when System_Tasking_Protected_Objects_Single_Entry => + Protection_Subtype := + New_Reference_To (RTE (RE_Protection_Entry), Loc); + + when others => + raise Program_Error; + end case; + + else + Protection_Subtype := + New_Reference_To (RTE (RE_Protection), Loc); + end if; + + Object_Comp := + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uObject), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => True, + Subtype_Indication => Protection_Subtype)); + end; + + -- Put the _Object component after the private component so that it + -- be finalized early as required by 9.4 (20) + + Append_To (Cdecls, Object_Comp); + end if; Insert_After (Current_Node, Rec_Decl); Current_Node := Rec_Decl; @@ -13149,9 +12932,12 @@ package body Exp_Ch9 is end if; -- Step 2: Create the Protection object and build its declaration for - -- any protected entry (family) of subprogram. + -- any protected entry (family) of subprogram. Note for the lock-free + -- implementation, the Protection object is not needed anymore. - if Is_Protected then + if Is_Protected + and then not Uses_Lock_Free (Conc_Typ) + then declare Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R'); Prot_Typ : RE_Id; @@ -13612,191 +13398,200 @@ package body Exp_Ch9 is Args := New_List; - -- Object parameter. This is a pointer to the object of type - -- Protection used by the GNARL to control the protected object. - - Append_To (Args, - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => Make_Identifier (Loc, Name_uObject)), - Attribute_Name => Name_Unchecked_Access)); - - -- Priority parameter. Set to Unspecified_Priority unless there is a - -- priority pragma, in which case we take the value from the pragma, - -- or there is an interrupt pragma and no priority pragma, and we - -- set the ceiling to Interrupt_Priority'Last, an implementation- - -- defined value, see D.3(10). - - if Present (Pdef) - and then Has_Pragma_Priority (Pdef) - then - declare - Prio : constant Node_Id := - Expression - (First - (Pragma_Argument_Associations - (Find_Task_Or_Protected_Pragma - (Pdef, Name_Priority)))); - Temp : Entity_Id; - - begin - -- If priority is a static expression, then we can duplicate it - -- with no problem and simply append it to the argument list. - - if Is_Static_Expression (Prio) then - Append_To (Args, - Duplicate_Subexpr_No_Checks (Prio)); - - -- Otherwise, the priority may be a per-object expression, if it - -- depends on a discriminant of the type. In this case, create - -- local variable to capture the expression. Note that it is - -- really necessary to create this variable explicitly. It might - -- be thought that removing side effects would the appropriate - -- approach, but that could generate declarations improperly - -- placed in the enclosing scope. - - -- Note: Use System.Any_Priority as the expected type for the - -- non-static priority expression, in case the expression has not - -- been analyzed yet (as occurs for example with pragma - -- Interrupt_Priority). - - else - Temp := Make_Temporary (Loc, 'R', Prio); - Append_To (L, - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => - New_Occurrence_Of (RTE (RE_Any_Priority), Loc), - Expression => Relocate_Node (Prio))); - - Append_To (Args, New_Occurrence_Of (Temp, Loc)); - end if; - end; + -- For lock-free implementation, skip initializations of the Protection + -- object. - -- When no priority is specified but an xx_Handler pragma is, we default - -- to System.Interrupts.Default_Interrupt_Priority, see D.3(10). + if not Uses_Lock_Free (Defining_Identifier (Pdec)) then + -- Object parameter. This is a pointer to the object of type + -- Protection used by the GNARL to control the protected object. - elsif Has_Attach_Handler (Ptyp) - or else Has_Interrupt_Handler (Ptyp) - then Append_To (Args, - New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc)); + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)); + + -- Priority parameter. Set to Unspecified_Priority unless there is a + -- priority pragma, in which case we take the value from the pragma, + -- or there is an interrupt pragma and no priority pragma, and we + -- set the ceiling to Interrupt_Priority'Last, an implementation- + -- defined value, see D.3(10). + + if Present (Pdef) + and then Has_Pragma_Priority (Pdef) + then + declare + Prio : constant Node_Id := + Expression + (First + (Pragma_Argument_Associations + (Find_Task_Or_Protected_Pragma + (Pdef, Name_Priority)))); + Temp : Entity_Id; - -- Normal case, no priority or xx_Handler specified, default priority + begin + -- If priority is a static expression, then we can duplicate it + -- with no problem and simply append it to the argument list. - else - Append_To (Args, - New_Reference_To (RTE (RE_Unspecified_Priority), Loc)); - end if; + if Is_Static_Expression (Prio) then + Append_To (Args, + Duplicate_Subexpr_No_Checks (Prio)); - -- Test for Compiler_Info parameter. This parameter allows entry body - -- procedures and barrier functions to be called from the runtime. It - -- is a pointer to the record generated by the compiler to represent - -- the protected object. + -- Otherwise, the priority may be a per-object expression, if + -- it depends on a discriminant of the type. In this case, + -- create local variable to capture the expression. Note that + -- it is really necessary to create this variable explicitly. + -- It might be thought that removing side effects would the + -- appropriate approach, but that could generate declarations + -- improperly placed in the enclosing scope. - -- A protected type without entries that covers an interface and - -- overrides the abstract routines with protected procedures is - -- considered equivalent to a protected type with entries in the - -- context of dispatching select statements. + -- Note: Use System.Any_Priority as the expected type for the + -- non-static priority expression, in case the expression has + -- not been analyzed yet (as occurs for example with pragma + -- Interrupt_Priority). - if Has_Entry - or else Has_Interfaces (Protect_Rec) - or else - ((Has_Attach_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp)) - and then not Restriction_Active (No_Dynamic_Attachment)) - then - declare - Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); + else + Temp := Make_Temporary (Loc, 'R', Prio); + Append_To (L, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any_Priority), Loc), + Expression => Relocate_Node (Prio))); + + Append_To (Args, New_Occurrence_Of (Temp, Loc)); + end if; + end; - Called_Subp : RE_Id; + -- When no priority is specified but an xx_Handler pragma is, we + -- default to System.Interrupts.Default_Interrupt_Priority, see + -- D.3(10). - begin - case Pkg_Id is - when System_Tasking_Protected_Objects_Entries => - Called_Subp := RE_Initialize_Protection_Entries; + elsif Has_Attach_Handler (Ptyp) + or else Has_Interrupt_Handler (Ptyp) + then + Append_To (Args, + New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc)); - when System_Tasking_Protected_Objects => - Called_Subp := RE_Initialize_Protection; + -- Normal case, no priority or xx_Handler specified, default priority - when System_Tasking_Protected_Objects_Single_Entry => - Called_Subp := RE_Initialize_Protection_Entry; + else + Append_To (Args, + New_Reference_To (RTE (RE_Unspecified_Priority), Loc)); + end if; - when others => - raise Program_Error; - end case; + -- Test for Compiler_Info parameter. This parameter allows entry body + -- procedures and barrier functions to be called from the runtime. It + -- is a pointer to the record generated by the compiler to represent + -- the protected object. + + -- A protected type without entries that covers an interface and + -- overrides the abstract routines with protected procedures is + -- considered equivalent to a protected type with entries in the + -- context of dispatching select statements. + + if Has_Entry + or else Has_Interfaces (Protect_Rec) + or else + ((Has_Attach_Handler (Ptyp) or else Has_Interrupt_Handler (Ptyp)) + and then not Restriction_Active (No_Dynamic_Attachment)) + then + declare + Pkg_Id : constant RTU_Id := + Corresponding_Runtime_Package (Ptyp); - if Has_Entry - or else not Restricted - or else Has_Interfaces (Protect_Rec) - then - Append_To (Args, - Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Attribute_Name => Name_Address)); - end if; + Called_Subp : RE_Id; - -- Entry_Bodies parameter. This is a pointer to an array of - -- pointers to the entry body procedures and barrier functions of - -- the object. If the protected type has no entries this object - -- will not exist, in this case, pass a null. + begin + case Pkg_Id is + when System_Tasking_Protected_Objects_Entries => + Called_Subp := RE_Initialize_Protection_Entries; - if Has_Entry then - P_Arr := Entry_Bodies_Array (Ptyp); + when System_Tasking_Protected_Objects => + Called_Subp := RE_Initialize_Protection; - Append_To (Args, - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (P_Arr, Loc), - Attribute_Name => Name_Unrestricted_Access)); + when System_Tasking_Protected_Objects_Single_Entry => + Called_Subp := RE_Initialize_Protection_Entry; + + when others => + raise Program_Error; + end case; - if Pkg_Id = System_Tasking_Protected_Objects_Entries then + if Has_Entry + or else not Restricted + or else Has_Interfaces (Protect_Rec) + then + Append_To (Args, + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Attribute_Name => Name_Address)); + end if; - -- Find index mapping function (clumsy but ok for now) + -- Entry_Bodies parameter. This is a pointer to an array of + -- pointers to the entry body procedures and barrier functions + -- of the object. If the protected type has no entries this + -- object will not exist, in this case, pass a null. - while Ekind (P_Arr) /= E_Function loop - Next_Entity (P_Arr); - end loop; + if Has_Entry then + P_Arr := Entry_Bodies_Array (Ptyp); Append_To (Args, Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (P_Arr, 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 Pkg_Id = System_Tasking_Protected_Objects_Entries then - 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)); + -- Find index mapping function (clumsy but ok for now) + + while Ekind (P_Arr) /= E_Function loop + Next_Entity (P_Arr); + end loop; + + Append_To (Args, + 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; - end if; - elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then - Append_To (Args, Make_Null (Loc)); + elsif Pkg_Id = + System_Tasking_Protected_Objects_Single_Entry + then + Append_To (Args, Make_Null (Loc)); - 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; + 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, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (Called_Subp), Loc), + Parameter_Associations => Args)); + end; + else Append_To (L, Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (Called_Subp), Loc), + Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc), Parameter_Associations => Args)); - end; - else - Append_To (L, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc), - Parameter_Associations => Args)); + end if; end if; if Has_Attach_Handler (Ptyp) then @@ -13868,15 +13663,18 @@ package body Exp_Ch9 is Parameter_Associations => Args)); else - -- First, prepends the _object argument + if not Uses_Lock_Free (Defining_Identifier (Pdec)) then + -- First, prepends the _object argument - Prepend_To (Args, - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), - Selector_Name => Make_Identifier (Loc, Name_uObject)), - Attribute_Name => Name_Unchecked_Access)); + Prepend_To (Args, + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => + Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)); + end if; -- Then, insert call to Install_Handlers |