@@ -62,7 +62,7 @@ with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
-use Sem_Util.Storage_Model_Support;
+ use Sem_Util.Storage_Model_Support;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
@@ -78,12 +78,10 @@ package body Exp_Aggr is
function Build_Assignment_With_Temporary
(Target : Node_Id;
- Typ : Node_Id;
+ Typ : Entity_Id;
Source : Node_Id) return List_Id;
-- Returns a list of actions to assign Source to Target of type Typ using
- -- an extra temporary:
- -- Tmp := Source;
- -- Target := Tmp;
+ -- an extra temporary, which can potentially be large.
type Case_Bounds is record
Choice_Lo : Node_Id;
@@ -2524,33 +2522,33 @@ package body Exp_Aggr is
function Build_Assignment_With_Temporary
(Target : Node_Id;
- Typ : Node_Id;
+ Typ : Entity_Id;
Source : Node_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Source);
Aggr_Code : List_Id;
Tmp : Entity_Id;
- Tmp_Decl : Node_Id;
begin
- Tmp := Make_Temporary (Loc, 'A', Source);
- Tmp_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Tmp,
- Object_Definition => New_Occurrence_Of (Typ, Loc));
- Set_No_Initialization (Tmp_Decl, True);
+ Aggr_Code := New_List;
+
+ Tmp := Build_Temporary_On_Secondary_Stack (Loc, Typ, Aggr_Code);
- Aggr_Code := New_List (Tmp_Decl);
Append_To (Aggr_Code,
Make_OK_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Tmp, Loc),
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Tmp, Loc)),
Expression => Source));
Append_To (Aggr_Code,
Make_OK_Assignment_Statement (Loc,
Name => Target,
- Expression => New_Occurrence_Of (Tmp, Loc)));
+ Expression =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Tmp, Loc))));
+
return Aggr_Code;
end Build_Assignment_With_Temporary;
@@ -4571,8 +4569,9 @@ package body Exp_Aggr is
(Storage_Model_Object
(Etype (Prefix (Expression (Target))))))
then
- Aggr_Code := Build_Assignment_With_Temporary (Target,
- Typ, New_Aggr);
+ Aggr_Code :=
+ Build_Assignment_With_Temporary (Target, Typ, New_Aggr);
+
else
Aggr_Code :=
New_List (
@@ -7139,20 +7138,20 @@ package body Exp_Aggr is
(Storage_Model_Object
(Etype (Prefix (Name (Parent_Node))))))
then
- Aggr_Code := Build_Assignment_With_Temporary (Target,
- Typ, New_Copy_Tree (N));
+ Aggr_Code := Build_Assignment_With_Temporary
+ (Target, Typ, New_Copy_Tree (N));
+
else
if Maybe_In_Place_OK then
return;
end if;
- Aggr_Code :=
- New_List (
- Make_Assignment_Statement (Loc,
- Name => Target,
- Expression => New_Copy_Tree (N)));
-
+ Aggr_Code := New_List (
+ Make_Assignment_Statement (Loc,
+ Name => Target,
+ Expression => New_Copy_Tree (N)));
end if;
+
else
Aggr_Code :=
Build_Array_Aggr_Code (N,
@@ -5066,13 +5066,12 @@ package body Exp_Ch4 is
-- Add discriminants if discriminated type
declare
- Dis : Boolean := False;
- Typ : Entity_Id := Empty;
+ Dis : Boolean := False;
+ Typ : Entity_Id := T;
begin
if Has_Discriminants (T) then
Dis := True;
- Typ := T;
-- Type may be a private type with no visible discriminants
-- in which case check full view if in scope, or the
@@ -5115,30 +5114,6 @@ package body Exp_Ch4 is
Set_Expression (N, New_Occurrence_Of (Typ, Loc));
end if;
- -- When the designated subtype is unconstrained and
- -- the allocator specifies a constrained subtype (or
- -- such a subtype has been created, such as above by
- -- Build_Default_Subtype), associate that subtype with
- -- the dereference of the allocator's access value.
- -- This is needed by the back end for cases where
- -- the access type has a Designated_Storage_Model,
- -- to support allocation of a host object of the right
- -- size for passing to the initialization procedure.
-
- if not Is_Constrained (Dtyp)
- and then Is_Constrained (Typ)
- then
- declare
- Init_Deref : constant Node_Id :=
- Unqual_Conv (Init_Arg1);
- begin
- pragma Assert
- (Nkind (Init_Deref) = N_Explicit_Dereference);
-
- Set_Actual_Designated_Subtype (Init_Deref, Typ);
- end;
- end if;
-
Discr := First_Elmt (Discriminant_Constraint (Typ));
while Present (Discr) loop
Nod := Node (Discr);
@@ -5161,6 +5136,29 @@ package body Exp_Ch4 is
Next_Elmt (Discr);
end loop;
end if;
+
+ -- When the designated subtype is unconstrained and
+ -- the allocator specifies a constrained subtype (or
+ -- such a subtype has been created, such as above by
+ -- Build_Default_Subtype), associate that subtype with
+ -- the dereference of the allocator's access value.
+ -- This is needed by the expander for cases where the
+ -- access type has a Designated_Storage_Model in order
+ -- to support allocation of a host object of the right
+ -- size for passing to the initialization procedure.
+
+ if not Is_Constrained (Dtyp)
+ and then Is_Constrained (Typ)
+ then
+ declare
+ Deref : constant Node_Id := Unqual_Conv (Init_Arg1);
+
+ begin
+ pragma Assert (Nkind (Deref) = N_Explicit_Dereference);
+
+ Set_Actual_Designated_Subtype (Deref, Typ);
+ end;
+ end if;
end;
-- We set the allocator as analyzed so that when we analyze
@@ -59,6 +59,7 @@ with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
+ use Sem_Util.Storage_Model_Support;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
@@ -2658,10 +2659,50 @@ package body Exp_Ch5 is
Convert_Aggr_In_Assignment (N);
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
-
return;
end if;
+ -- An assignment between nonnative storage models requires creating an
+ -- intermediate temporary on the host, which can potentially be large.
+
+ if Nkind (Lhs) = N_Explicit_Dereference
+ and then Has_Designated_Storage_Model_Aspect (Etype (Prefix (Lhs)))
+ and then Present (Storage_Model_Copy_To
+ (Storage_Model_Object (Etype (Prefix (Lhs)))))
+ and then Nkind (Rhs) = N_Explicit_Dereference
+ and then Has_Designated_Storage_Model_Aspect (Etype (Prefix (Rhs)))
+ and then Present (Storage_Model_Copy_From
+ (Storage_Model_Object (Etype (Prefix (Rhs)))))
+ then
+ declare
+ Assign_Code : List_Id;
+ Tmp : Entity_Id;
+
+ begin
+ Assign_Code := New_List;
+
+ Tmp := Build_Temporary_On_Secondary_Stack (Loc, Typ, Assign_Code);
+
+ Append_To (Assign_Code,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Tmp, Loc)),
+ Expression => Relocate_Node (Rhs)));
+
+ Append_To (Assign_Code,
+ Make_Assignment_Statement (Loc,
+ Name => Relocate_Node (Lhs),
+ Expression =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Tmp, Loc))));
+
+ Insert_Actions (N, Assign_Code);
+ Rewrite (N, Make_Null_Statement (Loc));
+ return;
+ end;
+ end if;
+
-- Apply discriminant check if required. If Lhs is an access type to a
-- designated type with discriminants, we must always check. If the
-- type has unknown discriminants, more elaborate processing below.
@@ -2672,7 +2713,7 @@ package body Exp_Ch5 is
-- Skip discriminant check if change of representation. Will be
-- done when the change of representation is expanded out.
- if not Crep then
+ if not Crep and then not Suppress_Assignment_Checks (N) then
Apply_Discriminant_Check (Rhs, Etype (Lhs), Lhs);
end if;
@@ -2712,7 +2753,9 @@ package body Exp_Ch5 is
Set_Etype (Lhs, Ubt);
Rewrite (Rhs, OK_Convert_To (Base_Type (Ubt), Rhs));
- Apply_Discriminant_Check (Rhs, Ubt, Lhs);
+ if not Suppress_Assignment_Checks (N) then
+ Apply_Discriminant_Check (Rhs, Ubt, Lhs);
+ end if;
Set_Etype (Lhs, Lt);
end;
@@ -2732,12 +2775,16 @@ package body Exp_Ch5 is
then
Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs));
- Apply_Discriminant_Check (Rhs, Typ, Lhs);
+ if not Suppress_Assignment_Checks (N) then
+ Apply_Discriminant_Check (Rhs, Typ, Lhs);
+ end if;
elsif Is_Array_Type (Typ) and then Is_Constrained (Typ) then
Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs));
- Apply_Length_Check (Rhs, Typ);
+ if not Suppress_Assignment_Checks (N) then
+ Apply_Length_Check (Rhs, Typ);
+ end if;
end if;
-- In the access type case, we need the same discriminant check, and
@@ -2745,6 +2792,7 @@ package body Exp_Ch5 is
elsif Is_Access_Type (Etype (Lhs))
and then Is_Constrained (Designated_Type (Etype (Lhs)))
+ and then not Suppress_Assignment_Checks (N)
then
if Has_Discriminants (Designated_Type (Etype (Lhs))) then
@@ -70,6 +70,7 @@ with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_SCIL; use Sem_SCIL;
with Sem_Util; use Sem_Util;
+ use Sem_Util.Storage_Model_Support;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
@@ -1936,8 +1937,14 @@ package body Exp_Ch6 is
----------------------------------
procedure Add_Simple_Call_By_Copy_Code (Force : Boolean) is
+ With_Storage_Model : constant Boolean :=
+ Nkind (Actual) = N_Explicit_Dereference
+ and then
+ Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual)));
+
+ Cpcod : List_Id;
Decl : Node_Id;
- F_Typ : Entity_Id := Etype (Formal);
+ F_Typ : Entity_Id;
Incod : Node_Id;
Indic : Node_Id;
Lhs : Node_Id;
@@ -1952,6 +1959,8 @@ package body Exp_Ch6 is
return;
end if;
+ F_Typ := Etype (Formal);
+
-- Handle formals whose type comes from the limited view
if From_Limited_With (F_Typ)
@@ -1960,12 +1969,21 @@ package body Exp_Ch6 is
F_Typ := Non_Limited_View (F_Typ);
end if;
+ -- Use the actual designated subtype for a dereference, if any
+
+ if Nkind (Actual) = N_Explicit_Dereference
+ and then Present (Actual_Designated_Subtype (Actual))
+ then
+ Indic :=
+ New_Occurrence_Of (Actual_Designated_Subtype (Actual), Loc);
+
-- Use formal type for temp, unless formal type is an unconstrained
-- array, in which case we don't have to worry about bounds checks,
-- and we use the actual type, since that has appropriate bounds.
- if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
+ elsif Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
Indic := New_Occurrence_Of (Etype (Actual), Loc);
+
else
Indic := New_Occurrence_Of (F_Typ, Loc);
end if;
@@ -1974,7 +1992,6 @@ package body Exp_Ch6 is
Reset_Packed_Prefix;
- Temp := Make_Temporary (Loc, 'T', Actual);
Incod := Relocate_Node (Actual);
Outcod := New_Copy_Tree (Incod);
@@ -1990,7 +2007,10 @@ package body Exp_Ch6 is
if Ekind (Formal) = E_Out_Parameter then
Incod := Empty;
- if Has_Discriminants (F_Typ) then
+ if Has_Discriminants (F_Typ)
+ and then (Nkind (Actual) /= N_Explicit_Dereference
+ or else No (Actual_Designated_Subtype (Actual)))
+ then
Indic := New_Occurrence_Of (Etype (Actual), Loc);
end if;
@@ -2017,15 +2037,31 @@ package body Exp_Ch6 is
end if;
end if;
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition => Indic,
- Expression => Incod);
+ Cpcod := New_List;
+
+ if With_Storage_Model then
+ Temp :=
+ Build_Temporary_On_Secondary_Stack (Loc, Entity (Indic), Cpcod);
+
+ if Present (Incod) then
+ Append_To (Cpcod,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Temp, Loc)),
+ Expression => Incod));
+ Set_Suppress_Assignment_Checks (Last (Cpcod));
+ end if;
+
+ else
+ Temp := Make_Temporary (Loc, 'T', Actual);
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => Indic,
+ Expression => Incod);
- if Inside_Init_Proc
- and then No (Incod)
- then
-- If the call is to initialize a component of a composite type,
-- and the component does not depend on discriminants, use the
-- actual type of the component. This is required in case the
@@ -2035,23 +2071,42 @@ package body Exp_Ch6 is
-- discriminant, the presence of the initialization in the
-- declaration will generate an expression for the actual subtype.
- Set_No_Initialization (Decl);
- Set_Object_Definition (Decl,
- New_Occurrence_Of (Etype (Actual), Loc));
+ if Inside_Init_Proc and then No (Incod) then
+ Set_No_Initialization (Decl);
+ Set_Object_Definition (Decl,
+ New_Occurrence_Of (Etype (Actual), Loc));
+ end if;
+
+ Append_To (Cpcod, Decl);
end if;
- Insert_Action (N, Decl);
+ Insert_Actions (N, Cpcod);
-- The actual is simply a reference to the temporary
- Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
+ if With_Storage_Model then
+ Rewrite (Actual,
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Temp, Loc)));
+ else
+ Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
+ end if;
+
+ Analyze (Actual);
-- Generate copy out if OUT or IN OUT parameter
if Ekind (Formal) /= E_In_Parameter then
Lhs := Outcod;
- Rhs := New_Occurrence_Of (Temp, Loc);
- Set_Is_True_Constant (Temp, False);
+
+ if With_Storage_Model then
+ Rhs :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Temp, Loc));
+ else
+ Rhs := New_Occurrence_Of (Temp, Loc);
+ Set_Is_True_Constant (Temp, False);
+ end if;
-- Deal with conversion
@@ -2064,6 +2119,7 @@ package body Exp_Ch6 is
Make_Assignment_Statement (Loc,
Name => Lhs,
Expression => Rhs));
+ Set_Suppress_Assignment_Checks (Last (Post_Call));
Set_Assignment_OK (Name (Last (Post_Call)));
end if;
end Add_Simple_Call_By_Copy_Code;
@@ -2452,6 +2508,22 @@ package body Exp_Ch6 is
elsif Is_Ref_To_Bit_Packed_Array (Actual) then
Add_Simple_Call_By_Copy_Code (Force => True);
+ -- If the actual has a nonnative storage model, we need a copy
+
+ elsif Nkind (Actual) = N_Explicit_Dereference
+ and then
+ Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual)))
+ and then
+ (Present (Storage_Model_Copy_To
+ (Storage_Model_Object (Etype (Prefix (Actual)))))
+ or else
+ (Ekind (Formal) = E_In_Out_Parameter
+ and then
+ (Present (Storage_Model_Copy_From
+ (Storage_Model_Object (Etype (Prefix (Actual))))))))
+ then
+ Add_Simple_Call_By_Copy_Code (Force => True);
+
-- If a nonscalar actual is possibly bit-aligned, we need a copy
-- because the back-end cannot cope with such objects. In other
-- cases where alignment forces a copy, the back-end generates
@@ -2598,6 +2670,17 @@ package body Exp_Ch6 is
elsif Is_Ref_To_Bit_Packed_Array (Actual) then
Add_Simple_Call_By_Copy_Code (Force => True);
+ -- If the actual has a nonnative storage model, we need a copy
+
+ elsif Nkind (Actual) = N_Explicit_Dereference
+ and then
+ Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual)))
+ and then
+ Present (Storage_Model_Copy_From
+ (Storage_Model_Object (Etype (Prefix (Actual)))))
+ then
+ Add_Simple_Call_By_Copy_Code (Force => True);
+
-- If we have a C++ constructor call, we need to create the object
elsif Is_CPP_Constructor_Call (Actual) then
@@ -4699,6 +4699,55 @@ package body Exp_Util is
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
end Build_Task_Record_Image;
+ ----------------------------------------
+ -- Build_Temporary_On_Secondary_Stack --
+ ----------------------------------------
+
+ function Build_Temporary_On_Secondary_Stack
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Code : List_Id) return Entity_Id
+ is
+ Acc_Typ : Entity_Id;
+ Alloc : Node_Id;
+ Alloc_Obj : Entity_Id;
+
+ begin
+ pragma Assert (RTE_Available (RE_SS_Pool)
+ and then not Needs_Finalization (Typ));
+
+ Acc_Typ := Make_Temporary (Loc, 'A');
+ Mutate_Ekind (Acc_Typ, E_Access_Type);
+ Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
+
+ Append_To (Code,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Acc_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Occurrence_Of (Typ, Loc))));
+
+ Alloc :=
+ Make_Allocator (Loc, Expression => New_Occurrence_Of (Typ, Loc));
+ Set_No_Initialization (Alloc);
+
+ Alloc_Obj := Make_Temporary (Loc, 'R');
+
+ Append_To (Code,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Alloc_Obj,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Acc_Typ, Loc),
+ Expression => Alloc));
+
+ Set_Uses_Sec_Stack (Current_Scope);
+
+ return Alloc_Obj;
+ end Build_Temporary_On_Secondary_Stack;
+
---------------------------------------
-- Build_Transient_Object_Statements --
---------------------------------------
@@ -351,6 +351,18 @@ package Exp_Util is
-- is false, the call is for a stand-alone object, and the generated
-- function itself must do its own cleanups.
+ function Build_Temporary_On_Secondary_Stack
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Code : List_Id) return Entity_Id;
+ -- Build a temporary of type Typ on the secondary stack, appending the
+ -- necessary actions to Code, and return a constant holding the access
+ -- value designating this temporary, under the assumption that Typ does
+ -- not need finalization.
+
+ -- This should be used when Typ can potentially be large, to avoid putting
+ -- too much pressure on the primary stack, for example with storage models.
+
procedure Build_Transient_Object_Statements
(Obj_Decl : Node_Id;
Fin_Call : out Node_Id;
@@ -324,10 +324,13 @@ package body Sem_Ch5 is
then
Opnd_Type := Get_Actual_Subtype (Opnd);
- -- If assignment operand is a component reference, then we get the
- -- actual subtype of the component for the unconstrained case.
+ -- If the assignment operand is a component reference, then we build
+ -- the actual subtype of the component for the unconstrained case,
+ -- unless there is already one or the type is an unchecked union.
- elsif Nkind (Opnd) in N_Selected_Component | N_Explicit_Dereference
+ elsif (Nkind (Opnd) = N_Selected_Component
+ or else (Nkind (Opnd) = N_Explicit_Dereference
+ and then No (Actual_Designated_Subtype (Opnd))))
and then not Is_Unchecked_Union (Opnd_Type)
then
Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
@@ -830,7 +830,7 @@ package Sinfo is
-- an unconstrained packed array and the dereference is the prefix of
-- a 'Size attribute reference, or 2) when the dereference node is
-- created for the expansion of an allocator with a subtype_indication
- -- and the designated subtype is an unconstrained discriminated type.
+ -- and the designated subtype is an unconstrained composite type.
-- Address_Warning_Posted
-- Present in N_Attribute_Definition nodes. Set to indicate that we have
@@ -2311,7 +2311,7 @@ package Sinfo is
-- can be set in N_Object_Declaration nodes, to similarly suppress any
-- checks on the initializing value. In assignment statements it also
-- suppresses access checks in the generated code for out- and in-out
- -- parameters in entry calls, as well as length checks.
+ -- parameters in entry calls, as well as discriminant and length checks.
-- Suppress_Loop_Warnings
-- Used in N_Loop_Statement node to indicate that warnings within the