CbC/CbC_gcc: gcc/ada/inline.adb comparison

comparison gcc/ada/inline.adb @ 131:84e7813d76e9

gcc-8.2

author	mir3636
date	Thu, 25 Oct 2018 07:37:49 +0900
parents	04ced10e8804
children	1830386684a0

comparison

equal deleted inserted replaced

-:04ced10e8804
+:84e7813d76e9
 --                                                                          --
 --                               I N L I N E                                --
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2018, 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- --
 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
 --  If a candidate for inlining contains type declarations for types with
 --  nontrivial initialization procedures, they are not worth inlining.
 function Has_Single_Return (N : Node_Id) return Boolean;
 --  In general we cannot inline functions that return unconstrained type.
---  However, we can handle such functions if all return statements return a
+--  However, we can handle such functions if all return statements return
---  local variable that is the only declaration in the body of the function.
+--  a local variable that is the first declaration in the body of the
---  In that case the call can be replaced by that local variable as is done
+--  function. In that case the call can be replaced by that local
---  for other inlined calls.
+--  variable as is done for other inlined calls.
 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean;
 --  Return True if E is in the main unit or its spec or in a subunit
 function Is_Nested (E : Entity_Id) return Boolean;
 --  Level of inlining for the call: Dont_Inline means no inlining,
 --  Inline_Call means that only the call is considered for inlining,
 --  Inline_Package means that the call is considered for inlining and
 --  its package compiled and scanned for more inlining opportunities.
+function Is_Non_Loading_Expression_Function
+(Id : Entity_Id) return Boolean;
+--  Determine whether arbitrary entity Id denotes a subprogram which is
+--  either
+--
+--    * An expression function
+--
+--    * A function completed by an expression function where both the
+--      spec and body are in the same context.
 function Must_Inline return Inline_Level_Type;
 --  Inlining is only done if the call statement N is in the main unit,
 --  or within the body of another inlined subprogram.
+----------------------------------------
+-- Is_Non_Loading_Expression_Function --
+----------------------------------------
+function Is_Non_Loading_Expression_Function
+(Id : Entity_Id) return Boolean
+is
+Body_Decl : Node_Id;
+Body_Id   : Entity_Id;
+Spec_Decl : Node_Id;
+begin
+--  A stand-alone expression function is transformed into a spec-body
+--  pair in-place. Since both the spec and body are in the same list,
+--  the inlining of such an expression function does not need to load
+--  anything extra.
+if Is_Expression_Function (Id) then
+return True;
+--  A function may be completed by an expression function
+elsif Ekind (Id) = E_Function then
+Spec_Decl := Unit_Declaration_Node (Id);
+if Nkind (Spec_Decl) = N_Subprogram_Declaration then
+Body_Id := Corresponding_Body (Spec_Decl);
+if Present (Body_Id) then
+Body_Decl := Unit_Declaration_Node (Body_Id);
+--  The inlining of a completing expression function does
+--  not need to load anything extra when both the spec and
+--  body are in the same context.
+return
+Was_Expression_Function (Body_Decl)
+and then Parent (Spec_Decl) = Parent (Body_Decl);
+end if;
+end if;
+end if;
+return False;
+end Is_Non_Loading_Expression_Function;
 -----------------
 -- Must_Inline --
 -----------------
 and then Is_Predefined_Unit (Get_Source_Unit (E))
 then
 Set_Needs_Debug_Info (E, False);
 end if;
---  If the subprogram is an expression function, then there is no need to
+--  If the subprogram is an expression function, or is completed by one
---  load any package body since the body of the function is in the spec.
+--  where both the spec and body are in the same context, then there is
+--  no need to load any package body since the body of the function is
-if Is_Expression_Function (E) then
+--  in the spec.
+if Is_Non_Loading_Expression_Function (E) then
 Set_Is_Called (E);
 return;
 end if;
 --  Find unit containing E, and add to list of inlined bodies if needed.
 Analysis_Status : constant Boolean := Full_Analysis;
 Original_Body   : Node_Id;
 Body_To_Analyze : Node_Id;
 Max_Size        : constant := 10;
