diff options
| -rw-r--r-- | gcc/ada/einfo.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 123 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 31 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 368 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 41 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 15 |
9 files changed, 455 insertions, 147 deletions
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 1a8760c..0254652 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2804,6 +2804,10 @@ package Einfo is -- case of private and incomplete types, this flag is set in both the -- partial view and the full view. +-- This flag is also set on the Master_Node objects generated by the +-- compiler (see Finalization_Master_Node above) to indicate that the +-- associated finalizable object has relaxed finalization semantics. + -- Is_Initial_Condition_Procedure -- Defined in functions and procedures. Set for a generated procedure -- which verifies the assumption of pragma Initial_Condition at run time. diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 344e4d1..1f1f580 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4119,7 +4119,6 @@ package body Exp_Aggr is -- Local variables - Parent_Kind : Node_Kind; Parent_Node : Node_Id; -- Start of processing for In_Place_Assign_OK @@ -4132,11 +4131,9 @@ package body Exp_Aggr is end if; Parent_Node := Parent (N); - Parent_Kind := Nkind (Parent_Node); - if Parent_Kind = N_Qualified_Expression then + if Nkind (Parent_Node) = N_Qualified_Expression then Parent_Node := Parent (Parent_Node); - Parent_Kind := Nkind (Parent_Node); end if; -- On assignment, sliding can take place, so we cannot do the @@ -4161,44 +4158,11 @@ package body Exp_Aggr is procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); - function Known_Size (Decl : Node_Id; Cond_Init : Boolean) return Boolean; - -- Decl is an N_Object_Declaration node. Return true if it declares an - -- object with a known size; in this context, that is always the case, - -- except for a declaration without explicit constraints of an object, - -- either whose nominal subtype is class-wide, or whose initialization - -- contains a conditional expression and whose nominal subtype is both - -- discriminated and unconstrained. - - ---------------- - -- Known_Size -- - ---------------- - - function Known_Size (Decl : Node_Id; Cond_Init : Boolean) return Boolean - is - begin - if Is_Entity_Name (Object_Definition (Decl)) then - declare - Typ : constant Entity_Id := Entity (Object_Definition (Decl)); - - begin - return not Is_Class_Wide_Type (Typ) - and then not (Cond_Init - and then Has_Discriminants (Typ) - and then not Is_Constrained (Typ)); - end; - - else - return True; - end if; - end Known_Size; - -- Local variables Aggr_Code : List_Id; Full_Typ : Entity_Id; - In_Cond_Expr : Boolean; Instr : Node_Id; - Node : Node_Id; Parent_Node : Node_Id; Target_Expr : Node_Id; Temp : Entity_Id; @@ -4210,40 +4174,11 @@ package body Exp_Aggr is pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N)); pragma Assert (Is_Record_Type (Typ)); - In_Cond_Expr := False; - Node := N; - Parent_Node := Parent (Node); - - -- First, climb the parent chain, looking through qualified expressions - -- and dependent expressions of conditional expressions. - - loop - case Nkind (Parent_Node) is - when N_Case_Expression_Alternative => - null; - - when N_Case_Expression => - exit when Node = Expression (Parent_Node); - In_Cond_Expr := True; - - when N_If_Expression => - exit when Node = First (Expressions (Parent_Node)); - In_Cond_Expr := True; - - when N_Qualified_Expression => - null; - - when others => - exit; - end case; - - Node := Parent_Node; - Parent_Node := Parent (Node); - end loop; - -- Set the Expansion_Delayed flag in the cases where the transformation -- will be done top down from above. + Parent_Node := Unconditional_Parent (N); + if -- Internal aggregates (transformed when expanding the parent), -- excluding container aggregates as these are transformed into @@ -4259,11 +4194,15 @@ package body Exp_Aggr is or else Nkind (Parent_Node) = N_Allocator - -- Object declaration (see Convert_Aggr_In_Object_Decl). So far only - -- declarations with a known size are supported. + -- Object declaration (see Convert_Aggr_In_Object_Decl). Class-wide + -- declarations are excluded so far. or else (Nkind (Parent_Node) = N_Object_Declaration - and then Known_Size (Parent_Node, In_Cond_Expr)) + and then not + (Is_Entity_Name (Object_Definition (Parent_Node)) + and then + Is_Class_Wide_Type + (Entity (Object_Definition (Parent_Node))))) -- Safe assignment (see Convert_Aggr_In_Assignment). So far only the -- assignments in init procs are taken into account. @@ -5894,7 +5833,6 @@ package body Exp_Aggr is -- Holds the declaration of Tmp Parent_Node : Node_Id; - Parent_Kind : Node_Kind; -- Start of processing for Expand_Array_Aggregate @@ -6110,13 +6048,7 @@ package body Exp_Aggr is -- Set the Expansion_Delayed flag in the cases where the transformation -- will be done top down from above. - Parent_Node := Parent (N); - Parent_Kind := Nkind (Parent_Node); - - if Parent_Kind = N_Qualified_Expression then - Parent_Node := Parent (Parent_Node); - Parent_Kind := Nkind (Parent_Node); - end if; + Parent_Node := Unconditional_Parent (N); if -- Internal aggregates (transformed when expanding the parent), @@ -6124,10 +6056,10 @@ package body Exp_Aggr is -- subprogram calls later. So far aggregates with self-references -- are not supported if they appear in a conditional expression. - (Parent_Kind = N_Component_Association + (Nkind (Parent_Node) = N_Component_Association and then not Is_Container_Aggregate (Parent (Parent_Node))) - or else (Parent_Kind in N_Aggregate | N_Extension_Aggregate + or else (Nkind (Parent_Node) in N_Aggregate | N_Extension_Aggregate and then not Is_Container_Aggregate (Parent_Node)) -- Allocator (see Convert_Aggr_In_Allocator). Sliding cannot be done @@ -6146,7 +6078,7 @@ package body Exp_Aggr is -- Object declaration (see Convert_Aggr_In_Object_Decl). Sliding -- cannot be done in place for the time being. - or else (Parent_Kind = N_Object_Declaration + or else (Nkind (Parent_Node) = N_Object_Declaration and then (Aggr_Assignment_OK_For_Backend (N) or else Is_Limited_Type (Typ) @@ -6163,7 +6095,7 @@ package body Exp_Aggr is -- assignments in init procs are taken into account, as well those -- directly performed by the back end. - or else (Parent_Kind = N_Assignment_Statement + or else (Nkind (Parent_Node) = N_Assignment_Statement and then (Inside_Init_Proc or else @@ -6174,7 +6106,16 @@ package body Exp_Aggr is or else Is_Build_In_Place_Aggregate_Return (Parent_Node) then - Set_Expansion_Delayed (N, not Static_Array_Aggregate (N)); + if not Static_Array_Aggregate (N) then + -- Mark the aggregate, as well as all the intermediate conditional + -- expressions, as having expansion delayed. This will block the + -- usual (bottom-up) expansion of the marked nodes and replace it + -- with a top-down expansion from the parent node. + + Set_Expansion_Delayed (N); + Delay_Conditional_Expressions_Between (N, Parent_Node); + end if; + return; end if; @@ -6184,6 +6125,14 @@ package body Exp_Aggr is Establish_Transient_Scope (N, Manage_Sec_Stack => False); end if; + -- Now get back to the immediate parent, modulo qualified expression + + Parent_Node := Parent (N); + + if Nkind (Parent_Node) = N_Qualified_Expression then + Parent_Node := Parent (Parent_Node); + end if; + -- STEP 5 -- Check whether in-place aggregate expansion is possible @@ -6193,7 +6142,7 @@ package body Exp_Aggr is -- protected objects or tasks. For other cases we create a temporary. Maybe_In_Place_OK := - Parent_Kind = N_Assignment_Statement + Nkind (Parent_Node) = N_Assignment_Statement and then (Is_Limited_Type (Typ) or else (not Has_Default_Init_Comps (N) and then not Is_Bit_Packed_Array (Typ) @@ -6259,14 +6208,14 @@ package body Exp_Aggr is -- around the aggregate for this purpose. if Ekind (Current_Scope) = E_Loop - and then Parent_Kind = N_Allocator + and then Nkind (Parent_Node) = N_Allocator then Establish_Transient_Scope (N, Manage_Sec_Stack => False); -- If the parent is an assignment for which no controlled actions -- should take place, prevent the temporary from being finalized. - elsif Parent_Kind = N_Assignment_Statement + elsif Nkind (Parent_Node) = N_Assignment_Statement and then No_Ctrl_Actions (Parent_Node) then Mutate_Ekind (Tmp, E_Variable); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 2a0b0e6..afcb0a9 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -38,7 +38,6 @@ with Exp_Ch4; use Exp_Ch4; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; -with Exp_Dbug; use Exp_Dbug; with Exp_Disp; use Exp_Disp; with Exp_Dist; use Exp_Dist; with Exp_Put_Image; @@ -9134,35 +9133,7 @@ package body Exp_Ch3 is -- illegal code if written by hand, but that's OK. if Rewrite_As_Renaming then - Rewrite (N, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Def_Id, - Subtype_Mark => New_Occurrence_Of (Etype (Def_Id), Loc), - Name => Expr_Q)); - - -- Keep original aspects - - Move_Aspects (Original_Node (N), N); - - -- We do not analyze this renaming declaration, because all its - -- components have already been analyzed, and if we were to go - -- ahead and analyze it, we would in effect be trying to generate - -- another declaration of X, which won't do. - - Set_Renamed_Object (Def_Id, Expr_Q); - Set_Analyzed (N); - - -- We do need to deal with debug issues for this renaming - - -- First, if entity comes from source, then mark it as needing - -- debug information, even though it is defined by a generated - -- renaming that does not come from source. - - Set_Debug_Info_Defining_Id (N); - - -- Now call the routine to generate debug info for the renaming - - Insert_Action (N, Debug_Renaming_Declaration (N)); + Rewrite_Object_Declaration_As_Renaming (N, Expr_Q); end if; -- Exception on library entity not available diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7fda622..8db729f 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -191,6 +191,15 @@ package body Exp_Ch4 is -- Return the size of a small signed integer type covering Lo .. Hi, the -- main goal being to return a size lower than that of standard types. + procedure Insert_Conditional_Object_Declaration + (Obj_Id : Entity_Id; + Expr : Node_Id; + Decl : Node_Id); + -- Expr is the dependent expression of a conditional expression and Decl + -- is the declaration of an object whose initialization expression is the + -- conditional expression. Insert in the actions of Expr the declaration + -- of Obj_Id modeled on Decl and with Expr as initialization expression. + procedure Insert_Dereference_Action (N : Node_Id); -- N is an expression whose type is an access. When the type of the -- associated storage pool is derived from Checked_Pool, generate a @@ -4259,7 +4268,7 @@ package body Exp_Ch4 is function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is Idx : Node_Id := First_Index (E); - Len : Node_Id; + Len : Node_Id := Empty; Res : Node_Id := Empty; begin @@ -4987,6 +4996,9 @@ package body Exp_Ch4 is -- Return True if we can copy objects of this type when expanding a case -- expression. + function Is_Optimizable_Declaration (N : Node_Id) return Boolean; + -- Return True if N is an object declaration that can be optimized + ------------------ -- Is_Copy_Type -- ------------------ @@ -4996,12 +5008,28 @@ package body Exp_Ch4 is return Is_Elementary_Type (Underlying_Type (Typ)); end Is_Copy_Type; + -------------------------------- + -- Is_Optimizable_Declaration -- + -------------------------------- + + function Is_Optimizable_Declaration (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Object_Declaration + and then not (Is_Entity_Name (Object_Definition (N)) + and then Is_Class_Wide_Type + (Entity (Object_Definition (N)))) + and then not Is_Return_Object (Defining_Identifier (N)) + and then not Is_Copy_Type (Typ); + end Is_Optimizable_Declaration; + -- Local variables Acts : List_Id; Alt : Node_Id; Case_Stmt : Node_Id; Decl : Node_Id; + New_N : Node_Id; + Par_Obj : Node_Id; Target : Entity_Id := Empty; Target_Typ : Entity_Id; @@ -5035,6 +5063,25 @@ package body Exp_Ch4 is -- This makes the expansion much easier when expressions are calls to -- build-in-place functions. + Optimize_Object_Decl : Boolean := False; + -- Small optimization: when the case expression appears in the context + -- of an object declaration of a type not Is_Copy_Type, expand into + + -- case X is + -- when A => + -- then-obj : typ := then_expr; + -- target := then-obj'Unrestricted_Access; + -- when B => + -- else-obj : typ := else-expr; + -- target := else-obj'Unrestricted_Access; + -- ... + -- end case + -- + -- obj : typ renames target.all; + + -- This makes the expansion much easier when expressions are calls to + -- build-in-place functions. + -- Start of processing for Expand_N_Case_Expression begin @@ -5047,7 +5094,9 @@ package body Exp_Ch4 is declare Uncond_Par : constant Node_Id := Unconditional_Parent (N); begin - if Nkind (Uncond_Par) = N_Simple_Return_Statement then + if Nkind (Uncond_Par) = N_Simple_Return_Statement + or else Is_Optimizable_Declaration (Uncond_Par) + then Delay_Conditional_Expressions_Between (N, Uncond_Par); end if; end; @@ -5065,6 +5114,9 @@ package body Exp_Ch4 is elsif Nkind (Par) = N_Simple_Return_Statement then Optimize_Return_Stmt := True; + elsif Is_Optimizable_Declaration (Par) then + Optimize_Object_Decl := True; + else return; end if; @@ -5148,7 +5200,7 @@ package body Exp_Ch4 is -- No need for Target_Typ in the case of statements if Optimize_Assignment_Stmt or else Optimize_Return_Stmt then - null; + Target_Typ := Empty; -- Scalar/Copy case @@ -5159,7 +5211,7 @@ package body Exp_Ch4 is -- 'Unrestricted_Access. -- Generate: - -- type Ptr_Typ is not null access all Typ; + -- type Ptr_Typ is not null access all [constant] Typ; else Target_Typ := Make_Temporary (Loc, 'P'); @@ -5171,7 +5223,9 @@ package body Exp_Ch4 is Make_Access_To_Object_Definition (Loc, All_Present => True, Null_Exclusion_Present => True, - Subtype_Indication => New_Occurrence_Of (Typ, Loc)))); + Subtype_Indication => New_Occurrence_Of (Typ, Loc), + Constant_Present => + Optimize_Object_Decl and then Constant_Present (Par)))); end if; -- Create the declaration of the target which captures the value of the @@ -5199,11 +5253,19 @@ package body Exp_Ch4 is Alt := First (Alternatives (N)); while Present (Alt) loop + -- When the alternative's expression involves controlled function + -- calls, generated temporaries are chained on the corresponding + -- list of actions. These temporaries need to be finalized after + -- the case expression is evaluated. + + Process_Transients_In_Expression (N, Actions (Alt)); + declare Alt_Loc : constant Source_Ptr := Sloc (Expression (Alt)); Alt_Expr : Node_Id := Relocate_Node (Expression (Alt)); LHS : Node_Id; + Obj : Node_Id; Stmts : List_Id; begin @@ -5240,12 +5302,34 @@ package body Exp_Ch4 is Unanalyze_Delayed_Conditional_Expression (Alt_Expr); end if; + -- Generate: + -- Obj : [constant] Typ := AX; + -- Target := Obj'Unrestricted_Access; + + elsif Optimize_Object_Decl then + Obj := Make_Temporary (Loc, 'C', Alt_Expr); + + Insert_Conditional_Object_Declaration (Obj, Alt_Expr, Par); + + Alt_Expr := + Make_Attribute_Reference (Alt_Loc, + Prefix => New_Occurrence_Of (Obj, Alt_Loc), + Attribute_Name => Name_Unrestricted_Access); + + LHS := New_Occurrence_Of (Target, Loc); + Set_Assignment_OK (LHS); + + Stmts := New_List ( + Make_Assignment_Statement (Alt_Loc, + Name => LHS, + Expression => Alt_Expr)); + -- Take the unrestricted access of the expression value for non- -- scalar types. This approach avoids big copies and covers the -- limited and unconstrained cases. -- Generate: - -- Target := AX['Unrestricted_Access]; + -- Target := AX'Unrestricted_Access; else if not Is_Copy_Type (Typ) then @@ -5288,12 +5372,6 @@ package body Exp_Ch4 is Make_Case_Statement_Alternative (Sloc (Alt), Discrete_Choices => Discrete_Choices (Alt), Statements => Stmts)); - - -- Finalize any transient objects on exit from the alternative. - -- Note that this needs to be done only after Stmts is attached - -- to the Alternatives list above (for Safe_To_Capture_Value). - - Process_Transients_In_Expression (N, Stmts); end; Next (Alt); @@ -5305,24 +5383,48 @@ package body Exp_Ch4 is Rewrite (Par, Case_Stmt); Analyze (Par); + elsif Optimize_Object_Decl then + Append_To (Acts, Case_Stmt); + Insert_Actions (Par, Acts); + + New_N := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Target, Loc)); + + -- The renaming is not analyzed so complete the decoration of the + -- object and set the type of the name directly. + + Par_Obj := Defining_Identifier (Par); + if Constant_Present (Par) then + Mutate_Ekind (Par_Obj, E_Constant); + Set_Is_True_Constant (Par_Obj); + else + Mutate_Ekind (Par_Obj, E_Variable); + end if; + + Set_Etype (New_N, Etype (Par_Obj)); + + Rewrite_Object_Declaration_As_Renaming (Par, New_N); + -- Otherwise rewrite the case expression itself else Append_To (Acts, Case_Stmt); if Is_Copy_Type (Typ) then - Rewrite (N, + New_N := Make_Expression_With_Actions (Loc, Expression => New_Occurrence_Of (Target, Loc), - Actions => Acts)); + Actions => Acts); else Insert_Actions (N, Acts); - Rewrite (N, + New_N := Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Target, Loc))); + Prefix => New_Occurrence_Of (Target, Loc)); end if; + Rewrite (N, New_N); Analyze_And_Resolve (N, Typ); end if; end Expand_N_Case_Expression; @@ -5488,11 +5590,44 @@ package body Exp_Ch4 is -- actions in order to create a temporary to capture the level of the -- expression in each branch. + function Is_Copy_Type (Typ : Entity_Id) return Boolean; + -- Return True if we can copy objects of this type when expanding an if + -- expression. + + function Is_Optimizable_Declaration (N : Node_Id) return Boolean; + -- Return True if N is an object declaration that can be optimized + function OK_For_Single_Subtype (T1, T2 : Entity_Id) return Boolean; -- Return true if it is acceptable to use a single subtype for two -- dependent expressions of subtype T1 and T2 respectively, which are -- unidimensional arrays whose index bounds are known at compile time. + ------------------ + -- Is_Copy_Type -- + ------------------ + + function Is_Copy_Type (Typ : Entity_Id) return Boolean is + Utyp : constant Entity_Id := Underlying_Type (Typ); + + begin + return Is_Definite_Subtype (Utyp) + and then not Is_By_Reference_Type (Utyp); + end Is_Copy_Type; + + -------------------------------- + -- Is_Optimizable_Declaration -- + -------------------------------- + + function Is_Optimizable_Declaration (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Object_Declaration + and then not (Is_Entity_Name (Object_Definition (N)) + and then Is_Class_Wide_Type + (Entity (Object_Definition (N)))) + and then not Is_Return_Object (Defining_Identifier (N)) + and then not Is_Copy_Type (Typ); + end Is_Optimizable_Declaration; + --------------------------- -- OK_For_Single_Subtype -- --------------------------- @@ -5526,7 +5661,7 @@ package body Exp_Ch4 is -- a safe assignment statement, expand into -- if cond then - -- lhs := then-expr + -- lhs := then-expr; -- else -- lhs := else-expr; -- end if; @@ -5539,7 +5674,7 @@ package body Exp_Ch4 is -- a simple return statement, expand into -- if cond then - -- return then-expr + -- return then-expr; -- else -- return else-expr; -- end if; @@ -5547,6 +5682,23 @@ package body Exp_Ch4 is -- This makes the expansion much easier when expressions are calls to -- build-in-place functions. + Optimize_Object_Decl : Boolean := False; + -- Small optimization: when the if expression appears in the context of + -- an object declaration of a type not Is_Copy_Type, expand into + + -- if cond then + -- then-obj : typ := then_expr; + -- target := then-obj'Unrestricted_Access; + -- else + -- else-obj : typ := else-expr; + -- target := else-obj'Unrestricted_Access; + -- end if; + -- + -- obj : typ renames target.all; + + -- This makes the expansion much easier when expressions are calls to + -- build-in-place functions. + -- Start of processing for Expand_N_If_Expression begin @@ -5560,7 +5712,9 @@ package body Exp_Ch4 is declare Uncond_Par : constant Node_Id := Unconditional_Parent (N); begin - if Nkind (Uncond_Par) = N_Simple_Return_Statement then + if Nkind (Uncond_Par) = N_Simple_Return_Statement + or else Is_Optimizable_Declaration (Uncond_Par) + then Delay_Conditional_Expressions_Between (N, Uncond_Par); end if; end; @@ -5578,6 +5732,9 @@ package body Exp_Ch4 is elsif Nkind (Par) = N_Simple_Return_Statement then Optimize_Return_Stmt := True; + elsif Is_Optimizable_Declaration (Par) then + Optimize_Object_Decl := True; + else return; end if; @@ -5685,6 +5842,8 @@ package body Exp_Ch4 is Condition => Relocate_Node (Cond), Then_Statements => New_List (New_Then), Else_Statements => New_List (New_Else)); + Decl := Empty; + New_N := Empty; -- Preserve the original context for which the if statement is -- being generated. This is needed by the finalization machinery @@ -5732,6 +5891,8 @@ package body Exp_Ch4 is Else_Statements => New_List ( Make_Simple_Return_Statement (Sloc (New_Else), Expression => New_Else))); + Decl := Empty; + New_N := Empty; -- Preserve the original context for which the if statement is -- being generated. This is needed by the finalization machinery @@ -5740,6 +5901,99 @@ package body Exp_Ch4 is Set_From_Conditional_Expression (If_Stmt); + elsif Optimize_Object_Decl then + -- When the "then" or "else" expressions involve controlled function + -- calls, generated temporaries are chained on the corresponding list + -- of actions. These temporaries need to be finalized after the if + -- expression is evaluated. + + Process_Transients_In_Expression (N, Then_Actions (N)); + Process_Transients_In_Expression (N, Else_Actions (N)); + + declare + Par_Obj : constant Entity_Id := Defining_Identifier (Par); + Then_Obj : constant Entity_Id := Make_Temporary (Loc, 'C', Thenx); + Else_Obj : constant Entity_Id := Make_Temporary (Loc, 'C', Elsex); + Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); + Target : constant Entity_Id := Make_Temporary (Loc, 'C', N); + + begin + Insert_Conditional_Object_Declaration (Then_Obj, Thenx, Par); + Insert_Conditional_Object_Declaration (Else_Obj, Elsex, Par); + + -- Generate: + -- type Ptr_Typ is not null access all [constant] Typ; + + Insert_Action (Par, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ptr_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Null_Exclusion_Present => True, + Subtype_Indication => New_Occurrence_Of (Typ, Loc), + Constant_Present => Constant_Present (Par)))); + + -- Generate: + -- Target : Ptr_Typ; + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Target, + Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc)); + Set_No_Initialization (Decl); + Insert_Action (Par, Decl); + + -- Generate: + -- if Cond then + -- Target := <Then_Obj>'Unrestricted_Access; + -- else + -- Target := <Else_Obj>'Unrestricted_Access; + -- end if; + + If_Stmt := + Make_Implicit_If_Statement (N, + Condition => Relocate_Node (Cond), + Then_Statements => New_List ( + Make_Assignment_Statement (Sloc (Thenx), + Name => New_Occurrence_Of (Target, Sloc (Thenx)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Then_Obj, Loc), + Attribute_Name => Name_Unrestricted_Access))), + + Else_Statements => New_List ( + Make_Assignment_Statement (Sloc (Elsex), + Name => New_Occurrence_Of (Target, Sloc (Elsex)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Else_Obj, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + + -- Preserve the original context for which the if statement is + -- being generated. This is needed by the finalization machinery + -- to prevent the premature finalization of controlled objects + -- found within the if statement. + + Set_From_Conditional_Expression (If_Stmt); + + New_N := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Target, Loc)); + + -- The renaming is not analyzed so complete the decoration of the + -- object and set the type of the name directly. + + if Constant_Present (Par) then + Mutate_Ekind (Par_Obj, E_Constant); + Set_Is_True_Constant (Par_Obj); + else + Mutate_Ekind (Par_Obj, E_Variable); + end if; + + Set_Etype (New_N, Etype (Par_Obj)); + end; + -- If the result is a unidimensional unconstrained array but the two -- dependent expressions have constrained subtypes with known bounds, -- then we expand as follows: @@ -5984,8 +6238,8 @@ package body Exp_Ch4 is High_Bound => Build_New_Bound (Then_Hi, Else_Hi, Slice_Hi))); end; - -- If the type is by reference or else not definite, then we expand as - -- follows to avoid the possibility of improper copying. + -- If the type cannot be copied, then we expand as follows to avoid the + -- possibility of improper copying. -- type Ptr_Typ is not null access all Typ; -- Target : Ptr; @@ -5999,9 +6253,7 @@ package body Exp_Ch4 is -- and replace the if expression by a reference to Target.all. - elsif Is_By_Reference_Type (Typ) - or else not Is_Definite_Subtype (Typ) - then + elsif not Is_Copy_Type (Typ) then -- When the "then" or "else" expressions involve controlled function -- calls, generated temporaries are chained on the corresponding list -- of actions. These temporaries need to be finalized after the if @@ -6240,6 +6492,10 @@ package body Exp_Ch4 is Rewrite (Par, If_Stmt); Analyze (Par); + elsif Optimize_Object_Decl then + Insert_Action (Par, If_Stmt); + Rewrite_Object_Declaration_As_Renaming (Par, New_N); + -- Otherwise rewrite the if expression itself else @@ -12931,6 +13187,70 @@ package body Exp_Ch4 is end if; end Get_Size_For_Range; + ------------------------------------------- + -- Insert_Conditional_Object_Declaration -- + ------------------------------------------- + + procedure Insert_Conditional_Object_Declaration + (Obj_Id : Entity_Id; + Expr : Node_Id; + Decl : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Expr); + Obj_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Aliased_Present => Aliased_Present (Decl), + Constant_Present => Constant_Present (Decl), + Object_Definition => New_Copy_Tree (Object_Definition (Decl)), + Expression => Relocate_Node (Expr)); + + Master_Node_Decl : Node_Id; + Master_Node_Id : Entity_Id; + + begin + -- If the expression is itself a conditional expression whose + -- expansion has been delayed, analyze it again and expand it. + + if Is_Delayed_Conditional_Expression (Expression (Obj_Decl)) then + Unanalyze_Delayed_Conditional_Expression (Expression (Obj_Decl)); + end if; + + Insert_Action (Expr, Obj_Decl); + + -- If the object needs finalization, we need to insert its Master_Node + -- manually because 1) the machinery in Exp_Ch7 will not pick it since + -- it will be declared in the arm of a conditional statement and 2) we + -- cannot invoke Process_Transients_In_Expression on it since it is not + -- a transient object (it has the lifetime of the original object). + + if Nkind (Obj_Decl) = N_Object_Declaration + and then Needs_Finalization (Base_Type (Etype (Obj_Id))) + then + Master_Node_Id := Make_Temporary (Loc, 'N'); + Master_Node_Decl := + Make_Master_Node_Declaration (Loc, Master_Node_Id, Obj_Id); + + -- The master is the innermost enclosing non-transient construct + + Insert_Action (Find_Hook_Context (Expr), Master_Node_Decl); + + -- Propagate the relaxed finalization semantics + + Set_Is_Independent + (Master_Node_Id, + Has_Relaxed_Finalization (Base_Type (Etype (Obj_Id)))); + + -- Generate the attachment of the object to the Master_Node + + Attach_Object_To_Master_Node (Obj_Decl, Master_Node_Id); + + -- Mark the transient object to avoid double finalization + + Set_Is_Finalized_Transient (Obj_Id); + end if; + end Insert_Conditional_Object_Declaration; + ------------------------------- -- Insert_Dereference_Action -- ------------------------------- diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 39cc9ab..ef5faa1 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5359,7 +5359,8 @@ package body Exp_Ch6 is procedure Expand_Ctrl_Function_Call (N : Node_Id; Use_Sec_Stack : Boolean) is - Par : constant Node_Id := Parent (N); + Par : constant Node_Id := Parent (N); + Uncond_Par : constant Node_Id := Unconditional_Parent (N); begin -- Optimization: if the returned value is returned again, then no need @@ -5368,7 +5369,7 @@ package body Exp_Ch6 is -- Note that simple return statements are distributed into conditional -- expressions but we may be invoked before this distribution is done. - if Nkind (Unconditional_Parent (N)) = N_Simple_Return_Statement then + if Nkind (Uncond_Par) = N_Simple_Return_Statement then return; end if; @@ -5381,8 +5382,15 @@ package body Exp_Ch6 is if Nkind (Par) in N_Object_Declaration | N_Delta_Aggregate and then Expression (Par) = N - and then not Use_Sec_Stack then + if not Use_Sec_Stack then + return; + end if; + + -- Note that object declarations are also distributed into conditional + -- expressions but we may be invoked before this distribution is done. + + elsif Nkind (Uncond_Par) = N_Object_Declaration then return; end if; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 017f16f..171ad4e 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2546,7 +2546,8 @@ package body Exp_Ch7 is elsif Ekind (Obj_Id) = E_Variable and then Is_RTE (Obj_Typ, RE_Master_Node) then - Processing_Actions (Decl); + Processing_Actions + (Decl, Strict => not Is_Independent (Obj_Id)); -- The object is of the form: -- Obj : [constant] Typ [:= Expr]; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 27d8233..e449d45 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -36,6 +36,7 @@ with Exp_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch11; use Exp_Ch11; +with Exp_Dbug; use Exp_Dbug; with Freeze; use Freeze; with Ghost; use Ghost; with Inline; use Inline; @@ -13556,6 +13557,46 @@ package body Exp_Util is return False; end Requires_Cleanup_Actions; + -------------------------------------------- + -- Rewrite_Object_Declaration_As_Renaming -- + -------------------------------------------- + + procedure Rewrite_Object_Declaration_As_Renaming (N, Nam : Node_Id) is + Def_Id : constant Entity_Id := Defining_Identifier (N); + Loc : constant Source_Ptr := Sloc (N); + + begin + Rewrite (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Mark => New_Occurrence_Of (Etype (Def_Id), Loc), + Name => Nam)); + + -- Keep original aspects + + Move_Aspects (Original_Node (N), N); + + -- We do not analyze this renaming declaration, because all its + -- components have already been analyzed, and if we were to go + -- ahead and analyze it, we would in effect be trying to generate + -- another declaration of X, which won't do. + + Set_Renamed_Object (Def_Id, Nam); + Set_Analyzed (N); + + -- We do need to deal with debug issues for this renaming + + -- First, if entity comes from source, then mark it as needing + -- debug information, even though it is defined by a generated + -- renaming that does not come from source. + + Set_Debug_Info_Defining_Id (N); + + -- Now call the routine to generate debug info for the renaming + + Insert_Action (N, Debug_Renaming_Declaration (N)); + end Rewrite_Object_Declaration_As_Renaming; + ------------------------------------ -- Safe_Unchecked_Type_Conversion -- ------------------------------------ diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index fc70ac5..81e51af 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -1243,6 +1243,9 @@ package Exp_Util is -- These cases require special actions on scope exit. Lib_Level is True if -- the construct is at library level, and False otherwise. + procedure Rewrite_Object_Declaration_As_Renaming (N, Nam : Node_Id); + -- Rewrite object declaration N as an object renaming declaration of Nam + function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean; -- Given the node for an N_Unchecked_Type_Conversion, return True if this -- is an unchecked conversion that Gigi can handle directly. Otherwise diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 76ae53b..eb53d59 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4689,11 +4689,22 @@ package body Sem_Ch3 is if Back_End_Inlining and then Expander_Active and then Nkind (E) = N_Function_Call - and then Nkind (Name (E)) in N_Has_Entity + and then Is_Entity_Name (Name (E)) and then Is_Inlined (Entity (Name (E))) and then not Is_Constrained (Etype (E)) - and then Analyzed (N) and then No (Expression (N)) + and then Analyzed (N) + then + goto Leave; + end if; + + -- No further action needed if E is a conditional expression and N + -- has been replaced by a renaming declaration during its expansion + -- (see Expand_N_Case_Expression and Expand_N_If_Expression). + + if Expander_Active + and then Nkind (E) in N_Case_Expression | N_If_Expression + and then Nkind (N) = N_Object_Renaming_Declaration then goto Leave; end if; |