with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
with Sem_Prag; use Sem_Prag;
+with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
-- Make entry in Inlined table for subprogram E, or return table index
-- that already holds E.
+ procedure Establish_Actual_Mapping_For_Inlined_Call
+ (N : Node_Id;
+ Subp : Entity_Id;
+ Decls : List_Id;
+ Body_Or_Expr_To_Check : Node_Id);
+ -- Establish a mapping from formals to actuals in the call N for the target
+ -- subprogram Subp, and create temporaries or renamings when needed for the
+ -- actuals that are expressions (except for actuals given by simple entity
+ -- names or literals) or that are scalars that require copying to preserve
+ -- semantics. Any temporary objects that are created are inserted in Decls.
+ -- Body_Or_Expr_To_Check indicates the target body (or possibly expression
+ -- of an expression function), which may be traversed to count formal uses.
+
function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id;
pragma Inline (Get_Code_Unit_Entity);
-- Return the entity node for the unit containing E. Always return the spec
-- Unmodified
-- Unreferenced
+ procedure Reset_Actual_Mapping_For_Inlined_Call (Subp : Entity_Id);
+ -- Reset the Renamed_Object flags on the formals of Subp, which can be set
+ -- by a call to Establish_Actual_Mapping_For_Inlined_Call.
+
------------------------------
-- Deferred Cleanup Actions --
------------------------------
end loop;
end Cleanup_Scopes;
- -------------------------
- -- Expand_Inlined_Call --
- -------------------------
-
- procedure Expand_Inlined_Call
- (N : Node_Id;
- Subp : Entity_Id;
- Orig_Subp : Entity_Id)
+ procedure Establish_Actual_Mapping_For_Inlined_Call
+ (N : Node_Id;
+ Subp : Entity_Id;
+ Decls : List_Id;
+ Body_Or_Expr_To_Check : Node_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);
- 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.
+ function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
+ -- Determine whether a formal parameter is used only once in
+ -- Body_Or_Expr_To_Check.
- Blk : Node_Id;
- Decl : Node_Id;
- Exit_Lab : Entity_Id := Empty;
- F : Entity_Id;
- A : Node_Id;
- Lab_Decl : Node_Id := Empty;
- Lab_Id : Node_Id;
- New_A : Node_Id;
- Num_Ret : Nat := 0;
- Ret_Type : Entity_Id;
- Temp : Entity_Id;
- Temp_Typ : Entity_Id;
+ -------------------------
+ -- Formal_Is_Used_Once --
+ -------------------------
- 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.
+ function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
+ Use_Counter : Int := 0;
- Return_Object : Entity_Id := Empty;
- -- Entity in declaration in an extended_return_statement
+ function Count_Uses (N : Node_Id) return Traverse_Result;
+ -- Traverse the tree and count the uses of the formal parameter.
+ -- In this case, for optimization purposes, we do not need to
+ -- continue the traversal once more than one use is encountered.
- 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.
+ ----------------
+ -- Count_Uses --
+ ----------------
- Targ1 : Node_Id := Empty;
- -- A separate target used when the return type is unconstrained
+ function Count_Uses (N : Node_Id) return Traverse_Result is
+ begin
+ -- The original node is an identifier
- procedure Declare_Postconditions_Result;
- -- When generating C code, declare _Result, which may be used in the
- -- inlined _Postconditions procedure to verify the return value.
+ if Nkind (N) = N_Identifier
+ and then Present (Entity (N))
- procedure Make_Exit_Label;
- -- Build declaration for exit label to be used in Return statements,
- -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
- -- declaration). Does nothing if Exit_Lab already set.
+ -- Original node's entity points to the one in the copied body
- procedure Make_Loop_Labels_Unique (HSS : Node_Id);
- -- When compiling for CCG and performing front-end inlining, replace
- -- loop names and references to them so that they do not conflict with
- -- homographs in the current subprogram.
+ and then Nkind (Entity (N)) = N_Identifier
+ and then Present (Entity (Entity (N)))
- function Process_Formals (N : Node_Id) return Traverse_Result;
- -- Replace occurrence of a formal with the corresponding actual, or the
- -- thunk generated for it. Replace a return statement with an assignment
- -- to the target of the call, with appropriate conversions if needed.
+ -- The entity of the copied node is the formal parameter
- function Process_Formals_In_Aspects (N : Node_Id) return Traverse_Result;
- -- Because aspects are linked indirectly to the rest of the tree,
- -- replacement of formals appearing in aspect specifications must
- -- be performed in a separate pass, using an instantiation of the
- -- previous subprogram over aspect specifications reachable from N.
+ and then Entity (Entity (N)) = Formal
+ then
+ Use_Counter := Use_Counter + 1;
- function Process_Sloc (Nod : Node_Id) return Traverse_Result;
- -- If the call being expanded is that of an internal subprogram, set the
- -- sloc of the generated block to that of the call itself, so that the
- -- expansion is skipped by the "next" command in gdb. Same processing
- -- for a subprogram in a predefined file, e.g. Ada.Tags. If
- -- Debug_Generated_Code is true, suppress this change to simplify our
- -- own development. Same in GNATprove mode, to ensure that warnings and
- -- diagnostics point to the proper location.
+ if Use_Counter > 1 then
- procedure Reset_Dispatching_Calls (N : Node_Id);
- -- In subtree N search for occurrences of dispatching calls that use the
- -- Ada 2005 Object.Operation notation and the object is a formal of the
- -- inlined subprogram. Reset the entity associated with Operation in all
- -- the found occurrences.
+ -- Denote more than one use and abandon the traversal
- procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
- -- If the function body is a single expression, replace call with
- -- expression, else insert block appropriately.
+ Use_Counter := 2;
+ return Abandon;
- procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
- -- If procedure body has no local variables, inline body without
- -- creating block, otherwise rewrite call with block.
+ end if;
+ end if;
- function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
- -- Determine whether a formal parameter is used only once in Orig_Bod
+ return OK;
+ end Count_Uses;
- -----------------------------------
- -- Declare_Postconditions_Result --
- -----------------------------------
+ procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
- procedure Declare_Postconditions_Result is
- Enclosing_Subp : constant Entity_Id := Scope (Subp);
+ -- Start of processing for Formal_Is_Used_Once
begin
- pragma Assert
- (Modify_Tree_For_C
- and then Is_Subprogram (Enclosing_Subp)
- and then Present (Postconditions_Proc (Enclosing_Subp)));
+ Count_Formal_Uses (Body_Or_Expr_To_Check);
+ return Use_Counter = 1;
+ end Formal_Is_Used_Once;
- if Ekind (Enclosing_Subp) = E_Function then
- if Nkind (First (Parameter_Associations (N))) in
- N_Numeric_Or_String_Literal
- then
- Append_To (Declarations (Blk),
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uResult),
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
- Expression =>
- New_Copy_Tree (First (Parameter_Associations (N)))));
- else
- Append_To (Declarations (Blk),
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uResult),
- Subtype_Mark =>
- New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
- Name =>
- New_Copy_Tree (First (Parameter_Associations (N)))));
- end if;
- end if;
- end Declare_Postconditions_Result;
+ -- Local Data --
- ---------------------
- -- Make_Exit_Label --
- ---------------------
+ F : Entity_Id;
+ A : Node_Id;
+ Decl : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ New_A : Node_Id;
+ Temp : Entity_Id;
+ Temp_Typ : Entity_Id;
- procedure Make_Exit_Label is
- Lab_Ent : Entity_Id;
- begin
- if No (Exit_Lab) then
- Lab_Ent := Make_Temporary (Loc, 'L');
- Lab_Id := New_Occurrence_Of (Lab_Ent, Loc);
- Exit_Lab := Make_Label (Loc, Lab_Id);
- Lab_Decl :=
- Make_Implicit_Label_Declaration (Loc,
- Defining_Identifier => Lab_Ent,
- Label_Construct => Exit_Lab);
- end if;
- end Make_Exit_Label;
+ -- Start of processing for Establish_Actual_Mapping_For_Inlined_Call
- -----------------------------
- -- Make_Loop_Labels_Unique --
- -----------------------------
+ begin
+ F := First_Formal (Subp);
+ A := First_Actual (N);
+ while Present (F) loop
+ if Present (Renamed_Object (F)) then
- procedure Make_Loop_Labels_Unique (HSS : Node_Id) is
- function Process_Loop (N : Node_Id) return Traverse_Result;
+ -- If expander is active, it is an error to try to inline a
+ -- recursive program. In GNATprove mode, just indicate that the
+ -- inlining will not happen, and mark the subprogram as not always
+ -- inlined.
- ------------------
- -- Process_Loop --
- ------------------
+ if GNATprove_Mode then
+ Cannot_Inline
+ ("cannot inline call to recursive subprogram?", N, Subp);
+ Set_Is_Inlined_Always (Subp, False);
+ else
+ Error_Msg_N
+ ("cannot inline call to recursive subprogram", N);
+ end if;
- function Process_Loop (N : Node_Id) return Traverse_Result is
- Id : Entity_Id;
+ return;
+ end if;
- begin
- if Nkind (N) = N_Loop_Statement
- and then Present (Identifier (N))
- then
- -- Create new external name for loop and update the
- -- corresponding entity.
+ -- Reset Last_Assignment for any parameters of mode out or in out, to
+ -- prevent spurious warnings about overwriting for assignments to the
+ -- formal in the inlined code.
- Id := Entity (Identifier (N));
- Set_Chars (Id, New_External_Name (Chars (Id), 'L', -1));
- Set_Chars (Identifier (N), Chars (Id));
+ if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
+ Set_Last_Assignment (Entity (A), Empty);
+ end if;
- elsif Nkind (N) = N_Exit_Statement
- and then Present (Name (N))
- then
- -- The exit statement must name an enclosing loop, whose name
- -- has already been updated.
+ -- If the argument may be a controlling argument in a call within
+ -- the inlined body, we must preserve its class-wide nature to ensure
+ -- that dynamic dispatching will take place subsequently. If the
+ -- formal has a constraint, then it must be preserved to retain the
+ -- semantics of the body.
- Set_Chars (Name (N), Chars (Entity (Name (N))));
- end if;
+ if Is_Class_Wide_Type (Etype (F))
+ or else (Is_Access_Type (Etype (F))
+ and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
+ then
+ Temp_Typ := Etype (F);
- return OK;
- end Process_Loop;
+ elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
+ and then Etype (F) /= Base_Type (Etype (F))
+ and then Is_Constrained (Etype (F))
+ then
+ Temp_Typ := Etype (F);
- procedure Update_Loop_Names is new Traverse_Proc (Process_Loop);
+ else
+ Temp_Typ := Etype (A);
+ end if;
- -- Local variables
+ -- If the actual is a simple name or a literal, no need to
+ -- create a temporary, object can be used directly.
- Stmt : Node_Id;
+ -- If the actual is a literal and the formal has its address taken,
+ -- we cannot pass the literal itself as an argument, so its value
+ -- must be captured in a temporary. Skip this optimization in
+ -- GNATprove mode, to make sure any check on a type conversion
+ -- will be issued.
- -- Start of processing for Make_Loop_Labels_Unique
+ if (Is_Entity_Name (A)
+ and then
+ (not Is_Scalar_Type (Etype (A))
+ or else Ekind (Entity (A)) = E_Enumeration_Literal)
+ and then not GNATprove_Mode)
+
+ -- When the actual is an identifier and the corresponding formal is
+ -- used only once in the original body, the formal can be substituted
+ -- directly with the actual parameter. Skip this optimization in
+ -- GNATprove mode, to make sure any check on a type conversion
+ -- will be issued.
+
+ or else
+ (Nkind (A) = N_Identifier
+ and then Formal_Is_Used_Once (F)
+ and then not GNATprove_Mode)
+
+ or else
+ (Nkind_In (A, N_Real_Literal,
+ N_Integer_Literal,
+ N_Character_Literal)
+ and then not Address_Taken (F))
+ then
+ if Etype (F) /= Etype (A) then
+ Set_Renamed_Object
+ (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
+ else
+ Set_Renamed_Object (F, A);
+ end if;
+
+ else
+ Temp := Make_Temporary (Loc, 'C');
+
+ -- If the actual for an in/in-out parameter is a view conversion,
+ -- make it into an unchecked conversion, given that an untagged
+ -- type conversion is not a proper object for a renaming.
+
+ -- In-out conversions that involve real conversions have already
+ -- been transformed in Expand_Actuals.
+
+ if Nkind (A) = N_Type_Conversion
+ and then Ekind (F) /= E_In_Parameter
+ then
+ New_A :=
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
+ Expression => Relocate_Node (Expression (A)));
+
+ -- In GNATprove mode, keep the most precise type of the actual for
+ -- the temporary variable, when the formal type is unconstrained.
+ -- Otherwise, the AST may contain unexpected assignment statements
+ -- to a temporary variable of unconstrained type renaming a local
+ -- variable of constrained type, which is not expected by
+ -- GNATprove.
+
+ elsif Etype (F) /= Etype (A)
+ and then (not GNATprove_Mode or else Is_Constrained (Etype (F)))
+ then
+ New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
+ Temp_Typ := Etype (F);
+
+ else
+ New_A := Relocate_Node (A);
+ end if;
+
+ Set_Sloc (New_A, Sloc (N));
+
+ -- If the actual has a by-reference type, it cannot be copied,
+ -- so its value is captured in a renaming declaration. Otherwise
+ -- declare a local constant initialized with the actual.
+
+ -- We also use a renaming declaration for expressions of an array
+ -- type that is not bit-packed, both for efficiency reasons and to
+ -- respect the semantics of the call: in most cases the original
+ -- call will pass the parameter by reference, and thus the inlined
+ -- code will have the same semantics.
+
+ -- Finally, we need a renaming declaration in the case of limited
+ -- types for which initialization cannot be by copy either.
+
+ if Ekind (F) = E_In_Parameter
+ and then not Is_By_Reference_Type (Etype (A))
+ and then not Is_Limited_Type (Etype (A))
+ and then
+ (not Is_Array_Type (Etype (A))
+ or else not Is_Object_Reference (A)
+ or else Is_Bit_Packed_Array (Etype (A)))
+ then
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
+ Expression => New_A);
+
+ else
+ -- In GNATprove mode, make an explicit copy of input
+ -- parameters when formal and actual types differ, to make
+ -- sure any check on the type conversion will be issued.
+ -- The legality of the copy is ensured by calling first
+ -- Call_Can_Be_Inlined_In_GNATprove_Mode.
+
+ 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_Limited_Type (Etype (A)));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'C'),
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
+ Expression => New_Copy_Tree (New_A)));
+ end if;
+
+ Decl :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
+ Name => New_A);
+ end if;
+
+ Append (Decl, Decls);
+ Set_Renamed_Object (F, Temp);
+ end if;
+
+ Next_Formal (F);
+ Next_Actual (A);
+ end loop;
+ end Establish_Actual_Mapping_For_Inlined_Call;
+
+ -------------------------
+ -- Expand_Inlined_Call --
+ -------------------------
+
+ 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);
+ 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;
+ Exit_Lab : Entity_Id := Empty;
+ Lab_Decl : Node_Id := Empty;
+ Lab_Id : Node_Id;
+ Num_Ret : Nat := 0;
+ Ret_Type : Entity_Id;
+ Temp : Entity_Id;
+
+ 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.
+
+ procedure Make_Exit_Label;
+ -- Build declaration for exit label to be used in Return statements,
+ -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
+ -- declaration). Does nothing if Exit_Lab already set.
+
+ procedure Make_Loop_Labels_Unique (HSS : Node_Id);
+ -- When compiling for CCG and performing front-end inlining, replace
+ -- loop names and references to them so that they do not conflict with
+ -- homographs in the current subprogram.
+
+ function Process_Formals (N : Node_Id) return Traverse_Result;
+ -- Replace occurrence of a formal with the corresponding actual, or the
+ -- thunk generated for it. Replace a return statement with an assignment
+ -- to the target of the call, with appropriate conversions if needed.
+
+ function Process_Formals_In_Aspects (N : Node_Id) return Traverse_Result;
+ -- Because aspects are linked indirectly to the rest of the tree,
+ -- replacement of formals appearing in aspect specifications must
+ -- be performed in a separate pass, using an instantiation of the
+ -- previous subprogram over aspect specifications reachable from N.
+
+ function Process_Sloc (Nod : Node_Id) return Traverse_Result;
+ -- If the call being expanded is that of an internal subprogram, set the
+ -- sloc of the generated block to that of the call itself, so that the
+ -- expansion is skipped by the "next" command in gdb. Same processing
+ -- for a subprogram in a predefined file, e.g. Ada.Tags. If
+ -- Debug_Generated_Code is true, suppress this change to simplify our
+ -- own development. Same in GNATprove mode, to ensure that warnings and
+ -- diagnostics point to the proper location.
+
+ procedure Reset_Dispatching_Calls (N : Node_Id);
+ -- In subtree N search for occurrences of dispatching calls that use the
+ -- Ada 2005 Object.Operation notation and the object is a formal of the
+ -- inlined subprogram. Reset the entity associated with Operation in all
+ -- the found occurrences.
+
+ procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
+ -- If the function body is a single expression, replace call with
+ -- expression, else insert block appropriately.
+
+ procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
+ -- If procedure body has no local variables, inline body without
+ -- creating block, otherwise rewrite call with block.
+
+ -----------------------------------
+ -- Declare_Postconditions_Result --
+ -----------------------------------
+
+ procedure Declare_Postconditions_Result is
+ Enclosing_Subp : constant Entity_Id := Scope (Subp);
+
+ begin
+ pragma Assert
+ (Modify_Tree_For_C
+ and then Is_Subprogram (Enclosing_Subp)
+ and then Present (Postconditions_Proc (Enclosing_Subp)));
+
+ if Ekind (Enclosing_Subp) = E_Function then
+ if Nkind (First (Parameter_Associations (N))) in
+ N_Numeric_Or_String_Literal
+ then
+ Append_To (Declarations (Blk),
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uResult),
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
+ Expression =>
+ New_Copy_Tree (First (Parameter_Associations (N)))));
+ else
+ Append_To (Declarations (Blk),
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uResult),
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
+ Name =>
+ New_Copy_Tree (First (Parameter_Associations (N)))));
+ end if;
+ end if;
+ end Declare_Postconditions_Result;
+
+ ---------------------
+ -- Make_Exit_Label --
+ ---------------------
+
+ procedure Make_Exit_Label is
+ Lab_Ent : Entity_Id;
+ begin
+ if No (Exit_Lab) then
+ Lab_Ent := Make_Temporary (Loc, 'L');
+ Lab_Id := New_Occurrence_Of (Lab_Ent, Loc);
+ Exit_Lab := Make_Label (Loc, Lab_Id);
+ Lab_Decl :=
+ Make_Implicit_Label_Declaration (Loc,
+ Defining_Identifier => Lab_Ent,
+ Label_Construct => Exit_Lab);
+ end if;
+ end Make_Exit_Label;
+
+ -----------------------------
+ -- Make_Loop_Labels_Unique --
+ -----------------------------
+
+ procedure Make_Loop_Labels_Unique (HSS : Node_Id) is
+ function Process_Loop (N : Node_Id) return Traverse_Result;
+
+ ------------------
+ -- Process_Loop --
+ ------------------
+
+ function Process_Loop (N : Node_Id) return Traverse_Result is
+ Id : Entity_Id;
+
+ begin
+ if Nkind (N) = N_Loop_Statement
+ and then Present (Identifier (N))
+ then
+ -- Create new external name for loop and update the
+ -- corresponding entity.
+
+ Id := Entity (Identifier (N));
+ Set_Chars (Id, New_External_Name (Chars (Id), 'L', -1));
+ Set_Chars (Identifier (N), Chars (Id));
+
+ elsif Nkind (N) = N_Exit_Statement
+ and then Present (Name (N))
+ then
+ -- The exit statement must name an enclosing loop, whose name
+ -- has already been updated.
+
+ Set_Chars (Name (N), Chars (Entity (Name (N))));
+ end if;
+
+ return OK;
+ end Process_Loop;
+
+ procedure Update_Loop_Names is new Traverse_Proc (Process_Loop);
+
+ -- Local variables
+
+ Stmt : Node_Id;
+
+ -- Start of processing for Make_Loop_Labels_Unique
begin
if Modify_Tree_For_C then
-- expanded into a procedure call which must be added after the
-- object declaration.
- if Is_Unc_Decl and Back_End_Inlining then
- Insert_Action_After (Parent (N), Blk);
- else
- Set_Expression (Parent (N), Empty);
- Insert_After (Parent (N), Blk);
- end if;
-
- elsif Is_Unc and then not Back_End_Inlining then
- Insert_Before (Parent (N), Blk);
- end if;
- end Rewrite_Function_Call;
-
- ----------------------------
- -- Rewrite_Procedure_Call --
- ----------------------------
-
- procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
- HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
-
- begin
- Make_Loop_Labels_Unique (HSS);
-
- -- If there is a transient scope for N, this will be the scope of the
- -- actions for N, and the statements in Blk need to be within this
- -- scope. For example, they need to have visibility on the constant
- -- declarations created for the formals.
-
- -- If N needs no transient scope, and if there are no declarations in
- -- the inlined body, we can do a little optimization and insert the
- -- statements for the body directly after N, and rewrite N to a
- -- null statement, instead of rewriting N into a full-blown block
- -- statement.
-
- if not Scope_Is_Transient
- and then Is_Empty_List (Declarations (Blk))
- then
- Insert_List_After (N, Statements (HSS));
- Rewrite (N, Make_Null_Statement (Loc));
- else
- Rewrite (N, Blk);
- end if;
- end Rewrite_Procedure_Call;
-
- -------------------------
- -- Formal_Is_Used_Once --
- -------------------------
-
- function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
- Use_Counter : Int := 0;
-
- function Count_Uses (N : Node_Id) return Traverse_Result;
- -- Traverse the tree and count the uses of the formal parameter.
- -- In this case, for optimization purposes, we do not need to
- -- continue the traversal once more than one use is encountered.
-
- ----------------
- -- Count_Uses --
- ----------------
-
- function Count_Uses (N : Node_Id) return Traverse_Result is
- begin
- -- The original node is an identifier
-
- if Nkind (N) = N_Identifier
- and then Present (Entity (N))
-
- -- Original node's entity points to the one in the copied body
-
- and then Nkind (Entity (N)) = N_Identifier
- and then Present (Entity (Entity (N)))
-
- -- The entity of the copied node is the formal parameter
-
- and then Entity (Entity (N)) = Formal
- then
- Use_Counter := Use_Counter + 1;
-
- if Use_Counter > 1 then
+ if Is_Unc_Decl and Back_End_Inlining then
+ Insert_Action_After (Parent (N), Blk);
+ else
+ Set_Expression (Parent (N), Empty);
+ Insert_After (Parent (N), Blk);
+ end if;
- -- Denote more than one use and abandon the traversal
+ elsif Is_Unc and then not Back_End_Inlining then
+ Insert_Before (Parent (N), Blk);
+ end if;
+ end Rewrite_Function_Call;
- Use_Counter := 2;
- return Abandon;
+ ----------------------------
+ -- Rewrite_Procedure_Call --
+ ----------------------------
- end if;
- end if;
+ procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
+ HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
- return OK;
- end Count_Uses;
+ begin
+ Make_Loop_Labels_Unique (HSS);
- procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
+ -- If there is a transient scope for N, this will be the scope of the
+ -- actions for N, and the statements in Blk need to be within this
+ -- scope. For example, they need to have visibility on the constant
+ -- declarations created for the formals.
- -- Start of processing for Formal_Is_Used_Once
+ -- If N needs no transient scope, and if there are no declarations in
+ -- the inlined body, we can do a little optimization and insert the
+ -- statements for the body directly after N, and rewrite N to a
+ -- null statement, instead of rewriting N into a full-blown block
+ -- statement.
- begin
- Count_Formal_Uses (Orig_Bod);
- return Use_Counter = 1;
- end Formal_Is_Used_Once;
+ if not Scope_Is_Transient
+ and then Is_Empty_List (Declarations (Blk))
+ then
+ Insert_List_After (N, Statements (HSS));
+ Rewrite (N, Make_Null_Statement (Loc));
+ else
+ Rewrite (N, Blk);
+ end if;
+ end Rewrite_Procedure_Call;
-- Start of processing for Expand_Inlined_Call
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 Nkind (Parent (N)) /= N_Assignment_Statement then
- Targ1 := Defining_Identifier (First_Decl);
- else
- Targ1 := Name (Parent (N));
- end if;
- end;
- end if;
- end;
-
- -- New semantics
-
- else
- declare
- Bod : Node_Id;
-
- begin
- -- General case
-
- if not Is_Unc then
- Bod :=
- Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
- Blk :=
- Make_Block_Statement (Loc,
- Declarations => Declarations (Bod),
- Handled_Statement_Sequence =>
- Handled_Statement_Sequence (Bod));
-
- -- Inline a call to a function that returns an unconstrained type.
- -- The semantic analyzer checked that frontend-inlined functions
- -- returning unconstrained types have no declarations and have
- -- a single extended return statement. As part of its processing
- -- the function was split into two subprograms: a procedure P' and
- -- a function F' that has a block with a call to procedure P' (see
- -- Split_Unconstrained_Function).
-
- else
- pragma Assert
- (Nkind
- (First
- (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
- N_Block_Statement);
-
- declare
- Blk_Stmt : constant Node_Id :=
- First (Statements (Handled_Statement_Sequence (Orig_Bod)));
- First_Stmt : constant Node_Id :=
- First (Statements (Handled_Statement_Sequence (Blk_Stmt)));
- Second_Stmt : constant Node_Id := Next (First_Stmt);
-
- begin
- pragma Assert
- (Nkind (First_Stmt) = N_Procedure_Call_Statement
- and then Nkind (Second_Stmt) = N_Simple_Return_Statement
- and then No (Next (Second_Stmt)));
-
- Bod :=
- Copy_Generic_Node
- (First
- (Statements (Handled_Statement_Sequence (Orig_Bod))),
- Empty, Instantiating => True);
- Blk := Bod;
-
- -- Capture the name of the local variable that holds the
- -- result. This must be the first declaration in the block,
- -- because its bounds cannot depend on local variables.
- -- Otherwise there is no way to declare the result outside
- -- of the block. Needless to say, in general the bounds will
- -- depend on the actuals in the call.
-
- if Nkind (Parent (N)) /= N_Assignment_Statement then
- Targ1 := Defining_Identifier (First (Declarations (Blk)));
-
- -- If the context is an assignment statement, as is the case
- -- for the expansion of an extended return, the left-hand
- -- side provides bounds even if the return type is
- -- unconstrained.
-
- else
- Targ1 := Name (Parent (N));
- end if;
- end;
- end if;
-
- if No (Declarations (Bod)) then
- Set_Declarations (Blk, New_List);
- end if;
- end;
- end if;
-
- -- If this is a derived function, establish the proper return type
-
- if Present (Orig_Subp) and then Orig_Subp /= Subp then
- Ret_Type := Etype (Orig_Subp);
- else
- Ret_Type := Etype (Subp);
- end if;
-
- -- Create temporaries for the actuals that are expressions, or that are
- -- scalars and require copying to preserve semantics.
-
- F := First_Formal (Subp);
- A := First_Actual (N);
- while Present (F) loop
- if Present (Renamed_Object (F)) then
-
- -- If expander is active, it is an error to try to inline a
- -- recursive program. In GNATprove mode, just indicate that the
- -- inlining will not happen, and mark the subprogram as not always
- -- inlined.
-
- if GNATprove_Mode then
- Cannot_Inline
- ("cannot inline call to recursive subprogram?", N, Subp);
- Set_Is_Inlined_Always (Subp, False);
- else
- Error_Msg_N
- ("cannot inline call to recursive subprogram", N);
- end if;
-
- return;
- end if;
-
- -- Reset Last_Assignment for any parameters of mode out or in out, to
- -- prevent spurious warnings about overwriting for assignments to the
- -- formal in the inlined code.
-
- if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
- Set_Last_Assignment (Entity (A), Empty);
- end if;
-
- -- If the argument may be a controlling argument in a call within
- -- the inlined body, we must preserve its classwide nature to insure
- -- that dynamic dispatching take place subsequently. If the formal
- -- has a constraint it must be preserved to retain the semantics of
- -- the body.
-
- if Is_Class_Wide_Type (Etype (F))
- or else (Is_Access_Type (Etype (F))
- and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
- then
- Temp_Typ := Etype (F);
-
- elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
- and then Etype (F) /= Base_Type (Etype (F))
- and then Is_Constrained (Etype (F))
- then
- Temp_Typ := Etype (F);
-
- else
- Temp_Typ := Etype (A);
- end if;
-
- -- If the actual is a simple name or a literal, no need to
- -- create a temporary, object can be used directly.
-
- -- If the actual is a literal and the formal has its address taken,
- -- we cannot pass the literal itself as an argument, so its value
- -- must be captured in a temporary. Skip this optimization in
- -- GNATprove mode, to make sure any check on a type conversion
- -- will be issued.
-
- if (Is_Entity_Name (A)
- and then
- (not Is_Scalar_Type (Etype (A))
- or else Ekind (Entity (A)) = E_Enumeration_Literal)
- and then not GNATprove_Mode)
-
- -- When the actual is an identifier and the corresponding formal is
- -- used only once in the original body, the formal can be substituted
- -- directly with the actual parameter. Skip this optimization in
- -- GNATprove mode, to make sure any check on a type conversion
- -- will be issued.
-
- or else
- (Nkind (A) = N_Identifier
- and then Formal_Is_Used_Once (F)
- and then not GNATprove_Mode)
-
- or else
- (Nkind_In (A, N_Real_Literal,
- N_Integer_Literal,
- N_Character_Literal)
- and then not Address_Taken (F))
- then
- if Etype (F) /= Etype (A) then
- Set_Renamed_Object
- (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
- else
- Set_Renamed_Object (F, A);
- end if;
-
- else
- Temp := Make_Temporary (Loc, 'C');
-
- -- If the actual for an in/in-out parameter is a view conversion,
- -- make it into an unchecked conversion, given that an untagged
- -- type conversion is not a proper object for a renaming.
+ -- If the body is a single extended return statement,the
+ -- resulting block is a nested block.
- -- In-out conversions that involve real conversions have already
- -- been transformed in Expand_Actuals.
+ if No (First_Decl) then
+ First_Decl :=
+ First (Statements (Handled_Statement_Sequence (Blk)));
- if Nkind (A) = N_Type_Conversion
- and then Ekind (F) /= E_In_Parameter
- then
- New_A :=
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
- Expression => Relocate_Node (Expression (A)));
+ if Nkind (First_Decl) = N_Block_Statement then
+ First_Decl := First (Declarations (First_Decl));
+ end if;
+ end if;
- -- In GNATprove mode, keep the most precise type of the actual for
- -- the temporary variable, when the formal type is unconstrained.
- -- Otherwise, the AST may contain unexpected assignment statements
- -- to a temporary variable of unconstrained type renaming a local
- -- variable of constrained type, which is not expected by
- -- GNATprove.
+ -- No front-end inlining possible
- elsif Etype (F) /= Etype (A)
- and then (not GNATprove_Mode or else Is_Constrained (Etype (F)))
- then
- New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
- Temp_Typ := Etype (F);
+ if Nkind (First_Decl) /= N_Object_Declaration then
+ return;
+ end if;
- else
- New_A := Relocate_Node (A);
+ if Nkind (Parent (N)) /= N_Assignment_Statement then
+ Targ1 := Defining_Identifier (First_Decl);
+ else
+ Targ1 := Name (Parent (N));
+ end if;
+ end;
end if;
+ end;
- Set_Sloc (New_A, Sloc (N));
+ -- New semantics
- -- If the actual has a by-reference type, it cannot be copied,
- -- so its value is captured in a renaming declaration. Otherwise
- -- declare a local constant initialized with the actual.
+ else
+ declare
+ Bod : Node_Id;
- -- We also use a renaming declaration for expressions of an array
- -- type that is not bit-packed, both for efficiency reasons and to
- -- respect the semantics of the call: in most cases the original
- -- call will pass the parameter by reference, and thus the inlined
- -- code will have the same semantics.
+ begin
+ -- General case
- -- Finally, we need a renaming declaration in the case of limited
- -- types for which initialization cannot be by copy either.
+ if not Is_Unc then
+ Bod :=
+ Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
+ Blk :=
+ Make_Block_Statement (Loc,
+ Declarations => Declarations (Bod),
+ Handled_Statement_Sequence =>
+ Handled_Statement_Sequence (Bod));
- if Ekind (F) = E_In_Parameter
- and then not Is_By_Reference_Type (Etype (A))
- and then not Is_Limited_Type (Etype (A))
- and then
- (not Is_Array_Type (Etype (A))
- or else not Is_Object_Reference (A)
- or else Is_Bit_Packed_Array (Etype (A)))
- then
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
- Expression => New_A);
+ -- Inline a call to a function that returns an unconstrained type.
+ -- The semantic analyzer checked that frontend-inlined functions
+ -- returning unconstrained types have no declarations and have
+ -- a single extended return statement. As part of its processing
+ -- the function was split into two subprograms: a procedure P' and
+ -- a function F' that has a block with a call to procedure P' (see
+ -- Split_Unconstrained_Function).
else
- -- In GNATprove mode, make an explicit copy of input
- -- parameters when formal and actual types differ, to make
- -- sure any check on the type conversion will be issued.
- -- The legality of the copy is ensured by calling first
- -- Call_Can_Be_Inlined_In_GNATprove_Mode.
+ pragma Assert
+ (Nkind
+ (First
+ (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
+ N_Block_Statement);
- 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_Limited_Type (Etype (A)));
+ declare
+ Blk_Stmt : constant Node_Id :=
+ First (Statements (Handled_Statement_Sequence (Orig_Bod)));
+ First_Stmt : constant Node_Id :=
+ First (Statements (Handled_Statement_Sequence (Blk_Stmt)));
+ Second_Stmt : constant Node_Id := Next (First_Stmt);
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'C'),
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
- Expression => New_Copy_Tree (New_A)));
- end if;
+ begin
+ pragma Assert
+ (Nkind (First_Stmt) = N_Procedure_Call_Statement
+ and then Nkind (Second_Stmt) = N_Simple_Return_Statement
+ and then No (Next (Second_Stmt)));
- Decl :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Temp,
- Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
- Name => New_A);
+ Bod :=
+ Copy_Generic_Node
+ (First
+ (Statements (Handled_Statement_Sequence (Orig_Bod))),
+ Empty, Instantiating => True);
+ Blk := Bod;
+
+ -- Capture the name of the local variable that holds the
+ -- result. This must be the first declaration in the block,
+ -- because its bounds cannot depend on local variables.
+ -- Otherwise there is no way to declare the result outside
+ -- of the block. Needless to say, in general the bounds will
+ -- depend on the actuals in the call.
+
+ if Nkind (Parent (N)) /= N_Assignment_Statement then
+ Targ1 := Defining_Identifier (First (Declarations (Blk)));
+
+ -- If the context is an assignment statement, as is the case
+ -- for the expansion of an extended return, the left-hand
+ -- side provides bounds even if the return type is
+ -- unconstrained.
+
+ else
+ Targ1 := Name (Parent (N));
+ end if;
+ end;
end if;
- Append (Decl, Decls);
- Set_Renamed_Object (F, Temp);
- end if;
+ if No (Declarations (Bod)) then
+ Set_Declarations (Blk, New_List);
+ end if;
+ end;
+ end if;
- Next_Formal (F);
- Next_Actual (A);
- end loop;
+ -- If this is a derived function, establish the proper return type
+
+ if Present (Orig_Subp) and then Orig_Subp /= Subp then
+ Ret_Type := Etype (Orig_Subp);
+ else
+ Ret_Type := Etype (Subp);
+ end if;
+
+ -- Create temporaries for the actuals that are expressions, or that are
+ -- scalars and require copying to preserve semantics.
+
+ Establish_Actual_Mapping_For_Inlined_Call (N, Subp, Decls, Orig_Bod);
-- Establish target of function call. If context is not assignment or
-- declaration, create a temporary as a target. The declaration for the
-- Cleanup mapping between formals and actuals for other expansions
- F := First_Formal (Subp);
- while Present (F) loop
- Set_Renamed_Object (F, Empty);
- Next_Formal (F);
- end loop;
+ Reset_Actual_Mapping_For_Inlined_Call (Subp);
end Expand_Inlined_Call;
--------------------------
Backend_Not_Inlined_Subps := No_Elist;
end Initialize;
+ --------------------------------------------
+ -- Inline_Static_Expression_Function_Call --
+ --------------------------------------------
+
+ procedure Inline_Static_Expression_Function_Call
+ (N : Node_Id; Subp : Entity_Id)
+ is
+
+ function Replace_Formal (N : Node_Id) return Traverse_Result;
+ -- Replace each occurrence of a formal with the corresponding actual,
+ -- using the mapping created by Establish_Mapping_For_Inlined_Call.
+
+ function Reset_Sloc (Nod : Node_Id) return Traverse_Result;
+ -- Reset the Sloc of a node to that of the call itself, so that errors
+ -- will be flagged on the call to the static expression function itself
+ -- rather than on the expression of the function's declaration.
+
+ --------------------
+ -- Replace_Formal --
+ --------------------
+
+ function Replace_Formal (N : Node_Id) return Traverse_Result is
+ A : Entity_Id;
+ E : Entity_Id;
+
+ begin
+ if Is_Entity_Name (N) and then Present (Entity (N)) then
+ E := Entity (N);
+
+ if Is_Formal (E) and then Scope (E) = Subp then
+ A := Renamed_Object (E);
+
+ if Nkind (A) = N_Defining_Identifier then
+ Rewrite (N, New_Occurrence_Of (A, Sloc (N)));
+
+ -- Literal cases
+
+ else
+ Rewrite (N, New_Copy (A));
+ end if;
+ end if;
+
+ return Skip;
+
+ else
+ return OK;
+ end if;
+ end Replace_Formal;
+
+ procedure Replace_Formals is new Traverse_Proc (Replace_Formal);
+
+ ------------------
+ -- Process_Sloc --
+ ------------------
+
+ function Reset_Sloc (Nod : Node_Id) return Traverse_Result is
+ begin
+ Set_Sloc (Nod, Sloc (N));
+ Set_Comes_From_Source (Nod, False);
+
+ return OK;
+ end Reset_Sloc;
+
+ procedure Reset_Slocs is new Traverse_Proc (Reset_Sloc);
+
+ -- Start of processing for Inline_Static_Expression_Function_Call
+
+ begin
+ pragma Assert (Is_Static_Expression_Function_Call (N));
+
+ declare
+ Decls : constant List_Id := New_List;
+ Func_Expr : constant Node_Id :=
+ Expression_Of_Expression_Function (Subp);
+ Expr_Copy : constant Node_Id := New_Copy_Tree (Func_Expr);
+
+ begin
+ -- Create a mapping from formals to actuals, also creating temps in
+ -- Decls, when needed, to hold the actuals.
+
+ Establish_Actual_Mapping_For_Inlined_Call (N, Subp, Decls, Func_Expr);
+
+ Insert_Actions (N, Decls);
+
+ -- Now substitute actuals for their corresponding formal references
+ -- within the expression.
+
+ Replace_Formals (Expr_Copy);
+
+ Reset_Slocs (Expr_Copy);
+
+ -- Apply a qualified expression with the function's result subtype,
+ -- to ensure that we check the expression against any constraint
+ -- or predicate, which will cause the call to be illegal if the
+ -- folded expression doesn't satisfy them. (The predicate case
+ -- might not get checked if the subtype hasn't been frozen yet,
+ -- which can happen if this static expression happens to be what
+ -- causes the freezing, because Has_Static_Predicate doesn't get
+ -- set on the subtype until it's frozen and Build_Predicates is
+ -- called. It's not clear how to address this case. ???)
+
+ Rewrite (Expr_Copy,
+ Make_Qualified_Expression (Sloc (Expr_Copy),
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (N), Sloc (Expr_Copy)),
+ Expression =>
+ Relocate_Node (Expr_Copy)));
+
+ Set_Etype (Expr_Copy, Etype (N));
+
+ Analyze_And_Resolve (Expr_Copy, Etype (N));
+
+ -- Finally rewrite the function call as the folded static result
+
+ Rewrite (N, Expr_Copy);
+
+ -- Cleanup mapping between formals and actuals for other expansions
+
+ Reset_Actual_Mapping_For_Inlined_Call (Subp);
+ end;
+ end Inline_Static_Expression_Function_Call;
+
------------------------
-- Instantiate_Bodies --
------------------------
end loop;
end Remove_Dead_Instance;
+ -------------------------------------------
+ -- Reset_Actual_Mapping_For_Inlined_Call --
+ -------------------------------------------
+
+ procedure Reset_Actual_Mapping_For_Inlined_Call (Subp : Entity_Id) is
+ F : Entity_Id := First_Formal (Subp);
+
+ begin
+ while Present (F) loop
+ Set_Renamed_Object (F, Empty);
+ Next_Formal (F);
+ end loop;
+ end Reset_Actual_Mapping_For_Inlined_Call;
+
end Inline;
projects / gcc.git / commitdiff