+function Has_Extended_Return return Boolean;
+--  This function returns True if the subprogram has an extended return
+--  statement.
 function Has_Pending_Instantiation return Boolean;
 --  If some enclosing body contains instantiations that appear before
 --  the corresponding generic body, the enclosing body has a freeze node
 --  so that it can be elaborated after the generic itself. This might
 --  conflict with subsequent inlinings, so that it is unsafe to try to
 --  inlining would generate gotos in that case as well (although the
 --  goto is useless in that case).
 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
 --  If the body of the subprogram includes a call that returns an
---  unconstrained type, the secondary stack is involved, and it
+--  unconstrained type, the secondary stack is involved, and it is
---  is not worth inlining.
+--  not worth inlining.
+-------------------------
+-- Has_Extended_Return --
+-------------------------
+function Has_Extended_Return return Boolean is
+Body_To_Inline : constant Node_Id := N;
+function Check_Return (N : Node_Id) return Traverse_Result;
+--  Returns OK on node N if this is not an extended return statement
+------------------
+-- Check_Return --
+------------------
+function Check_Return (N : Node_Id) return Traverse_Result is
+begin
+case Nkind (N) is
+when N_Extended_Return_Statement =>
+return Abandon;
+--  Skip locally declared subprogram bodies inside the body to
+--  inline, as the return statements inside those do not count.
+when N_Subprogram_Body =>
+if N = Body_To_Inline then
+return OK;
+else
+return Skip;
+end if;
+when others =>
+return OK;
+end case;
+end Check_Return;
+function Check_All_Returns is new Traverse_Func (Check_Return);
+--  Start of processing for Has_Extended_Return
+begin
+return Check_All_Returns (N) /= OK;
+end Has_Extended_Return;
 -------------------------------
 -- Has_Pending_Instantiation --
 -------------------------------
 and then not Has_Single_Return_In_GNATprove_Mode
 then
 Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id);
 return;
---  Functions that return unconstrained composite types require
+--  Functions that return controlled types cannot currently be inlined
---  secondary stack handling, and cannot currently be inlined, unless
+--  because they require secondary stack handling; controlled actions
---  all return statements return a local variable that is the first
+--  may also interfere in complex ways with inlining.
---  local declaration in the body.
-elsif Ekind (Spec_Id) = E_Function
-and then not Is_Scalar_Type (Etype (Spec_Id))
-and then not Is_Access_Type (Etype (Spec_Id))
-and then not Is_Constrained (Etype (Spec_Id))
-then
-if not Has_Single_Return (N) then
-Cannot_Inline
-("cannot inline & (unconstrained return type)?", N, Spec_Id);
-return;
-end if;
---  Ditto for functions that return controlled types, where controlled
---  actions interfere in complex ways with inlining.
 elsif Ekind (Spec_Id) = E_Function
 and then Needs_Finalization (Etype (Spec_Id))
 then
 Cannot_Inline
 Set_Declarations (N, New_List (Body_To_Analyze));
 else
 Append (Body_To_Analyze, Declarations (N));
 end if;
---  The body to inline is pre-analyzed. In GNATprove mode we must disable
+--  The body to inline is preanalyzed. In GNATprove mode we must disable
 --  full analysis as well so that light expansion does not take place
 --  either, and name resolution is unaffected.
 Expander_Mode_Save_And_Set (False);
 Full_Analysis := False;
 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
 Restore_Env;
 end if;
