diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 36 |
4 files changed, 51 insertions, 32 deletions
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 84594ed..bbb53fc 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7589,6 +7589,13 @@ package body Exp_Ch3 is Typ => Base_Typ); end if; + -- Renaming an expression of the object's type is immediate + + elsif Rewrite_As_Renaming + and then Base_Type (Etype (Expr_Q)) = Base_Type (Typ) + then + null; + elsif Tagged_Type_Expansion then declare Iface : constant Entity_Id := Root_Type (Typ); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index d3a4f57..31823ea 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -698,11 +698,14 @@ package body Exp_Ch4 is -- recursion and inappropriate call to Initialize. -- We don't want to remove side effects when the expression must be - -- built in place. In the case of a build-in-place function call, - -- that could lead to a duplication of the call, which was already - -- substituted for the allocator. + -- built in place and we don't need it when there is no storage pool + -- or this is a return/secondary stack allocation. - if not Aggr_In_Place then + if not Aggr_In_Place + and then Present (Storage_Pool (N)) + and then not Is_RTE (Storage_Pool (N), RE_RS_Pool) + and then not Is_RTE (Storage_Pool (N), RE_SS_Pool) + then Remove_Side_Effects (Exp); end if; @@ -747,7 +750,7 @@ package body Exp_Ch4 is -- Processing for allocators returning non-interface types - if not Is_Interface (Directly_Designated_Type (PtrT)) then + if not Is_Interface (DesigT) then if Aggr_In_Place then Temp_Decl := Make_Object_Declaration (Loc, @@ -960,8 +963,9 @@ package body Exp_Ch4 is if Needs_Finalization (DesigT) and then Needs_Finalization (T) - and then not Aggr_In_Place and then not Is_Limited_View (T) + and then not Aggr_In_Place + and then Nkind (Exp) /= N_Function_Call and then not For_Special_Return_Object (N) then -- An unchecked conversion is needed in the classwide case because @@ -993,7 +997,7 @@ package body Exp_Ch4 is -- component containing the secondary dispatch table of the interface -- type. - if Is_Interface (Directly_Designated_Type (PtrT)) then + if Is_Interface (DesigT) then Displace_Allocator_Pointer (N); end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 503fdc1..7abf25e 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5133,14 +5133,11 @@ package body Exp_Ch6 is -- Another optimization: if the returned value is used to initialize an -- object, then no need to copy/readjust/finalize, we can initialize it - -- in place. However, if the call returns on the secondary stack or this - -- is a special return object, then we need the expansion because we'll - -- be renaming the temporary as the (permanent) object. + -- in place. However, if the call returns on the secondary stack, then + -- we need the expansion because we'll be renaming the temporary as the + -- (permanent) object. - if Nkind (Par) = N_Object_Declaration - and then not Use_Sec_Stack - and then not Is_Special_Return_Object (Defining_Entity (Par)) - then + if Nkind (Par) = N_Object_Declaration and then not Use_Sec_Stack then return; end if; @@ -6745,7 +6742,7 @@ package body Exp_Ch6 is null; -- Optimize the case where the result is a function call that also - -- returns on the secondary stack. In this case the result is already + -- returns on the secondary stack; in this case the result is already -- on the secondary stack and no further processing is required. elsif Exp_Is_Function_Call @@ -6781,13 +6778,14 @@ package body Exp_Ch6 is -- gigi is not able to properly allocate class-wide types. -- But optimize the case where the result is a function call that - -- also needs finalization. In this case the result can directly be + -- also needs finalization; in this case the result can directly be -- allocated on the secondary stack and no further processing is - -- required. + -- required, unless the returned object is an interface. elsif CW_Or_Needs_Finalization (Utyp) - and then not (Exp_Is_Function_Call - and then Needs_Finalization (Exp_Typ)) + and then (Is_Interface (R_Type) + or else not (Exp_Is_Function_Call + and then Needs_Finalization (Exp_Typ))) then declare Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index cac0d84..f86b938 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5820,7 +5820,6 @@ package body Exp_Util is -- discriminants. else - Remove_Side_Effects (Exp); Rewrite (Subtype_Indic, Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type))); end if; @@ -5885,7 +5884,6 @@ package body Exp_Util is end if; else - Remove_Side_Effects (Exp); Rewrite (Subtype_Indic, Make_Subtype_From_Expr (Exp, Unc_Type, Related_Id)); end if; @@ -9496,12 +9494,13 @@ package body Exp_Util is Root_Utyp : constant Entity_Id := Underlying_Type (Root_Typ); List_Def : constant List_Id := Empty_List; Comp_List : constant List_Id := New_List; + Equiv_Type : Entity_Id; Range_Type : Entity_Id; Str_Type : Entity_Id; Constr_Root : Entity_Id; + Size_Attr : Node_Id; Size_Expr : Node_Id; - Size_Pref : Node_Id; function Has_Tag_Of_Type (Exp : Node_Id) return Boolean; -- Return True if expression Exp of a tagged type is known to statically @@ -9597,9 +9596,26 @@ package body Exp_Util is -- the _Size primitive operation. if Has_Tag_Of_Type (E) then - Size_Pref := Duplicate_Subexpr_No_Checks (E); + if not Has_Discriminants (Etype (E)) + or else Is_Constrained (Etype (E)) + then + Size_Attr := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (E), Loc), + Attribute_Name => Name_Object_Size); + + else + Size_Attr := + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr_No_Checks (E), + Attribute_Name => Name_Size); + end if; + else - Size_Pref := OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)); + Size_Attr := + Make_Attribute_Reference (Loc, + Prefix => OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)), + Attribute_Name => Name_Size); end if; if not Is_Interface (Root_Typ) then @@ -9610,10 +9626,7 @@ package body Exp_Util is Size_Expr := Make_Op_Subtract (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => Size_Pref, - Attribute_Name => Name_Size), + Left_Opnd => Size_Attr, Right_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Constr_Root, Loc), @@ -9625,10 +9638,7 @@ package body Exp_Util is Size_Expr := Make_Op_Subtract (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => Size_Pref, - Attribute_Name => Name_Size), + Left_Opnd => Size_Attr, Right_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (RTE (RE_Tag), Loc), |