diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 36 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 94 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/exp_fixd.adb | 27 | ||||
| -rw-r--r-- | gcc/ada/exp_spark.adb | 27 | ||||
| -rw-r--r-- | gcc/ada/opt.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/opt.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 4 |
10 files changed, 169 insertions, 59 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 59ee6e5..5eff9e2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,39 @@ +2017-05-02 Eric Botcazou <ebotcazou@adacore.com> + + * opt.ads: Add missing GNAT markers in comments. + * opt.adb (Set_Opt_Config_Switches): Do not override earlier + settings of Optimize_Alignment at the end. + +2017-05-02 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb (Apply_Constraint_Check): Do not apply + a discriminant check when the associated type is a constrained + subtype created for an unconstrained nominal type. + * exp_attr.adb: Minor reformatting. + +2017-05-02 Bob Duff <duff@adacore.com> + + * sem_ch3.adb (OK_For_Limited_Init_In_05): Handle correctly + the N_Raise_Expression case. + * sem_ch6.adb (Check_Limited_Return): Minor: clarify comment, + and add assertions. + +2017-05-02 Yannick Moy <moy@adacore.com> + + * exp_ch4.adb (Expand_N_Op_Ne): Do not bump parenthese level and + optimize length comparison in GNATprove mode. + * exp_spark.adb (Expand_SPARK_Op_Ne): New function to rewrite + operator /= into negation of operator = when needed. + (Expand_SPARK): Call new + function to expand operator /=. + +2017-05-02 Ed Schonberg <schonberg@adacore.com> + + * exp_fixd.adb (Expand_Divide_Fixed_By_Fixed_Giving_Fixed): + Simplify the expression for a fixed-fixed division to remove + divisions by constants whenever possible, as an optimization + for restricted targets. + 2017-05-02 Hristian Kirtchev <kirtchev@adacore.com> * checks.adb, sem_ch3.adb, sem_ch6.adb: Minor reformatting. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 40f4e65..e8f38f9 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -1355,8 +1355,13 @@ package body Checks is Apply_Range_Check (N, Typ); + -- Do not install a discriminant check for a constrained subtype + -- created for an unconstrained nominal type because the subtype + -- has the correct constraints by construction. + elsif Has_Discriminants (Base_Type (Desig_Typ)) - and then Is_Constrained (Desig_Typ) + and then Is_Constrained (Desig_Typ) + and then not Is_Constr_Subt_For_U_Nominal (Desig_Typ) then Apply_Discriminant_Check (N, Typ); end if; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 4d8417a..79560ae 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -83,6 +83,9 @@ package body Exp_Attr is -- value returned is the entity of the constructed function body. We do not -- bother to generate a separate spec for this subprogram. + function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id; + -- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter + function Build_Record_VS_Func (R_Type : Entity_Id; Nod : Node_Id) return Entity_Id; @@ -354,6 +357,23 @@ package body Exp_Attr is return Func_Id; end Build_Array_VS_Func; + --------------------------------- + -- Build_Disp_Get_Task_Id_Call -- + --------------------------------- + + function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id is + Typ : constant Entity_Id := Etype (Actual); + Id : constant Node_Id := + New_Occurrence_Of + (Find_Prim_Op (Typ, Name_uDisp_Get_Task_Id), Sloc (Actual)); + Result : constant Node_Id := + Make_Function_Call (Sloc (Actual), + Name => Id, + Parameter_Associations => New_List (Actual)); + begin + return Result; + end Build_Disp_Get_Task_Id_Call; + -------------------------- -- Build_Record_VS_Func -- -------------------------- @@ -2469,6 +2489,7 @@ package body Exp_Attr is -- Transforms 'Callable attribute into a call to the Callable function when Attribute_Callable => + -- We have an object of a task interface class-wide type as a prefix -- to Callable. Generate: -- callable (Task_Id (Pref._disp_get_task_id)); @@ -2478,29 +2499,18 @@ package body Exp_Attr is and then Is_Interface (Ptyp) and then Is_Task_Interface (Ptyp) then - declare - Id : constant Node_Id := - New_Occurrence_Of - (Find_Prim_Op (Ptyp, Name_uDisp_Get_Task_Id), Loc); - Call : constant Node_Id := - Make_Function_Call (Loc, - Name => Id, - Parameter_Associations => New_List (Pref)); - begin - Rewrite (N, - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Callable), Loc), - Parameter_Associations => New_List ( - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), - Expression => Call)))); - end; + Rewrite (N, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Callable), Loc), + Parameter_Associations => New_List ( + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), + Expression => Build_Disp_Get_Task_Id_Call (Pref))))); else - Rewrite (N, - Build_Call_With_Task (Pref, RTE (RE_Callable))); + Rewrite (N, Build_Call_With_Task (Pref, RTE (RE_Callable))); end if; Analyze_And_Resolve (N, Standard_Boolean); @@ -3581,17 +3591,9 @@ package body Exp_Attr is and then Is_Interface (Ptyp) and then Is_Task_Interface (Ptyp) then - declare - Id : constant Node_Id := - New_Occurrence_Of - (Find_Prim_Op (Ptyp, Name_uDisp_Get_Task_Id), Loc); - Call : constant Node_Id := - Make_Function_Call (Loc, - Name => Id, - Parameter_Associations => New_List (Pref)); - begin - Rewrite (N, Unchecked_Convert_To (Id_Kind, Call)); - end; + Rewrite + (N, Unchecked_Convert_To + (Id_Kind, Build_Disp_Get_Task_Id_Call (Pref))); else Rewrite (N, @@ -6278,25 +6280,15 @@ package body Exp_Attr is and then Is_Interface (Ptyp) and then Is_Task_Interface (Ptyp) then - declare - Id : constant Node_Id := - New_Occurrence_Of - (Find_Prim_Op (Ptyp, Name_uDisp_Get_Task_Id), Loc); - Call : constant Node_Id := - Make_Function_Call (Loc, - Name => Id, - Parameter_Associations => New_List (Pref)); - begin - Rewrite (N, - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Terminated), Loc), - Parameter_Associations => New_List ( - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), - Expression => Call)))); - end; + Rewrite (N, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Terminated), Loc), + Parameter_Associations => New_List ( + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), + Expression => Build_Disp_Get_Task_Id_Call (Pref))))); elsif Restricted_Profile then Rewrite (N, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 57691b9..eccfcd2 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -8926,6 +8926,9 @@ package body Exp_Ch4 is -- the same visibility as in the generic unit. This avoids duplicating -- or factoring the complex code for record/array equality tests etc. + -- This case is also used for the minimal expansion performed in + -- GNATprove mode. + else declare Loc : constant Source_Ptr := Sloc (N); @@ -8941,7 +8944,14 @@ package body Exp_Ch4 is Make_Op_Eq (Loc, Left_Opnd => Left_Opnd (N), Right_Opnd => Right_Opnd (N))); - Set_Paren_Count (Right_Opnd (Neg), 1); + + -- The level of parentheses is useless in GNATprove mode, and + -- bumping its level here leads to wrong columns being used in + -- check messages, hence skip it in this mode. + + if not GNATprove_Mode then + Set_Paren_Count (Right_Opnd (Neg), 1); + end if; if Scope (Ne) /= Standard_Standard then Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne)); @@ -8958,7 +8968,12 @@ package body Exp_Ch4 is end; end if; - Optimize_Length_Comparison (N); + -- No need for optimization in GNATprove mode, where we would rather see + -- the original source expression. + + if not GNATprove_Mode then + Optimize_Length_Comparison (N); + end if; end Expand_N_Op_Ne; --------------------- diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index 97bc99b..6d31eb8 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -2008,6 +2008,31 @@ package body Exp_Fixd is else Do_Divide_Fixed_Fixed (N); + + -- A focused optimization: if after constant folding the + -- expression is of the form: T ((Exp * D) / D), where D is + -- a static constant, return T (Exp). This form will show up + -- when D is the denominator of the static expression for the + -- 'small of fixed-point types involved. This transformation + -- removes a division that may be expensive on some targets. + + if Nkind (N) = N_Type_Conversion + and then Nkind (Expression (N)) = N_Op_Divide + then + declare + Num : constant Node_Id := Left_Opnd (Expression (N)); + Den : constant Node_Id := Right_Opnd (Expression (N)); + + begin + if Nkind (Den) = N_Integer_Literal + and then Nkind (Num) = N_Op_Multiply + and then Nkind (Right_Opnd (Num)) = N_Integer_Literal + and then Intval (Den) = Intval (Right_Opnd (Num)) + then + Rewrite (Expression (N), Left_Opnd (Num)); + end if; + end; + end if; end if; end Expand_Divide_Fixed_By_Fixed_Giving_Fixed; diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index 7062e13..785652e 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -26,6 +26,7 @@ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; +with Exp_Ch4; with Exp_Ch5; use Exp_Ch5; with Exp_Dbug; use Exp_Dbug; with Exp_Util; use Exp_Util; @@ -62,6 +63,9 @@ package body Exp_SPARK is procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id); -- Perform name evaluation for a renamed object + procedure Expand_SPARK_Op_Ne (N : Node_Id); + -- Rewrite operator /= based on operator = when defined explicitly + ------------------ -- Expand_SPARK -- ------------------ @@ -125,6 +129,9 @@ package body Exp_SPARK is when N_Object_Renaming_Declaration => Expand_SPARK_N_Object_Renaming_Declaration (N); + when N_Op_Ne => + Expand_SPARK_Op_Ne (N); + when N_Freeze_Entity => if Is_Type (Entity (N)) then Expand_SPARK_Freeze_Type (Entity (N)); @@ -291,6 +298,26 @@ package body Exp_SPARK is Evaluate_Name (Name (N)); end Expand_SPARK_N_Object_Renaming_Declaration; + ------------------------ + -- Expand_SPARK_Op_Ne -- + ------------------------ + + procedure Expand_SPARK_Op_Ne (N : Node_Id) is + Typ : constant Entity_Id := Etype (Left_Opnd (N)); + + begin + -- Case of elementary type with standard operator + + if Is_Elementary_Type (Typ) + and then Sloc (Entity (N)) = Standard_Location + then + null; + + else + Exp_Ch4.Expand_N_Op_Ne (N); + end if; + end Expand_SPARK_Op_Ne; + ------------------------------------- -- Expand_SPARK_Potential_Renaming -- ------------------------------------- diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index f1ce4a4..91642ed 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -219,11 +219,11 @@ package body Opt is External_Name_Exp_Casing := As_Is; External_Name_Imp_Casing := Lowercase; Optimize_Alignment := 'O'; + Optimize_Alignment_Local := True; Persistent_BSS_Mode := False; Prefix_Exception_Messages := True; Uneval_Old := 'E'; Use_VADS_Size := False; - Optimize_Alignment_Local := True; -- Note: we do not need to worry about Warnings_As_Errors_Count since -- we do not expect to get any warnings from compiling such a unit. @@ -293,7 +293,6 @@ package body Opt is Default_Pool := Default_Pool_Config; Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config; Fast_Math := Fast_Math_Config; - Optimize_Alignment := Optimize_Alignment_Config; Polling_Required := Polling_Required_Config; end Set_Opt_Config_Switches; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 09ed571..c73b622 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1194,10 +1194,12 @@ package Opt is -- type with the semantics that each value does more than the previous one. Optimize_Alignment : Character := 'O'; + -- GNAT -- Setting of Optimize_Alignment, set to T/S/O for time/space/off. Can -- be modified by use of pragma Optimize_Alignment. Optimize_Alignment_Local : Boolean := False; + -- GNAT -- Set True if Optimize_Alignment mode is set by a local configuration -- pragma that overrides the gnat.adc (or other configuration file) default -- so that the unit is not dependent on the default setting. Also always @@ -1213,10 +1215,12 @@ package Opt is Optimization_Level : Int; pragma Import (C, Optimization_Level, "optimize"); + -- GNAT -- Constant reflecting the optimization level (0,1,2,3 for -O0,-O1,-O2,-O3) Optimize_Size : Int; pragma Import (C, Optimize_Size, "optimize_size"); + -- GNAT -- Constant reflecting setting of -Os (optimize for size). Set to nonzero -- in -Os mode and set to zero otherwise. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 9ad370f..4f7691b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -19316,6 +19316,11 @@ package body Sem_Ch3 is when N_Attribute_Reference => return Attribute_Name (Original_Node (Exp)) = Name_Input; + -- "return raise ..." is OK + + when N_Raise_Expression => + return True; + -- For a case expression, all dependent expressions must be legal when N_Case_Expression => diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5c31c42..61e4f86 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -5996,9 +5996,11 @@ package body Sem_Ch6 is & "(RM-2005 6.5(5.5/2))?y?", Expr); end if; - -- Ada 95 mode, compatibility warnings disabled + -- Ada 95 mode, and compatibility warnings disabled else + pragma Assert (Ada_Version <= Ada_95); + pragma Assert (not (Warn_On_Ada_2005_Compatibility or GNAT_Mode)); return; -- skip continuation messages below end if; |