+--  Functions that return unconstrained composite types require
+--  secondary stack handling, and cannot currently be inlined, unless
+--  all return statements return a local variable that is the first
+--  local declaration in the body. We had to delay this check until
+--  the body of the function is analyzed since Has_Single_Return()
+--  requires a minimum decoration.
+if Ekind (Spec_Id) = E_Function
+and then not Is_Scalar_Type (Etype (Spec_Id))
+and then not Is_Access_Type (Etype (Spec_Id))
+and then not Is_Constrained (Etype (Spec_Id))
+then
+if not Has_Single_Return (Body_To_Analyze)
+--  Skip inlining if the function returns an unconstrained type
+--  using an extended return statement, since this part of the
+--  new inlining model is not yet supported by the current
+--  implementation. ???
+or else (Returns_Unconstrained_Type (Spec_Id)
+and then Has_Extended_Return)
+then
+Cannot_Inline
+("cannot inline & (unconstrained return type)?", N, Spec_Id);
+return;
+end if;
 --  If secondary stack is used, there is no point in inlining. We have
 --  already issued the warning in this case, so nothing to do.
-if Uses_Secondary_Stack (Body_To_Analyze) then
+elsif Uses_Secondary_Stack (Body_To_Analyze) then
 return;
 end if;
 Set_Body_To_Inline (Decl, Original_Body);
 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
 if Is_Predefined_Unit (Get_Source_Unit (Subp))
 and then not In_Extended_Main_Source_Unit (Subp)
 then
 null;
---  In GNATprove mode, issue a warning, and indicate that the
+--  In GNATprove mode, issue a warning when -gnatd_f is set, and
---  subprogram is not always inlined by setting flag Is_Inlined_Always
+--  indicate that the subprogram is not always inlined by setting
---  to False.
+--  flag Is_Inlined_Always to False.
 elsif GNATprove_Mode then
 Set_Is_Inlined_Always (Subp, False);
-Error_Msg_NE (Msg & "p?", N, Subp);
+if Debug_Flag_Underscore_F then
+Error_Msg_NE (Msg, N, Subp);
+end if;
 elsif Has_Pragma_Inline_Always (Subp) then
 --  Remove last character (question mark) to make this into an
 --  error, because the Inline_Always pragma cannot be obeyed.
 --  Remove last character (question mark) to make this into an error.
 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
---  In GNATprove mode, issue a warning, and indicate that the subprogram
+--  In GNATprove mode, issue a warning when -gnatd_f is set, and
---  is not always inlined by setting flag Is_Inlined_Always to False.
+--  indicate that the subprogram is not always inlined by setting
+--  flag Is_Inlined_Always to False.
 elsif GNATprove_Mode then
 Set_Is_Inlined_Always (Subp, False);
-Error_Msg_NE (Msg & "p?", N, Subp);
+if Debug_Flag_Underscore_F then
+Error_Msg_NE (Msg, N, Subp);
+end if;
 else
 --  Do not emit warning if this is a predefined unit which is not
 --  the main unit. This behavior is currently provided for backward
 --  occurrences of pragmas referencing the formals are removed since
 --  they have no meaning when the body is inlined and the formals are
 --  rewritten (the analysis of the non-inlined body will handle these
 --  pragmas).  A new internal name is associated with Body_To_Inline.
------------------------------
+------------------------------
--- Generate_Body_To_Inline --
+-- Generate_Subprogram_Body --
------------------------------
+------------------------------
 procedure Generate_Subprogram_Body
 (N              : Node_Id;
 Body_To_Inline : out Node_Id)
 is
 procedure Expand_Inlined_Call
 (N         : Node_Id;
 Subp      : Entity_Id;
 Orig_Subp : Entity_Id)
 is
+Decls     : constant List_Id    := New_List;
+Is_Predef : constant Boolean    :=
+Is_Predefined_Unit (Get_Source_Unit (Subp));
 Loc       : constant Source_Ptr := Sloc (N);
-Is_Predef : constant Boolean :=
+Orig_Bod  : constant Node_Id    :=
-Is_Predefined_Unit (Get_Source_Unit (Subp));
-Orig_Bod  : constant Node_Id :=
 Body_To_Inline (Unit_Declaration_Node (Subp));
+Uses_Back_End : constant Boolean :=
+Back_End_Inlining and then Optimization_Level > 0;
+--  The back-end expansion is used if the target supports back-end
+--  inlining and some level of optimixation is required; otherwise
+--  the inlining takes place fully as a tree expansion.
 Blk      : Node_Id;
 Decl     : Node_Id;
