-- 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.
-- 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
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_Unchecked_Type_Conversion,
+ N_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 --
----------------------------
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" semantic. 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));
- -- Generating C, do not declare a temporary to initialize an aggregate
- -- assigned to Out or In_Out parameters whose type has no discriminants.
- -- This avoids stack overflow errors at run time.
+ -- 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 Modify_Tree_For_C
- and then Nkind (Parent (N)) = N_Assignment_Statement
+ elsif Nkind (Parent (N)) = N_Assignment_Statement
and then Nkind (Name (Parent (N))) = N_Identifier
- and then Ekind_In (Entity (Name (Parent (N))), E_Out_Parameter,
- E_In_Out_Parameter)
- and then not Has_Discriminants (Etype (Entity (Name (Parent (N)))))
+ and then In_Place_Assign_OK (N)
then
Target_Expr := New_Copy_Tree (Name (Parent (N)));
Insert_Actions (Parent (N),
-- 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.
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 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 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_In (Comp, N_Unchecked_Type_Conversion,
- N_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
- 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 (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;
-
------------------
-- Others_Check --
------------------
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
function Is_CCG_Supported_Aggregate
(N : Node_Id) return Boolean
is
- In_Obj_Decl : Boolean := False;
- P : Node_Id := Parent (N);
+ P : Node_Id := Parent (N);
begin
- while Present (P) loop
- if Nkind (P) = N_Object_Declaration then
- In_Obj_Decl := True;
- end if;
+ -- Aggregates are not supported for non standard 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;
-- Cases where aggregates are supported by the CCG backend
- if In_Obj_Decl then
- if Nkind (Parent (N)) = N_Object_Declaration then
- return True;
+ if Nkind (P) = N_Object_Declaration then
+ return True;
- elsif Nkind (Parent (N)) = N_Qualified_Expression
- and then Nkind_In (Parent (Parent (N)), N_Allocator,
- N_Object_Declaration)
- then
- return True;
- end if;
+ elsif Nkind (P) = N_Qualified_Expression
+ and then Nkind_In (Parent (P), N_Allocator, N_Object_Declaration)
+ then
+ return True;
end if;
return False;
projects / gcc.git / commitdiff