-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, 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- --
-- N is an aggregate (record or array). Checks the presence of default
-- initialization (<>) in any component (Ada 2005: AI-287).
- function In_Object_Declaration (N : Node_Id) return Boolean;
- -- Return True if N is part of an object declaration, False otherwise
+ function Is_CCG_Supported_Aggregate (N : Node_Id) return Boolean;
+ -- Return True if aggregate N is located in a context supported by the
+ -- CCG backend; False otherwise.
function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean;
-- Returns true if N is an aggregate used to initialize the components
-- Local subprograms for Record Aggregate Expansion --
------------------------------------------------------
+ function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean;
+ -- True if N is an aggregate (possibly qualified or converted) that is
+ -- being returned from a build-in-place function.
+
function Build_Record_Aggr_Code
(N : Node_Id;
Typ : Entity_Id;
-- types.
procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id);
- -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
- -- aggregate (which can only be a record type, this procedure is only used
- -- for record types). Transform the given aggregate into a sequence of
- -- assignments performed component by component.
+ -- Transform a record aggregate into a sequence of assignments performed
+ -- component by component. N is an N_Aggregate or N_Extension_Aggregate.
+ -- Typ is the type of the record aggregate.
procedure Expand_Record_Aggregate
(N : Node_Id;
-- defaults. An aggregate for a type with mutable components must be
-- expanded into individual assignments.
+ function In_Place_Assign_OK (N : Node_Id) return Boolean;
+ -- Predicate to determine whether an aggregate assignment can be done in
+ -- place, because none of the new values can depend on the components of
+ -- the target of the assignment.
+
procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id);
-- If the type of the aggregate is a type extension with renamed discrimi-
-- nants, we must initialize the hidden discriminants of the parent.
-- calling Flatten.
--
-- This function also detects and warns about one-component aggregates that
- -- appear in a non-static context. Even if the component value is static,
+ -- appear in a nonstatic context. Even if the component value is static,
-- such an aggregate must be expanded into an assignment.
function Backend_Processing_Possible (N : Node_Id) return Boolean;
procedure Convert_To_Positional
(N : Node_Id;
- Max_Others_Replicate : Nat := 5;
+ Max_Others_Replicate : Nat := 32;
Handle_Bit_Packed : Boolean := False);
-- If possible, convert named notation to positional notation. This
-- conversion is possible only in some static cases. If the conversion is
-- possible, then N is rewritten with the analyzed converted aggregate.
-- The parameter Max_Others_Replicate controls the maximum number of
-- values corresponding to an others choice that will be converted to
- -- positional notation (the default of 5 is the normal limit, and reflects
+ -- positional notation (the default of 32 is the normal limit, and reflects
-- the fact that normally the loop is better than a lot of separate
-- assignments). Note that this limit gets overridden in any case if
-- either of the restrictions No_Elaboration_Code or No_Implicit_Loops is
-- Packed_Array_Aggregate_Handled, we set this parameter to True, since
-- these are cases we handle in there.
- -- It would seem useful to have a higher default for Max_Others_Replicate,
- -- but aggregates in the compiler make this impossible: the compiler
- -- bootstrap fails if Max_Others_Replicate is greater than 25. This
- -- is unexpected ???
-
procedure Expand_Array_Aggregate (N : Node_Id);
-- This is the top-level routine to perform array aggregate expansion.
-- N is the N_Aggregate node to be expanded.
Lo : Node_Id;
Hi : Node_Id;
Indx : Node_Id;
- Siz : Int;
+ Size : Uint;
Lov : Uint;
Hiv : Uint;
-- Start of processing for Aggr_Size_OK
begin
- -- The normal aggregate limit is 50000, but we increase this limit to
+ -- The normal aggregate limit is 500000, but we increase this limit to
-- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code) or
-- Restrictions (No_Implicit_Loops) is specified, since in either case
-- we are at risk of declaring the program illegal because of this
-- Finally, we use a small limit in CodePeer mode where we favor loops
-- instead of thousands of single assignments (from large aggregates).
- Max_Aggr_Size := 50000;
+ Max_Aggr_Size := 500000;
if CodePeer_Mode then
Max_Aggr_Size := 100;
Max_Aggr_Size := 5000;
end if;
- Siz := Component_Count (Component_Type (Typ));
+ Size := UI_From_Int (Component_Count (Component_Type (Typ)));
Indx := First_Index (Typ);
while Present (Indx) loop
end if;
-- One-component aggregates are suspicious, and if the context type
- -- is an object declaration with non-static bounds it will trip gcc;
+ -- is an object declaration with nonstatic bounds it will trip gcc;
-- such an aggregate must be expanded into a single assignment.
if Hiv = Lov and then Nkind (Parent (N)) = N_Object_Declaration then
return False;
end if;
- Siz := Siz * UI_To_Int (Rng);
- end;
+ -- Compute the size using universal arithmetic to avoid the
+ -- possibility of overflow on very large aggregates.
- if Siz <= 0
- or else Siz > Max_Aggr_Size
- then
- return False;
- end if;
+ Size := Size * Rng;
+
+ if Size <= 0
+ or else Size > Max_Aggr_Size
+ then
+ return False;
+ end if;
+ end;
-- Bounds must be in integer range, for later array construction
-- Checks 11: The C code generator cannot handle aggregates that are
-- not part of an object declaration.
- if Modify_Tree_For_C then
- declare
- Par : Node_Id := Parent (N);
-
- begin
- -- Skip enclosing nested aggregates and their qualified
- -- expressions.
-
- while Nkind (Par) = N_Aggregate
- or else Nkind (Par) = N_Qualified_Expression
- loop
- Par := Parent (Par);
- end loop;
-
- if Nkind (Par) /= N_Object_Declaration then
- return False;
- end if;
- end;
+ if Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then
+ return False;
end if;
-- Checks on components
-- Recurse to check subaggregates, which may appear in qualified
-- expressions. If delayed, the front-end will have to expand.
- -- If the component is a discriminated record, treat as non-static,
+ -- If the component is a discriminated record, treat as nonstatic,
-- as the back-end cannot handle this properly.
Expr := First (Expressions (N));
-- Checks 5 (if the component type is tagged, then we may need to do
-- tag adjustments. Perhaps this should be refined to check for any
-- component associations that actually need tag adjustment, similar
- -- to the test in Component_Not_OK_For_Backend for record aggregates
- -- with tagged components, but not clear whether it's worthwhile ???;
- -- in the case of virtual machines (no Tagged_Type_Expansion), object
- -- tags are handled implicitly).
+ -- to the test in Component_OK_For_Backend for record aggregates with
+ -- tagged components, but not clear whether it's worthwhile ???; in the
+ -- case of virtual machines (no Tagged_Type_Expansion), object tags are
+ -- handled implicitly).
if Is_Tagged_Type (Component_Type (Typ))
and then Tagged_Type_Expansion
if Finalization_OK
and then not Is_Limited_Type (Comp_Typ)
+ and then not Is_Build_In_Place_Function_Call (Init_Expr)
and then not
(Is_Array_Type (Comp_Typ)
and then Is_Controlled (Component_Type (Comp_Typ))
In_Place_Expansion :=
Nkind (Expr) = N_Function_Call
- and then not Is_Limited_Type (Comp_Typ);
+ and then not Is_Build_In_Place_Result_Type (Comp_Typ);
-- The initialization expression is a controlled function call.
-- Perform in-place removal of side effects to avoid creating a
-- transient scope, which leads to premature finalization.
-- This in-place expansion is not performed for limited transient
- -- objects because the initialization is already done in-place.
+ -- objects, because the initialization is already done in place.
if In_Place_Expansion then
- -- Suppress the removal of side effects by general analysis
+ -- Suppress the removal of side effects by general analysis,
-- because this behavior is emulated here. This avoids the
-- generation of a transient scope, which leads to out-of-order
-- adjustment and finalization.
-- the analysis of non-array aggregates now in order to get the
-- value of Expansion_Delayed flag for the inner aggregate ???
+ -- In the case of an iterated component association, the analysis
+ -- of the generated loop will analyze the expression in the
+ -- proper context, in which the loop parameter is visible.
+
if Present (Comp_Typ) and then not Is_Array_Type (Comp_Typ) then
- Analyze_And_Resolve (Expr_Q, Comp_Typ);
+ if Nkind (Parent (Expr_Q)) = N_Iterated_Component_Association
+ or else Nkind (Parent (Parent ((Expr_Q)))) =
+ N_Iterated_Component_Association
+ then
+ null;
+ else
+ Analyze_And_Resolve (Expr_Q, Comp_Typ);
+ end if;
end if;
if Is_Delayed_Aggregate (Expr_Q) then
and then Is_Bit_Packed_Array (Typ)
and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ))
then
- Append_To (New_Code,
- Make_Assignment_Statement (Loc,
- Name => New_Copy_Tree (Into),
- Expression =>
- Unchecked_Convert_To (Typ,
- Make_Integer_Literal (Loc, Uint_0))));
+ declare
+ Zero : constant Node_Id := Make_Integer_Literal (Loc, Uint_0);
+ begin
+ Analyze_And_Resolve (Zero, Packed_Array_Impl_Type (Typ));
+ Append_To (New_Code,
+ Make_Assignment_Statement (Loc,
+ Name => New_Copy_Tree (Into),
+ Expression => Unchecked_Convert_To (Typ, Zero)));
+ end;
end if;
-- If the component type contains tasks, we need to build a Master
Choice := First (Choice_List (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
- Set_Loop_Actions (Assoc, New_List);
Others_Assoc := Assoc;
exit;
end if;
if Present (Others_Assoc) then
declare
- First : Boolean := True;
+ First : Boolean := True;
+ Dup_Expr : Node_Id;
begin
for J in 0 .. Nb_Choices loop
or else not Empty_Range (Low, High)
then
First := False;
+
+ -- Duplicate the expression in case we will be generating
+ -- several loops. As a result the expression is no longer
+ -- shared between the loops and is reevaluated for each
+ -- such loop.
+
+ Expr := Get_Assoc_Expr (Others_Assoc);
+ Dup_Expr := New_Copy_Tree (Expr);
+ Set_Parent (Dup_Expr, Parent (Expr));
+
+ Set_Loop_Actions (Others_Assoc, New_List);
Append_List
- (Gen_Loop (Low, High,
- Get_Assoc_Expr (Others_Assoc)), To => New_Code);
+ (Gen_Loop (Low, High, Dup_Expr), To => New_Code);
end if;
end loop;
end;
Discr_Constr :=
First_Elmt (Stored_Constraint (Full_View (Base_Typ)));
+ -- Otherwise, no discriminant to process
+
else
- Discr_Constr := First_Elmt (Stored_Constraint (Typ));
+ Discr_Constr := No_Elmt;
end if;
while Present (Discr) and then Present (Discr_Constr) loop
Selector_Name => New_Occurrence_Of (Discr, Loc)),
Expression => New_Copy_Tree (Discr_Val));
- Set_No_Ctrl_Actions (Discr_Init);
Append_To (List, Discr_Init);
end if;
Name => Comp_Expr,
Expression => New_Copy_Tree (Discriminant_Value));
- Set_No_Ctrl_Actions (Instr);
Append_To (L, Instr);
Next_Discriminant (Discriminant);
Name => Comp_Expr,
Expression => New_Copy_Tree (Discriminant_Value));
- Set_No_Ctrl_Actions (Instr);
Append_To (L, Instr);
Next_Stored_Discriminant (Discriminant);
In_Place_Expansion :=
Nkind (Init_Expr) = N_Function_Call
- and then not Is_Limited_Type (Comp_Typ);
+ and then not Is_Build_In_Place_Result_Type (Comp_Typ);
-- The initialization expression is a controlled function call.
-- Perform in-place removal of side effects to avoid creating a
Set_No_Side_Effect_Removal (Init_Expr);
-- Install all hook-related declarations and prepare the clean up
- -- statements.
+ -- statements. The generated code follows the initialization order
+ -- of individual components and discriminants, rather than being
+ -- inserted prior to the aggregate. This ensures that a transient
+ -- component which mentions a discriminant has proper visibility
+ -- of the discriminant.
Process_Transient_Component
(Loc => Loc,
Init_Expr => Init_Expr,
Fin_Call => Fin_Call,
Hook_Clear => Hook_Clear,
- Aggr => N);
+ Stmts => Stmts);
end if;
-- Use the noncontrolled component initialization circuitry to
-- [Deep_]Adjust (Rec_Comp);
- if Finalization_OK and then not Is_Limited_Type (Comp_Typ) then
+ if Finalization_OK
+ and then not Is_Limited_Type (Comp_Typ)
+ and then not Is_Build_In_Place_Function_Call (Init_Expr)
+ then
Adj_Call :=
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Rec_Comp),
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Lhs),
Selector_Name => Make_Identifier (Loc, Chars (Expr))));
+
+ -- The generated code will be reanalyzed, but if the reference
+ -- to the discriminant appears within an already analyzed
+ -- expression (e.g. a conditional) we must set its proper entity
+ -- now. Context is an initialization procedure.
+
+ Analyze (Expr);
end if;
return OK;
-- Ada 2005 (AI-287): If the ancestor part is an aggregate of
-- limited type, a recursive call expands the ancestor. Note that
-- in the limited case, the ancestor part must be either a
- -- function call (possibly qualified, or wrapped in an unchecked
- -- conversion) or aggregate (definitely qualified).
-
- -- The ancestor part can also be a function call (that may be
- -- transformed into an explicit dereference) or a qualification
- -- of one such.
+ -- function call (possibly qualified) or aggregate (definitely
+ -- qualified).
elsif Is_Limited_Type (Etype (Ancestor))
and then Nkind_In (Unqualify (Ancestor), N_Aggregate,
if Needs_Finalization (Etype (Ancestor))
and then not Is_Limited_Type (Etype (Ancestor))
+ and then not Is_Build_In_Place_Function_Call (Ancestor)
then
Adj_Call :=
Make_Adjust_Call
Check_Ancestor_Discriminants (Init_Typ);
end if;
end if;
+
+ pragma Assert (Nkind (N) = N_Extension_Aggregate);
+ pragma Assert
+ (not (Ancestor_Is_Expression and Ancestor_Is_Subtype_Mark));
end;
-- Generate assignments of hidden discriminants. If the base type is
Next_Elmt (Disc2);
end loop;
- -- If any discriminant constraint is non-static, emit a check
+ -- If any discriminant constraint is nonstatic, emit a check
if Present (Cond) then
Insert_Action (N,
and then Ekind (Current_Scope) /= E_Return_Statement
and then not Is_Limited_Type (Typ)
then
- Establish_Transient_Scope
- (Aggr,
- Sec_Stack =>
- Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
+ Establish_Transient_Scope (Aggr, Manage_Sec_Stack => False);
end if;
declare
- Node_After : constant Node_Id := Next (N);
+ Node_After : constant Node_Id := Next (N);
begin
Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ));
Collect_Initialization_Statements (Obj, N, Node_After);
end;
+
Set_No_Initialization (N);
Initialize_Discriminants (N, Typ);
end Convert_Aggr_In_Object_Decl;
Insert_Actions_After (Decl, Aggr_Code);
end Convert_Array_Aggr_In_Allocator;
+ ------------------------
+ -- In_Place_Assign_OK --
+ ------------------------
+
+ function In_Place_Assign_OK (N : Node_Id) return Boolean is
+ Is_Array : constant Boolean := Is_Array_Type (Etype (N));
+
+ Aggr_In : Node_Id;
+ Aggr_Lo : Node_Id;
+ Aggr_Hi : Node_Id;
+ Obj_In : Node_Id;
+ Obj_Lo : Node_Id;
+ Obj_Hi : Node_Id;
+
+ function Safe_Aggregate (Aggr : Node_Id) return Boolean;
+ -- Check recursively that each component of a (sub)aggregate does not
+ -- depend on the variable being assigned to.
+
+ function Safe_Component (Expr : Node_Id) return Boolean;
+ -- Verify that an expression cannot depend on the variable being
+ -- assigned to. Room for improvement here (but less than before).
+
+ --------------------
+ -- Safe_Aggregate --
+ --------------------
+
+ function Safe_Aggregate (Aggr : Node_Id) return Boolean is
+ Expr : Node_Id;
+
+ begin
+ if Nkind (Parent (Aggr)) = N_Iterated_Component_Association then
+ return False;
+ end if;
+
+ if Present (Expressions (Aggr)) then
+ Expr := First (Expressions (Aggr));
+ while Present (Expr) loop
+ if Nkind (Expr) = N_Aggregate then
+ if not Safe_Aggregate (Expr) then
+ return False;
+ end if;
+
+ elsif not Safe_Component (Expr) then
+ return False;
+ end if;
+
+ Next (Expr);
+ end loop;
+ end if;
+
+ if Present (Component_Associations (Aggr)) then
+ Expr := First (Component_Associations (Aggr));
+ while Present (Expr) loop
+ if Nkind (Expression (Expr)) = N_Aggregate then
+ if not Safe_Aggregate (Expression (Expr)) then
+ return False;
+ end if;
+
+ -- If association has a box, no way to determine yet whether
+ -- default can be assigned in place.
+
+ elsif Box_Present (Expr) then
+ return False;
+
+ elsif not Safe_Component (Expression (Expr)) then
+ return False;
+ end if;
+
+ Next (Expr);
+ end loop;
+ end if;
+
+ return True;
+ end Safe_Aggregate;
+
+ --------------------
+ -- Safe_Component --
+ --------------------
+
+ function Safe_Component (Expr : Node_Id) return Boolean is
+ Comp : Node_Id := Expr;
+
+ function Check_Component (Comp : Node_Id) return Boolean;
+ -- Do the recursive traversal, after copy
+
+ ---------------------
+ -- Check_Component --
+ ---------------------
+
+ function Check_Component (Comp : Node_Id) return Boolean is
+ begin
+ if Is_Overloaded (Comp) then
+ return False;
+ end if;
+
+ return Compile_Time_Known_Value (Comp)
+
+ or else (Is_Entity_Name (Comp)
+ and then Present (Entity (Comp))
+ and then Ekind (Entity (Comp)) not in Type_Kind
+ and then No (Renamed_Object (Entity (Comp))))
+
+ or else (Nkind (Comp) = N_Attribute_Reference
+ and then Check_Component (Prefix (Comp)))
+
+ or else (Nkind (Comp) in N_Binary_Op
+ and then Check_Component (Left_Opnd (Comp))
+ and then Check_Component (Right_Opnd (Comp)))
+
+ or else (Nkind (Comp) in N_Unary_Op
+ and then Check_Component (Right_Opnd (Comp)))
+
+ or else (Nkind (Comp) = N_Selected_Component
+ and then Is_Array
+ and then Check_Component (Prefix (Comp)))
+
+ or else (Nkind_In (Comp, N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
+ and then Check_Component (Expression (Comp)));
+ end Check_Component;
+
+ -- Start of processing for Safe_Component
+
+ begin
+ -- If the component appears in an association that may correspond
+ -- to more than one element, it is not analyzed before expansion
+ -- into assignments, to avoid side effects. We analyze, but do not
+ -- resolve the copy, to obtain sufficient entity information for
+ -- the checks that follow. If component is overloaded we assume
+ -- an unsafe function call.
+
+ if not Analyzed (Comp) then
+ if Is_Overloaded (Expr) then
+ return False;
+
+ elsif Nkind (Expr) = N_Aggregate
+ and then not Is_Others_Aggregate (Expr)
+ then
+ return False;
+
+ elsif Nkind (Expr) = N_Allocator then
+
+ -- For now, too complex to analyze
+
+ return False;
+
+ elsif Nkind (Parent (Expr)) = N_Iterated_Component_Association then
+
+ -- Ditto for iterated component associations, which in general
+ -- require an enclosing loop and involve nonstatic expressions.
+
+ return False;
+ end if;
+
+ Comp := New_Copy_Tree (Expr);
+ Set_Parent (Comp, Parent (Expr));
+ Analyze (Comp);
+ end if;
+
+ if Nkind (Comp) = N_Aggregate then
+ return Safe_Aggregate (Comp);
+ else
+ return Check_Component (Comp);
+ end if;
+ end Safe_Component;
+
+ -- Start of processing for In_Place_Assign_OK
+
+ begin
+ -- By-copy semantic cannot be guaranteed for controlled objects or
+ -- objects with discriminants.
+
+ if Needs_Finalization (Etype (N))
+ or else Has_Discriminants (Etype (N))
+ then
+ return False;
+
+ elsif Is_Array and then Present (Component_Associations (N)) then
+
+ -- On assignment, sliding can take place, so we cannot do the
+ -- assignment in place unless the bounds of the aggregate are
+ -- statically equal to those of the target.
+
+ -- If the aggregate is given by an others choice, the bounds are
+ -- derived from the left-hand side, and the assignment is safe if
+ -- the expression is.
+
+ if Is_Others_Aggregate (N) then
+ return
+ Safe_Component
+ (Expression (First (Component_Associations (N))));
+ end if;
+
+ Aggr_In := First_Index (Etype (N));
+
+ if Nkind (Parent (N)) = N_Assignment_Statement then
+ Obj_In := First_Index (Etype (Name (Parent (N))));
+
+ else
+ -- Context is an allocator. Check bounds of aggregate against
+ -- given type in qualified expression.
+
+ pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator);
+ Obj_In := First_Index (Etype (Entity (Subtype_Mark (Parent (N)))));
+ end if;
+
+ while Present (Aggr_In) loop
+ Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi);
+ Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
+
+ if not Compile_Time_Known_Value (Aggr_Lo)
+ or else not Compile_Time_Known_Value (Obj_Lo)
+ or else not Compile_Time_Known_Value (Obj_Hi)
+ or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
+ then
+ return False;
+
+ -- For an assignment statement we require static matching of
+ -- bounds. Ditto for an allocator whose qualified expression
+ -- is a constrained type. If the expression in the allocator
+ -- is an unconstrained array, we accept an upper bound that
+ -- is not static, to allow for nonstatic expressions of the
+ -- base type. Clearly there are further possibilities (with
+ -- diminishing returns) for safely building arrays in place
+ -- here.
+
+ elsif Nkind (Parent (N)) = N_Assignment_Statement
+ or else Is_Constrained (Etype (Parent (N)))
+ then
+ if not Compile_Time_Known_Value (Aggr_Hi)
+ or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
+ then
+ return False;
+ end if;
+ end if;
+
+ Next_Index (Aggr_In);
+ Next_Index (Obj_In);
+ end loop;
+ end if;
+
+ -- Now check the component values themselves
+
+ return Safe_Aggregate (N);
+ end In_Place_Assign_OK;
+
----------------------------
-- Convert_To_Assignments --
----------------------------
Parent_Node : Node_Id;
begin
+ pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate));
pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N));
pragma Assert (Is_Record_Type (Typ));
Parent_Kind := Nkind (Parent_Node);
if Parent_Kind = N_Qualified_Expression then
-
- -- Check if we are in a unconstrained declaration because in this
+ -- Check if we are in an unconstrained declaration because in this
-- case the current delayed expansion mechanism doesn't work when
- -- the declared object size depend on the initializing expr.
+ -- the declared object size depends on the initializing expr.
Parent_Node := Parent (Parent_Node);
Parent_Kind := Nkind (Parent_Node);
if Parent_Kind = N_Object_Declaration then
Unc_Decl :=
not Is_Entity_Name (Object_Definition (Parent_Node))
- or else Has_Discriminants
- (Entity (Object_Definition (Parent_Node)))
+ or else (Nkind (N) = N_Aggregate
+ and then
+ Has_Discriminants
+ (Entity (Object_Definition (Parent_Node))))
or else Is_Class_Wide_Type
(Entity (Object_Definition (Parent_Node)));
end if;
-- finalization of the return object (which is built in place
-- within the caller's scope).
- or else
- (Is_Limited_View (Typ)
- and then
- (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement
- or else Nkind (Parent_Node) = N_Simple_Return_Statement))
+ or else Is_Build_In_Place_Aggregate_Return (N)
then
Set_Expansion_Delayed (N);
return;
-- Should the condition be more restrictive ???
if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then
- Establish_Transient_Scope (N, Sec_Stack => Needs_Finalization (Typ));
+ Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
- -- If the aggregate is nonlimited, create a temporary. If it is limited
- -- and context is an assignment, this is a subaggregate for an enclosing
- -- aggregate being expanded. It must be built in place, so use target of
- -- the current assignment.
+ -- If the aggregate is nonlimited, create a temporary, since aggregates
+ -- have "by copy" semantics. If it is limited and context is an
+ -- assignment, this is a subaggregate for an enclosing aggregate being
+ -- expanded. It must be built in place, so use target of the current
+ -- assignment.
if Is_Limited_Type (Typ)
and then Nkind (Parent (N)) = N_Assignment_Statement
Build_Record_Aggr_Code (N, Typ, Target_Expr));
Rewrite (Parent (N), Make_Null_Statement (Loc));
+ -- Do not declare a temporary to initialize an aggregate assigned to an
+ -- identifier when in-place assignment is possible, preserving the
+ -- by-copy semantic of aggregates. This avoids large stack usage and
+ -- generates more efficient code.
+
+ elsif Nkind (Parent (N)) = N_Assignment_Statement
+ and then Nkind (Name (Parent (N))) = N_Identifier
+ and then In_Place_Assign_OK (N)
+ then
+ Target_Expr := New_Copy_Tree (Name (Parent (N)));
+ Insert_Actions (Parent (N),
+ Build_Record_Aggr_Code (N, Typ, Target_Expr));
+ Rewrite (Parent (N), Make_Null_Statement (Loc));
+
else
Temp := Make_Temporary (Loc, 'A', N);
procedure Convert_To_Positional
(N : Node_Id;
- Max_Others_Replicate : Nat := 5;
+ Max_Others_Replicate : Nat := 32;
Handle_Bit_Packed : Boolean := False)
is
Typ : constant Entity_Id := Etype (N);
-- Check whether all components of the aggregate are compile-time known
-- values, and can be passed as is to the back-end without further
-- expansion.
- -- An Iterated_Component_Association is treated as non-static, but there
- -- are possibilities for optimization here.
function Flatten
(N : Node_Id;
-- Return True iff the array N is flat (which is not trivial in the case
-- of multidimensional aggregates).
+ function Is_Static_Element (N : Node_Id) return Boolean;
+ -- Return True if N, an element of a component association list, i.e.
+ -- N_Component_Association or N_Iterated_Component_Association, has a
+ -- compile-time known value and can be passed as is to the back-end
+ -- without further expansion.
+ -- An Iterated_Component_Association is treated as nonstatic in most
+ -- cases for now, so there are possibilities for optimization.
+
-----------------------------
-- Check_Static_Components --
-----------------------------
-- Could use some comments in this body ???
procedure Check_Static_Components is
- Expr : Node_Id;
+ Assoc : Node_Id;
+ Expr : Node_Id;
begin
Static_Components := True;
if Nkind (N) = N_Aggregate
and then Present (Component_Associations (N))
then
- Expr := First (Component_Associations (N));
- while Present (Expr) loop
- if Nkind_In (Expression (Expr), N_Integer_Literal,
- N_Real_Literal)
- then
- null;
-
- elsif Is_Entity_Name (Expression (Expr))
- and then Present (Entity (Expression (Expr)))
- and then Ekind (Entity (Expression (Expr))) =
- E_Enumeration_Literal
- then
- null;
-
- elsif Nkind (Expression (Expr)) /= N_Aggregate
- or else not Compile_Time_Known_Aggregate (Expression (Expr))
- or else Expansion_Delayed (Expression (Expr))
- or else Nkind (Expr) = N_Iterated_Component_Association
- then
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+ if not Is_Static_Element (Assoc) then
Static_Components := False;
exit;
end if;
- Next (Expr);
+ Next (Assoc);
end loop;
end if;
end Check_Static_Components;
return False;
end if;
- Vals (Num) := Relocate_Node (Elmt);
+ -- Duplicate expression for each index it covers
+
+ Vals (Num) := New_Copy_Tree (Elmt);
Num := Num + 1;
Next (Elmt);
if Nkind (Choice) = N_Others_Choice then
Rep_Count := 0;
+ -- If the expression involves a construct that generates
+ -- a loop, we must generate individual assignments and
+ -- no flattening is possible.
+
+ if Nkind (Expression (Elmt)) = N_Quantified_Expression
+ then
+ return False;
+ end if;
+
for J in Vals'Range loop
if No (Vals (J)) then
- Vals (J) := New_Copy_Tree (Expression (Elmt));
+ Vals (J) := New_Copy_Tree (Expression (Elmt));
Rep_Count := Rep_Count + 1;
-- Check for maximum others replication. Note that
declare
P : constant Entity_Id :=
- Cunit_Entity (Current_Sem_Unit);
+ Cunit_Entity (Current_Sem_Unit);
begin
- -- Check if duplication OK and if so continue
- -- processing.
+ -- Check if duplication is always OK and, if so,
+ -- continue processing.
if Restriction_Active (No_Elaboration_Code)
or else Restriction_Active (No_Implicit_Loops)
then
null;
- -- If duplication not OK, then we return False
- -- if the replication count is too high
+ -- If duplication is not always OK, continue
+ -- only if either the element is static or is
+ -- an aggregate which can itself be flattened,
+ -- and the replication count is not too high.
- elsif Rep_Count > Max_Others_Replicate then
- return False;
+ elsif (Is_Static_Element (Elmt)
+ or else
+ (Nkind (Expression (Elmt)) = N_Aggregate
+ and then Present (Next_Index (Ix))))
+ and then Rep_Count <= Max_Others_Replicate
+ then
+ null;
- -- Continue on if duplication not OK, but the
- -- replication count is not excessive.
+ -- Return False in all the other cases
else
- null;
+ return False;
end if;
end;
end if;
end loop;
+ if Rep_Count = 0
+ and then Warn_On_Redundant_Constructs
+ then
+ Error_Msg_N ("there are no others?r?", Elmt);
+ end if;
+
exit Component_Loop;
-- Case of a subtype mark, identifier or expanded name
end if;
end Is_Flat;
+ -------------------------
+ -- Is_Static_Element --
+ -------------------------
+
+ function Is_Static_Element (N : Node_Id) return Boolean is
+ Expr : constant Node_Id := Expression (N);
+
+ begin
+ if Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then
+ return True;
+
+ elsif Is_Entity_Name (Expr)
+ and then Present (Entity (Expr))
+ and then Ekind (Entity (Expr)) = E_Enumeration_Literal
+ then
+ return True;
+
+ elsif Nkind (N) = N_Iterated_Component_Association then
+ return False;
+
+ elsif Nkind (Expr) = N_Aggregate
+ and then Compile_Time_Known_Aggregate (Expr)
+ and then not Expansion_Delayed (Expr)
+ then
+ return True;
+
+ else
+ return False;
+ end if;
+ end Is_Static_Element;
+
-- Start of processing for Convert_To_Positional
begin
-- object declaration, this is the only case where aggregates are
-- supported in C.
- if Modify_Tree_For_C and then not In_Object_Declaration (N) then
+ if Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then
return;
end if;
return;
end if;
+ -- A subaggregate may have been flattened but is not known to be
+ -- Compile_Time_Known. Set that flag in cases that cannot require
+ -- elaboration code, so that the aggregate can be used as the
+ -- initial value of a thread-local variable.
+
if Is_Flat (N, Number_Dimensions (Typ)) then
+ if Static_Array_Aggregate (N) then
+ Set_Compile_Time_Known_Aggregate (N);
+ end if;
+
return;
end if;
-- case pass it as is to Gigi. Note that a necessary condition for
-- static processing is that the aggregate be fully positional.
- -- 5. If in place aggregate expansion is possible (i.e. no need to create
+ -- 5. If in-place aggregate expansion is possible (i.e. no need to create
-- a temporary) then mark the aggregate as such and return. Otherwise
-- create a new temporary and generate the appropriate initialization
-- code.
-- The type of each index
In_Place_Assign_OK_For_Declaration : Boolean := False;
- -- True if we are to generate an in place assignment for a declaration
+ -- True if we are to generate an in-place assignment for a declaration
Maybe_In_Place_OK : Boolean;
-- If the type is neither controlled nor packed and the aggregate
-- subaggregate we start the computation from. Dim is the dimension
-- corresponding to the subaggregate.
- function In_Place_Assign_OK return Boolean;
- -- Simple predicate to determine whether an aggregate assignment can
- -- be done in place, because none of the new values can depend on the
- -- components of the target of the assignment.
-
procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos);
-- Checks that if an others choice is present in any subaggregate, no
-- aggregate index is outside the bounds of the index constraint.
-- 1. N consists of a single OTHERS choice, possibly recursively
- -- 2. The array type is not packed
+ -- 2. The array type has no null ranges (the purpose of this is to
+ -- avoid a bogus warning for an out-of-range value).
-- 3. The array type has no atomic components
- -- 4. The array type has no null ranges (the purpose of this is to
- -- avoid a bogus warning for an out-of-range value).
+ -- 4. The component type is elementary
- -- 5. The component type is elementary
+ -- 5. The component size is a multiple of Storage_Unit
-- 6. The component size is Storage_Unit or the value is of the form
-- M * (1 + A**1 + A**2 + .. A**(K-1)) where A = 2**(Storage_Unit)
-- specifically optimized for the target.
function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean is
+ Csiz : Uint := No_Uint;
Ctyp : Entity_Id;
+ Expr : Node_Id;
+ High : Node_Id;
Index : Entity_Id;
- Expr : Node_Id := N;
Low : Node_Id;
- High : Node_Id;
+ Nunits : Int;
Remainder : Uint;
Value : Uint;
- Nunits : Nat;
begin
+ -- Back end doesn't know about <>
+
+ if Has_Default_Init_Comps (N) then
+ return False;
+ end if;
+
-- Recurse as far as possible to find the innermost component type
Ctyp := Etype (N);
+ Expr := N;
while Is_Array_Type (Ctyp) loop
if Nkind (Expr) /= N_Aggregate
or else not Is_Others_Aggregate (Expr)
return False;
end if;
- if Present (Packed_Array_Impl_Type (Ctyp)) then
- return False;
- end if;
-
- if Has_Atomic_Components (Ctyp) then
- return False;
- end if;
-
Index := First_Index (Ctyp);
while Present (Index) loop
Get_Index_Bounds (Index, Low, High);
Expr := Expression (First (Component_Associations (Expr)));
end loop;
+ if Has_Atomic_Components (Ctyp) then
+ return False;
+ end if;
+
+ Csiz := Component_Size (Ctyp);
Ctyp := Component_Type (Ctyp);
if Is_Atomic_Or_VFA (Ctyp) then
return False;
end if;
- -- All elementary types are supported except for fat pointers
- -- because they are not really elementary for the backend.
+ -- Access types need to be dealt with specially
- if not Is_Elementary_Type (Ctyp)
- or else (Is_Access_Type (Ctyp)
- and then Esize (Ctyp) /= System_Address_Size)
- then
- return False;
- end if;
+ if Is_Access_Type (Ctyp) then
- -- The expression needs to be analyzed if True is returned
+ -- Component_Size is not set by Layout_Type if the component
+ -- type is an access type ???
- Analyze_And_Resolve (Expr, Ctyp);
+ Csiz := Esize (Ctyp);
- -- The back end uses the Esize as the precision of the type
+ -- Fat pointers are rejected as they are not really elementary
+ -- for the backend.
- Nunits := UI_To_Int (Esize (Ctyp)) / System_Storage_Unit;
+ if Csiz /= System_Address_Size then
+ return False;
+ end if;
- if Nunits = 1 then
- return True;
- end if;
+ -- The supported expressions are NULL and constants, others are
+ -- rejected upfront to avoid being analyzed below, which can be
+ -- problematic for some of them, for example allocators.
- if not Compile_Time_Known_Value (Expr) then
+ if Nkind (Expr) /= N_Null and then not Is_Entity_Name (Expr) then
+ return False;
+ end if;
+
+ -- Scalar types are OK if their size is a multiple of Storage_Unit
+
+ elsif Is_Scalar_Type (Ctyp) then
+ pragma Assert (Csiz /= No_Uint);
+
+ if Csiz mod System_Storage_Unit /= 0 then
+ return False;
+ end if;
+
+ -- Composite types are rejected
+
+ else
+ return False;
+ end if;
+
+ -- If the expression has side effects (e.g. contains calls with
+ -- potential side effects) reject as well. We only preanalyze the
+ -- expression to prevent the removal of intended side effects.
+
+ Preanalyze_And_Resolve (Expr, Ctyp);
+
+ if not Side_Effect_Free (Expr) then
+ return False;
+ end if;
+
+ -- The expression needs to be analyzed if True is returned
+
+ Analyze_And_Resolve (Expr, Ctyp);
+
+ -- Strip away any conversions from the expression as they simply
+ -- qualify the real expression.
+
+ while Nkind_In (Expr, N_Unchecked_Type_Conversion,
+ N_Type_Conversion)
+ loop
+ Expr := Expression (Expr);
+ end loop;
+
+ Nunits := UI_To_Int (Csiz) / System_Storage_Unit;
+
+ if Nunits = 1 then
+ return True;
+ end if;
+
+ if not Compile_Time_Known_Value (Expr) then
return False;
end if;
return Expr_Value_R (Expr) = Ureal_0;
end if;
- -- For other types, we can look into the value as an integer
+ -- For other types, we can look into the value as an integer, which
+ -- means the representation value for enumeration literals.
- Value := Expr_Value (Expr);
+ Value := Expr_Rep_Value (Expr);
if Has_Biased_Representation (Ctyp) then
Value := Value - Expr_Value (Type_Low_Bound (Ctyp));
end if;
end Compute_Others_Present;
- ------------------------
- -- In_Place_Assign_OK --
- ------------------------
-
- function In_Place_Assign_OK return Boolean is
- Aggr_In : Node_Id;
- Aggr_Lo : Node_Id;
- Aggr_Hi : Node_Id;
- Obj_In : Node_Id;
- Obj_Lo : Node_Id;
- Obj_Hi : Node_Id;
-
- function Safe_Aggregate (Aggr : Node_Id) return Boolean;
- -- Check recursively that each component of a (sub)aggregate does not
- -- depend on the variable being assigned to.
-
- function Safe_Component (Expr : Node_Id) return Boolean;
- -- Verify that an expression cannot depend on the variable being
- -- assigned to. Room for improvement here (but less than before).
-
- --------------------
- -- Safe_Aggregate --
- --------------------
-
- function Safe_Aggregate (Aggr : Node_Id) return Boolean is
- Expr : Node_Id;
-
- begin
- if Present (Expressions (Aggr)) then
- Expr := First (Expressions (Aggr));
- while Present (Expr) loop
- if Nkind (Expr) = N_Aggregate then
- if not Safe_Aggregate (Expr) then
- return False;
- end if;
-
- elsif not Safe_Component (Expr) then
- return False;
- end if;
-
- Next (Expr);
- end loop;
- end if;
-
- if Present (Component_Associations (Aggr)) then
- Expr := First (Component_Associations (Aggr));
- while Present (Expr) loop
- if Nkind (Expression (Expr)) = N_Aggregate then
- if not Safe_Aggregate (Expression (Expr)) then
- return False;
- end if;
-
- -- If association has a box, no way to determine yet
- -- whether default can be assigned in place.
-
- elsif Box_Present (Expr) then
- return False;
-
- elsif not Safe_Component (Expression (Expr)) then
- return False;
- end if;
-
- Next (Expr);
- end loop;
- end if;
-
- return True;
- end Safe_Aggregate;
-
- --------------------
- -- Safe_Component --
- --------------------
-
- function Safe_Component (Expr : Node_Id) return Boolean is
- Comp : Node_Id := Expr;
-
- function Check_Component (Comp : Node_Id) return Boolean;
- -- Do the recursive traversal, after copy
-
- ---------------------
- -- Check_Component --
- ---------------------
-
- function Check_Component (Comp : Node_Id) return Boolean is
- begin
- if Is_Overloaded (Comp) then
- return False;
- end if;
-
- return Compile_Time_Known_Value (Comp)
-
- or else (Is_Entity_Name (Comp)
- and then Present (Entity (Comp))
- and then No (Renamed_Object (Entity (Comp))))
-
- or else (Nkind (Comp) = N_Attribute_Reference
- and then Check_Component (Prefix (Comp)))
-
- or else (Nkind (Comp) in N_Binary_Op
- and then Check_Component (Left_Opnd (Comp))
- and then Check_Component (Right_Opnd (Comp)))
-
- or else (Nkind (Comp) in N_Unary_Op
- and then Check_Component (Right_Opnd (Comp)))
-
- or else (Nkind (Comp) = N_Selected_Component
- and then Check_Component (Prefix (Comp)))
-
- or else (Nkind (Comp) = N_Unchecked_Type_Conversion
- and then Check_Component (Expression (Comp)));
- end Check_Component;
-
- -- Start of processing for Safe_Component
-
- begin
- -- If the component appears in an association that may correspond
- -- to more than one element, it is not analyzed before expansion
- -- into assignments, to avoid side effects. We analyze, but do not
- -- resolve the copy, to obtain sufficient entity information for
- -- the checks that follow. If component is overloaded we assume
- -- an unsafe function call.
-
- if not Analyzed (Comp) then
- if Is_Overloaded (Expr) then
- return False;
-
- elsif Nkind (Expr) = N_Aggregate
- and then not Is_Others_Aggregate (Expr)
- then
- return False;
-
- elsif Nkind (Expr) = N_Allocator then
-
- -- For now, too complex to analyze
-
- return False;
- end if;
-
- Comp := New_Copy_Tree (Expr);
- Set_Parent (Comp, Parent (Expr));
- Analyze (Comp);
- end if;
-
- if Nkind (Comp) = N_Aggregate then
- return Safe_Aggregate (Comp);
- else
- return Check_Component (Comp);
- end if;
- end Safe_Component;
-
- -- Start of processing for In_Place_Assign_OK
-
- begin
- if Present (Component_Associations (N)) then
-
- -- On assignment, sliding can take place, so we cannot do the
- -- assignment in place unless the bounds of the aggregate are
- -- statically equal to those of the target.
-
- -- If the aggregate is given by an others choice, the bounds are
- -- derived from the left-hand side, and the assignment is safe if
- -- the expression is.
-
- if Is_Others_Aggregate (N) then
- return
- Safe_Component
- (Expression (First (Component_Associations (N))));
- end if;
-
- Aggr_In := First_Index (Etype (N));
-
- if Nkind (Parent (N)) = N_Assignment_Statement then
- Obj_In := First_Index (Etype (Name (Parent (N))));
-
- else
- -- Context is an allocator. Check bounds of aggregate against
- -- given type in qualified expression.
-
- pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator);
- Obj_In :=
- First_Index (Etype (Entity (Subtype_Mark (Parent (N)))));
- end if;
-
- while Present (Aggr_In) loop
- Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi);
- Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
-
- if not Compile_Time_Known_Value (Aggr_Lo)
- or else not Compile_Time_Known_Value (Aggr_Hi)
- or else not Compile_Time_Known_Value (Obj_Lo)
- or else not Compile_Time_Known_Value (Obj_Hi)
- or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
- or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
- then
- return False;
- end if;
-
- Next_Index (Aggr_In);
- Next_Index (Obj_In);
- end loop;
- end if;
-
- -- Now check the component values themselves
-
- return Safe_Aggregate (N);
- end In_Place_Assign_OK;
-
------------------
-- Others_Check --
------------------
-- raise Constraint_Error;
-- end if;
+ -- in the general case, but the following simpler test:
+
+ -- [constraint_error when
+ -- Aggr_Lo + (Nb_Elements - 1) > Aggr_Hi];
+
+ -- instead if the index type is a signed integer.
+
elsif Nb_Elements > Uint_0 then
- Cond :=
- Make_Op_Gt (Loc,
- Left_Opnd =>
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ind_Typ, Loc),
- Attribute_Name => Name_Pos,
- Expressions =>
- New_List
- (Duplicate_Subexpr_Move_Checks (Aggr_Lo))),
- Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
+ if Nb_Elements = Uint_1 then
+ Cond :=
+ Make_Op_Gt (Loc,
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi));
+
+ elsif Is_Signed_Integer_Type (Ind_Typ) then
+ Cond :=
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Nb_Elements - 1)),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi));
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ind_Typ, Loc),
- Attribute_Name => Name_Pos,
- Expressions => New_List (
- Duplicate_Subexpr_Move_Checks (Aggr_Hi))));
+ else
+ Cond :=
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ind_Typ, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions =>
+ New_List
+ (Duplicate_Subexpr_Move_Checks (Aggr_Lo))),
+ Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
+
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ind_Typ, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (
+ Duplicate_Subexpr_Move_Checks (Aggr_Hi))));
+ end if;
-- If we are dealing with an aggregate containing an others choice
-- and discrete choices we generate the following test:
-- that Convert_To_Positional succeeded and reanalyzed the rewritten
-- aggregate.
- elsif Analyzed (N) and then N /= Original_Node (N) then
+ elsif Analyzed (N) and then Is_Rewrite_Substitution (N) then
return;
end if;
or else (Parent_Kind = N_Assignment_Statement
and then Inside_Init_Proc)
then
- if Static_Array_Aggregate (N)
- or else Compile_Time_Known_Aggregate (N)
- then
- Set_Expansion_Delayed (N, False);
- return;
- else
- Set_Expansion_Delayed (N);
- return;
- end if;
+ Set_Expansion_Delayed (N, not Static_Array_Aggregate (N));
+ return;
end if;
-- STEP 4
- -- Look if in place aggregate expansion is possible
+ -- Check whether in-place aggregate expansion is possible
-- For object declarations we build the aggregate in place, unless
- -- the array is bit-packed or the component is controlled.
+ -- the array is bit-packed.
-- For assignments we do the assignment in place if all the component
- -- associations have compile-time known values. For other cases we
+ -- associations have compile-time known values, or are default-
+ -- initialized limited components, e.g. tasks. For other cases we
-- create a temporary. The analysis for safety of on-line assignment
-- is delicate, i.e. we don't know how to do it fully yet ???
-- for default initialization, e.g. with Initialize_Scalars.
if Requires_Transient_Scope (Typ) then
- Establish_Transient_Scope
- (N, Sec_Stack => Has_Controlled_Component (Typ));
+ Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
- if Has_Default_Init_Comps (N) then
+ -- An array of limited components is built in place
+
+ if Is_Limited_Type (Typ) then
+ Maybe_In_Place_OK := True;
+
+ elsif Has_Default_Init_Comps (N) then
Maybe_In_Place_OK := False;
elsif Is_Bit_Packed_Array (Typ)
else
Maybe_In_Place_OK :=
(Nkind (Parent (N)) = N_Assignment_Statement
- and then In_Place_Assign_OK)
+ and then In_Place_Assign_OK (N))
or else
(Nkind (Parent (Parent (N))) = N_Allocator
- and then In_Place_Assign_OK);
+ and then In_Place_Assign_OK (N));
end if;
-- If this is an array of tasks, it will be expanded into build-in-place
-- expected to appear in qualified form. In-place expansion eliminates
-- the qualification and eventually violates this SPARK 05 restiction.
- -- Should document the rest of the guards ???
+ -- Arrays of limited components must be built in place. The code
+ -- previously excluded controlled components but this is an old
+ -- oversight: the rules in 7.6 (17) are clear.
- if not Has_Default_Init_Comps (N)
- and then Comes_From_Source (Parent_Node)
+ if Comes_From_Source (Parent_Node)
and then Parent_Kind = N_Object_Declaration
and then Present (Expression (Parent_Node))
and then not
Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ)
- and then not Has_Controlled_Component (Typ)
and then not Is_Bit_Packed_Array (Typ)
and then not Restriction_Check_Required (SPARK_05)
then
Set_Expansion_Delayed (N);
return;
+ -- Limited arrays in return statements are expanded when
+ -- enclosing construct is expanded.
+
+ elsif Maybe_In_Place_OK
+ and then Nkind (Parent (N)) = N_Simple_Return_Statement
+ then
+ Set_Expansion_Delayed (N);
+ return;
+
-- In the remaining cases the aggregate is the RHS of an assignment
elsif Maybe_In_Place_OK
-- Step 5
- -- In place aggregate expansion is not possible
+ -- In-place aggregate expansion is not possible
else
Maybe_In_Place_OK := False;
Defining_Identifier => Tmp,
Object_Definition => New_Occurrence_Of (Typ, Loc));
Set_No_Initialization (Tmp_Decl, True);
+ Set_Warnings_Off (Tmp);
-- If we are within a loop, the temporary will be pushed on the
- -- stack at each iteration. If the aggregate is the expression for an
- -- allocator, it will be immediately copied to the heap and can
- -- be reclaimed at once. We create a transient scope around the
- -- aggregate for this purpose.
+ -- stack at each iteration. If the aggregate is the expression
+ -- for an allocator, it will be immediately copied to the heap
+ -- and can be reclaimed at once. We create a transient scope
+ -- around the aggregate for this purpose.
if Ekind (Current_Scope) = E_Loop
and then Nkind (Parent (Parent (N))) = N_Allocator
then
- Establish_Transient_Scope (N, False);
+ Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
Insert_Action (N, Tmp_Decl);
Target := New_Occurrence_Of (Tmp, Loc);
else
- if Has_Default_Init_Comps (N) then
-
+ if Has_Default_Init_Comps (N)
+ and then not Maybe_In_Place_OK
+ then
-- Ada 2005 (AI-287): This case has not been analyzed???
raise Program_Error;
Target := New_Copy (Tmp);
end if;
- -- If we are to generate an in place assignment for a declaration or
+ -- If we are to generate an in-place assignment for a declaration or
-- an assignment statement, and the assignment can be done directly
-- by the back end, then do not expand further.
- -- ??? We can also do that if in place expansion is not possible but
+ -- ??? We can also do that if in-place expansion is not possible but
-- then we could go into an infinite recursion.
if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK)
-- If the ancestor part is an expression, add a component association for
-- the parent field. If the type of the ancestor part is not the direct
- -- parent of the expected type, build recursively the needed ancestors.
- -- If the ancestor part is a subtype_mark, replace aggregate with a decla-
- -- ration for a temporary of the expected type, followed by individual
- -- assignments to the given components.
+ -- parent of the expected type, build recursively the needed ancestors.
+ -- If the ancestor part is a subtype_mark, replace aggregate with a
+ -- declaration for a temporary of the expected type, followed by
+ -- individual assignments to the given components.
procedure Expand_N_Extension_Aggregate (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
A : constant Node_Id := Ancestor_Part (N);
+ Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
begin
Static_Components : Boolean := True;
-- Flag to indicate whether all components are compile-time known,
-- and the aggregate can be constructed statically and handled by
- -- the back-end.
+ -- the back-end. Set to False by Component_OK_For_Backend.
procedure Build_Back_End_Aggregate;
-- Build a proper aggregate to be handled by the back-end
-- This returns true for N_Aggregate with Compile_Time_Known_Aggregate
-- set and constants whose expression is such an aggregate, recursively.
- function Component_Not_OK_For_Backend return Boolean;
+ function Component_OK_For_Backend return Boolean;
-- Check for presence of a component which makes it impossible for the
-- backend to process the aggregate, thus requiring the use of a series
-- of assignment statements. Cases checked for are a nested aggregate
-- in order to minimize elaboration code. This is one case where the
-- semantics of Ada complicate the analysis and lead to anomalies in
-- the gcc back-end if the aggregate is not expanded into assignments.
+ --
+ -- NOTE: This sets the global Static_Components to False in most, but
+ -- not all, cases when it returns False.
function Has_Per_Object_Constraint (L : List_Id) return Boolean;
-- Return True if any element of L has Has_Per_Object_Constraint set.
Comp := First_Component (Typ);
while Chars (Comp) /= Name_uParent loop
- Comp := Next_Component (Comp);
+ Next_Component (Comp);
end loop;
Parent_Name := New_Occurrence_Of (Comp, Loc);
-- The ancestor part may be a nested aggregate that has
-- delayed expansion: recheck now.
- if Component_Not_OK_For_Backend then
+ if not Component_OK_For_Backend then
Convert_To_Assignments (N, Typ);
end if;
end;
end Compile_Time_Known_Composite_Value;
- ----------------------------------
- -- Component_Not_OK_For_Backend --
- ----------------------------------
+ ------------------------------
+ -- Component_OK_For_Backend --
+ ------------------------------
- function Component_Not_OK_For_Backend return Boolean is
+ function Component_OK_For_Backend return Boolean is
C : Node_Id;
Expr_Q : Node_Id;
begin
if No (Comps) then
- return False;
+ return True;
end if;
C := First (Comps);
-- and component is not ready for backend.
if Box_Present (C) then
- return True;
+ return False;
end if;
if Nkind (Expression (C)) = N_Qualified_Expression then
Expr_Q := Expression (C);
end if;
- -- Return true if the aggregate has any associations for tagged
+ -- Return False for array components whose bounds raise
+ -- constraint error.
+
+ declare
+ Comp : constant Entity_Id := First (Choices (C));
+ Indx : Node_Id;
+
+ begin
+ if Present (Etype (Comp))
+ and then Is_Array_Type (Etype (Comp))
+ then
+ Indx := First_Index (Etype (Comp));
+ while Present (Indx) loop
+ if Nkind (Type_Low_Bound (Etype (Indx))) =
+ N_Raise_Constraint_Error
+ or else Nkind (Type_High_Bound (Etype (Indx))) =
+ N_Raise_Constraint_Error
+ then
+ return False;
+ end if;
+
+ Next_Index (Indx);
+ end loop;
+ end if;
+ end;
+
+ -- Return False if the aggregate has any associations for tagged
-- components that may require tag adjustment.
-- These are cases where the source expression may have a tag that
-- the machine.)
if Is_Tagged_Type (Etype (Expr_Q))
- and then (Nkind (Expr_Q) = N_Type_Conversion
- or else (Is_Entity_Name (Expr_Q)
- and then
- Ekind (Entity (Expr_Q)) in Formal_Kind))
+ and then
+ (Nkind (Expr_Q) = N_Type_Conversion
+ or else
+ (Is_Entity_Name (Expr_Q)
+ and then Is_Formal (Entity (Expr_Q))))
and then Tagged_Type_Expansion
then
Static_Components := False;
- return True;
+ return False;
elsif Is_Delayed_Aggregate (Expr_Q) then
Static_Components := False;
- return True;
+ return False;
+
+ elsif Nkind (Expr_Q) = N_Quantified_Expression then
+ Static_Components := False;
+ return False;
elsif Possible_Bit_Aligned_Component (Expr_Q) then
Static_Components := False;
- return True;
+ return False;
elsif Modify_Tree_For_C
and then Nkind (C) = N_Component_Association
and then Has_Per_Object_Constraint (Choices (C))
then
Static_Components := False;
- return True;
+ return False;
elsif Modify_Tree_For_C
and then Nkind (Expr_Q) = N_Identifier
and then Is_Array_Type (Etype (Expr_Q))
then
Static_Components := False;
- return True;
+ return False;
elsif Modify_Tree_For_C
and then Nkind (Expr_Q) = N_Type_Conversion
and then Is_Array_Type (Etype (Expr_Q))
then
Static_Components := False;
- return True;
+ return False;
end if;
if Is_Elementary_Type (Etype (Expr_Q)) then
if Is_Private_Type (Etype (Expr_Q))
and then Has_Discriminants (Etype (Expr_Q))
then
- return True;
+ return False;
end if;
end if;
Next (C);
end loop;
- return False;
- end Component_Not_OK_For_Backend;
+ return True;
+ end Component_OK_For_Backend;
-------------------------------
-- Has_Per_Object_Constraint --
return;
end if;
+ -- If the pragma Aggregate_Individually_Assign is set, always convert to
+ -- assignments.
+
+ if Aggregate_Individually_Assign then
+ Convert_To_Assignments (N, Typ);
+
-- Ada 2005 (AI-318-2): We need to convert to assignments if components
-- are build-in-place function calls. The assignments will each turn
-- into a build-in-place function call. If components are all static,
- -- we can pass the aggregate to the backend regardless of limitedness.
+ -- we can pass the aggregate to the back end regardless of limitedness.
-- Extension aggregates, aggregates in extended return statements, and
-- aggregates for C++ imported types must be expanded.
- if Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then
+ elsif Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then
if not Nkind_In (Parent (N), N_Component_Association,
N_Object_Declaration)
then
Convert_To_Assignments (N, Typ);
elsif not Size_Known_At_Compile_Time (Typ)
- or else Component_Not_OK_For_Backend
+ or else not Component_OK_For_Backend
or else not Static_Components
then
Convert_To_Assignments (N, Typ);
-- Check components
- elsif Component_Not_OK_For_Backend then
+ elsif not Component_OK_For_Backend then
Convert_To_Assignments (N, Typ);
-- If an ancestor is private, some components are not inherited and we
-- When generating C, only generate an aggregate when declaring objects
-- since C does not support aggregates in e.g. assignment statements.
- elsif Modify_Tree_For_C and then not In_Object_Declaration (N) then
+ elsif Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then
Convert_To_Assignments (N, Typ);
-- In all other cases, build a proper aggregate to be handled by gigi
return False;
end Has_Default_Init_Comps;
+ ----------------------------------------
+ -- Is_Build_In_Place_Aggregate_Return --
+ ----------------------------------------
+
+ function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean is
+ P : Node_Id := Parent (N);
+
+ begin
+ while Nkind (P) = N_Qualified_Expression loop
+ P := Parent (P);
+ end loop;
+
+ if Nkind (P) = N_Simple_Return_Statement then
+ null;
+
+ elsif Nkind (Parent (P)) = N_Extended_Return_Statement then
+ P := Parent (P);
+
+ else
+ return False;
+ end if;
+
+ return
+ Is_Build_In_Place_Function
+ (Return_Applies_To (Return_Statement_Entity (P)));
+ end Is_Build_In_Place_Aggregate_Return;
+
--------------------------
-- Is_Delayed_Aggregate --
--------------------------
end if;
end Is_Delayed_Aggregate;
- ---------------------------
- -- In_Object_Declaration --
- ---------------------------
+ --------------------------------
+ -- Is_CCG_Supported_Aggregate --
+ --------------------------------
- function In_Object_Declaration (N : Node_Id) return Boolean is
+ function Is_CCG_Supported_Aggregate
+ (N : Node_Id) return Boolean
+ is
P : Node_Id := Parent (N);
+
begin
- while Present (P) loop
- if Nkind (P) = N_Object_Declaration then
- return True;
- end if;
+ -- Aggregates are not supported for nonstandard rep clauses, since they
+ -- may lead to extra padding fields in CCG.
+ if Ekind (Etype (N)) in Record_Kind
+ and then Has_Non_Standard_Rep (Etype (N))
+ then
+ return False;
+ end if;
+
+ while Present (P) and then Nkind (P) = N_Aggregate loop
P := Parent (P);
end loop;
+ -- Check cases where aggregates are supported by the CCG backend
+
+ if Nkind (P) = N_Object_Declaration then
+ declare
+ P_Typ : constant Entity_Id := Etype (Defining_Identifier (P));
+
+ begin
+ if Is_Record_Type (P_Typ) then
+ return True;
+ else
+ return Compile_Time_Known_Bounds (P_Typ);
+ end if;
+ end;
+
+ elsif Nkind (P) = N_Qualified_Expression then
+ if Nkind (Parent (P)) = N_Object_Declaration then
+ declare
+ P_Typ : constant Entity_Id :=
+ Etype (Defining_Identifier (Parent (P)));
+ begin
+ if Is_Record_Type (P_Typ) then
+ return True;
+ else
+ return Compile_Time_Known_Bounds (P_Typ);
+ end if;
+ end;
+
+ elsif Nkind (Parent (P)) = N_Allocator then
+ return True;
+ end if;
+ end if;
+
return False;
- end In_Object_Declaration;
+ end Is_CCG_Supported_Aggregate;
----------------------------------------
-- Is_Static_Dispatch_Table_Aggregate --
Typ : constant Entity_Id := Base_Type (Etype (N));
begin
- return Static_Dispatch_Tables
+ return Building_Static_Dispatch_Tables
and then Tagged_Type_Expansion
and then RTU_Loaded (Ada_Tags)
return False;
end if;
- if not Is_Scalar_Type (Component_Type (Typ))
- and then Has_Non_Standard_Rep (Component_Type (Typ))
- then
+ if not Is_Scalar_Type (Ctyp) then
return False;
end if;
function Get_Component_Val (N : Node_Id) return Uint;
-- Given a expression value N of the component type Ctyp, returns a
-- value of Csiz (component size) bits representing this value. If
- -- the value is non-static or any other reason exists why the value
+ -- the value is nonstatic or any other reason exists why the value
-- cannot be returned, then Not_Handled is raised.
-----------------------
function Has_Mutable_Components (Typ : Entity_Id) return Boolean is
Comp : Entity_Id;
+ Ctyp : Entity_Id;
begin
Comp := First_Component (Typ);
while Present (Comp) loop
- if Is_Record_Type (Etype (Comp))
- and then Has_Discriminants (Etype (Comp))
- and then not Is_Constrained (Etype (Comp))
+ Ctyp := Underlying_Type (Etype (Comp));
+ if Is_Record_Type (Ctyp)
+ and then Has_Discriminants (Ctyp)
+ and then not Is_Constrained (Ctyp)
then
return True;
end if;
----------------------------
function Static_Array_Aggregate (N : Node_Id) return Boolean is
- Bounds : constant Node_Id := Aggregate_Bounds (N);
+ function Is_Static_Component (Nod : Node_Id) return Boolean;
+ -- Return True if Nod has a compile-time known value and can be passed
+ -- as is to the back-end without further expansion.
+
+ ---------------------------
+ -- Is_Static_Component --
+ ---------------------------
+
+ function Is_Static_Component (Nod : Node_Id) return Boolean is
+ begin
+ if Nkind_In (Nod, N_Integer_Literal, N_Real_Literal) then
+ return True;
- Typ : constant Entity_Id := Etype (N);
- Comp_Type : constant Entity_Id := Component_Type (Typ);
- Agg : Node_Id;
- Expr : Node_Id;
- Lo : Node_Id;
- Hi : Node_Id;
+ elsif Is_Entity_Name (Nod)
+ and then Present (Entity (Nod))
+ and then Ekind (Entity (Nod)) = E_Enumeration_Literal
+ then
+ return True;
+
+ elsif Nkind (Nod) = N_Aggregate
+ and then Compile_Time_Known_Aggregate (Nod)
+ then
+ return True;
+
+ else
+ return False;
+ end if;
+ end Is_Static_Component;
+
+ -- Local variables
+
+ Bounds : constant Node_Id := Aggregate_Bounds (N);
+ Typ : constant Entity_Id := Etype (N);
+
+ Agg : Node_Id;
+ Expr : Node_Id;
+ Lo : Node_Id;
+ Hi : Node_Id;
+
+ -- Start of processing for Static_Array_Aggregate
begin
- if Is_Tagged_Type (Typ)
- or else Is_Controlled (Typ)
- or else Is_Packed (Typ)
- then
+ if Is_Packed (Typ) or else Has_Discriminants (Component_Type (Typ)) then
return False;
end if;
if No (Component_Associations (N)) then
- -- Verify that all components are static integers
+ -- Verify that all components are static
Expr := First (Expressions (N));
while Present (Expr) loop
- if Nkind (Expr) /= N_Integer_Literal then
+ if not Is_Static_Component (Expr) then
return False;
end if;
-- component type. We also limit the size of a static aggregate
-- to prevent runaway static expressions.
- if Is_Array_Type (Comp_Type)
- or else Is_Record_Type (Comp_Type)
- then
- if Nkind (Expression (Expr)) /= N_Aggregate
- or else
- not Compile_Time_Known_Aggregate (Expression (Expr))
- then
- return False;
- end if;
-
- elsif Nkind (Expression (Expr)) /= N_Integer_Literal then
+ if not Is_Static_Component (Expression (Expr)) then
return False;
end if;
Val := 0;
Packed_Num := 0;
- -- Account for endianness. See corresponding comment in
+ -- Account for endianness. See corresponding comment in
-- Packed_Array_Aggregate_Handled concerning the following.
if Bytes_Big_Endian
Comp_Val := Comp_Val mod Uint_2 ** Comp_Size;
Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift);
Shift := Shift + Incr;
- One_Comp := Next (One_Comp);
+ Next (One_Comp);
Packed_Num := Packed_Num + 1;
end if;
end loop;
- One_Dim := Next (One_Dim);
+ Next (One_Dim);
end loop;
if Packed_Num > 0 then
git://gcc.gnu.org / gcc.git / blobdiff