-Decls    : constant List_Id := New_List;
+Exit_Lab : Entity_Id := Empty;
-Exit_Lab : Entity_Id        := Empty;
 F        : Entity_Id;
 A        : Node_Id;
-Lab_Decl : Node_Id;
+Lab_Decl : Node_Id   := Empty;
 Lab_Id   : Node_Id;
 New_A    : Node_Id;
-Num_Ret  : Nat := 0;
+Num_Ret  : Nat       := 0;
 Ret_Type : Entity_Id;
-Targ : Node_Id;
---  The target of the call. If context is an assignment statement then
---  this is the left-hand side of the assignment, else it is a temporary
---  to which the return value is assigned prior to rewriting the call.
-Targ1 : Node_Id := Empty;
---  A separate target used when the return type is unconstrained
 Temp     : Entity_Id;
 Temp_Typ : Entity_Id;
-Return_Object : Entity_Id := Empty;
---  Entity in declaration in an extended_return_statement
 Is_Unc      : Boolean;
 Is_Unc_Decl : Boolean;
 --  If the type returned by the function is unconstrained and the call
 --  can be inlined, special processing is required.
+Return_Object : Entity_Id := Empty;
+--  Entity in declaration in an extended_return_statement
+Targ : Node_Id := Empty;
+--  The target of the call. If context is an assignment statement then
+--  this is the left-hand side of the assignment, else it is a temporary
+--  to which the return value is assigned prior to rewriting the call.
+Targ1 : Node_Id := Empty;
+--  A separate target used when the return type is unconstrained
 procedure Declare_Postconditions_Result;
 --  When generating C code, declare _Result, which may be used in the
 --  inlined _Postconditions procedure to verify the return value.
 Num_Ret := Num_Ret + 1;
 Make_Exit_Label;
 end if;
 --  Because of the presence of private types, the views of the
---  expression and the context may be different, so place an
+--  expression and the context may be different, so place
---  unchecked conversion to the context type to avoid spurious
+--  a type conversion to the context type to avoid spurious
 --  errors, e.g. when the expression is a numeric literal and
 --  the context is private. If the expression is an aggregate,
 --  use a qualified expression, because an aggregate is not a
---  legal argument of a conversion. Ditto for numeric literals
+--  legal argument of a conversion. Ditto for numeric, character
---  and attributes that yield a universal type, because those
+--  and string literals, and attributes that yield a universal
---  must be resolved to a specific type.
+--  type, because those must be resolved to a specific type.
-if Nkind_In (Expression (N), N_Aggregate, N_Null)
+if Nkind_In (Expression (N), N_Aggregate,
+N_Character_Literal,
+N_Null,
+N_String_Literal)
 or else Yields_Universal_Type (Expression (N))
 then
 Ret :=
 Make_Qualified_Expression (Sloc (N),
 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
 Expression   => Relocate_Node (Expression (N)));
-else
+--  Use an unchecked type conversion between access types, for
+--  which a type conversion would not always be valid, as no
+--  check may result from the conversion.
+elsif Is_Access_Type (Ret_Type) then
 Ret :=
 Unchecked_Convert_To
 (Ret_Type, Relocate_Node (Expression (N)));
+--  Otherwise use a type conversion, which may trigger a check
+else
+Ret :=
+Make_Type_Conversion (Sloc (N),
+Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
+Expression   => Relocate_Node (Expression (N)));
 end if;
 if Nkind (Targ) = N_Defining_Identifier then
 Rewrite (N,
 Make_Assignment_Statement (Loc,
 --  Start of processing for Expand_Inlined_Call
 begin
 --  Initializations for old/new semantics
-if not Back_End_Inlining then
+if not Uses_Back_End then
 Is_Unc      := Is_Array_Type (Etype (Subp))
 and then not Is_Constrained (Etype (Subp));
 Is_Unc_Decl := False;
 else
 Is_Unc      := Returns_Unconstrained_Type (Subp)
 --  Skip inlining if this is not a true inlining since the attribute
 --  Body_To_Inline is also set for renamings (see sinfo.ads). For a
 --  true inlining, Orig_Bod has code rather than being an entity.
 elsif Nkind (Orig_Bod) in N_Entity then
-return;
---  Skip inlining if the function returns an unconstrained type using
---  an extended return statement since this part of the new inlining
---  model which is not yet supported by the current implementation. ???
-elsif Is_Unc
-and then
-Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
-N_Extended_Return_Statement
-and then not Back_End_Inlining
-then
 return;
 end if;
 if Nkind (Orig_Bod) = N_Defining_Identifier
 or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol
 Save_Env (Subp, Empty);
 Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
 --  Old semantics
-if not Back_End_Inlining then
+if not Uses_Back_End then
 declare
 Bod : Node_Id;
 begin
 Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
 declare
 First_Decl : Node_Id;
 begin
 First_Decl := First (Declarations (Blk));
+--  If the body is a single extended return statement,the
+--  resulting block is a nested block.
+if No (First_Decl) then
+First_Decl :=
+First (Statements (Handled_Statement_Sequence (Blk)));
+if Nkind (First_Decl) = N_Block_Statement then
+First_Decl := First (Declarations (First_Decl));
+end if;
+end if;
+--  No front-end inlining possible
 if Nkind (First_Decl) /= N_Object_Declaration then
 return;
 end if;
 if GNATprove_Mode
 and then Ekind (F) /= E_Out_Parameter
 and then not Same_Type (Etype (F), Etype (A))
 then
-pragma Assert (not (Is_By_Reference_Type (Etype (A))));
+pragma Assert (not Is_By_Reference_Type (Etype (A)));
-pragma Assert (not (Is_Limited_Type (Etype (A))));
+pragma Assert (not Is_Limited_Type (Etype (A)));
 Append_To (Decls,
 Make_Object_Declaration (Loc,
 Defining_Identifier => Make_Temporary (Loc, 'C'),
 Constant_Present    => True,
 --  New semantics: In an object declaration avoid an extra copy
 --  of the result of a call to an inlined function that returns
 --  an unconstrained type
-elsif Back_End_Inlining
+elsif Uses_Back_End
 and then Nkind (Parent (N)) = N_Object_Declaration
 and then Is_Unc
 then
 Targ := Defining_Identifier (Parent (N));
 begin
 if Nkind (N) = N_Simple_Return_Statement then
 if Present (Expression (N))
 and then Is_Entity_Name (Expression (N))
 then
+pragma Assert (Present (Entity (Expression (N))));
 if No (Return_Statement) then
 Return_Statement := N;
 return OK;
-elsif Chars (Expression (N)) =
-Chars (Expression (Return_Statement))
-then
-return OK;
 else
-return Abandon;
+pragma Assert
+(Present (Entity (Expression (Return_Statement))));
+if Entity (Expression (N)) =
+Entity (Expression (Return_Statement))
+then
+return OK;
+else
+return Abandon;
+end if;
 end if;
---  A return statement within an extended return is a noop
+--  A return statement within an extended return is a noop after
---  after inlining.
+--  inlining.
 elsif No (Expression (N))
-and then
+and then Nkind (Parent (Parent (N))) =
-Nkind (Parent (Parent (N))) = N_Extended_Return_Statement
+N_Extended_Return_Statement
 then
 return OK;
 else
 --  Expression has wrong form
 elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
 return True;
 else
-return Present (Declarations (N))
+return
-and then Present (First (Declarations (N)))
+Present (Declarations (N))
-and then Chars (Expression (Return_Statement)) =
+and then Present (First (Declarations (N)))
-Chars (Defining_Identifier (First (Declarations (N))));
+and then Entity (Expression (Return_Statement)) =
+Defining_Identifier (First (Declarations (N)));
 end if;
 end Has_Single_Return;
 -----------------------------
 -- In_Main_Unit_Or_Subunit --

Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/inline.adb @ 131:84e7813d76e9