@@ -1060,7 +1060,7 @@ package body Exp_Ch6 is
begin
return (No (Ctrl) and then Is_Definite_Subtype (Utyp))
- or else not Returns_On_Secondary_Stack (Utyp);
+ or else not Needs_Secondary_Stack (Utyp);
end Caller_Known_Size;
-----------------------
@@ -4946,7 +4946,7 @@ package body Exp_Ch6 is
Is_Build_In_Place_Function_Call (Parent (Call_Node)))
then
Establish_Transient_Scope
- (Call_Node, Returns_On_Secondary_Stack (Etype (Subp)));
+ (Call_Node, Needs_Secondary_Stack (Etype (Subp)));
end if;
end if;
end Expand_Call_Helper;
@@ -7341,7 +7341,7 @@ package body Exp_Ch6 is
-- A return statement from an ignored Ghost function does not use the
-- secondary stack (or any other one).
- elsif not Returns_On_Secondary_Stack (R_Type)
+ elsif not Needs_Secondary_Stack (R_Type)
or else Is_Ignored_Ghost_Entity (Scope_Id)
then
-- Mutable records with variable-length components are not returned
@@ -7455,7 +7455,7 @@ package body Exp_Ch6 is
-- how to do a copy.)
if Exp_Is_Function_Call
- and then Returns_On_Secondary_Stack (Exp_Typ)
+ and then Needs_Secondary_Stack (Exp_Typ)
then
Set_By_Ref (N);
@@ -10219,7 +10219,7 @@ package body Exp_Ch6 is
pragma Assert (Is_Build_In_Place_Function (Func_Id));
Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
begin
- return Returns_On_Secondary_Stack (Func_Typ);
+ return Needs_Secondary_Stack (Func_Typ);
end Needs_BIP_Alloc_Form;
-------------------------------------
@@ -10312,7 +10312,7 @@ package body Exp_Ch7 is
-- reclamation is done by the caller.
if Ekind (Curr_S) = E_Function
- and then Returns_On_Secondary_Stack (Etype (Curr_S))
+ and then Needs_Secondary_Stack (Etype (Curr_S))
then
null;
@@ -297,15 +297,15 @@ extern Boolean Compile_Time_Known_Value (Node_Id);
#define First_Actual sem_util__first_actual
#define Is_Expression_Function sem_util__is_expression_function
#define Is_Variable_Size_Record sem_util__is_variable_size_record
+#define Needs_Secondary_Stack sem_util__needs_secondary_stack
#define Next_Actual sem_util__next_actual
-#define Returns_On_Secondary_Stack sem_util__returns_on_secondary_stack
extern Entity_Id Defining_Entity (Node_Id);
extern Node_Id First_Actual (Node_Id);
extern Boolean Is_Expression_Function (Entity_Id);
extern Boolean Is_Variable_Size_Record (Entity_Id);
+extern Boolean Needs_Secondary_Stack (Entity_Id);
extern Node_Id Next_Actual (Node_Id);
-extern Boolean Returns_On_Secondary_Stack (Entity_Id);
/* sinfo: */
@@ -5864,7 +5864,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
}
/* This is for the other types returned on the secondary stack. */
- else if (Returns_On_Secondary_Stack (gnat_return_type))
+ else if (Needs_Secondary_Stack (gnat_return_type))
{
gnu_return_type = build_reference_type (gnu_return_type);
return_unconstrained_p = true;
@@ -6959,8 +6959,7 @@ package body Sem_Res is
and then Requires_Transient_Scope (Etype (Nam))
and then not Is_Ignored_Ghost_Entity (Nam)
then
- Establish_Transient_Scope
- (N, Returns_On_Secondary_Stack (Etype (Nam)));
+ Establish_Transient_Scope (N, Needs_Secondary_Stack (Etype (Nam)));
-- If the call appears within the bounds of a loop, it will be
-- rewritten and reanalyzed, nothing left to do here.
@@ -8540,8 +8539,7 @@ package body Sem_Res is
elsif Expander_Active
and then Requires_Transient_Scope (Etype (Nam))
then
- Establish_Transient_Scope
- (N, Returns_On_Secondary_Stack (Etype (Nam)));
+ Establish_Transient_Scope (N, Needs_Secondary_Stack (Etype (Nam)));
end if;
-- Now we know that this is not a call to a function that returns an
@@ -6891,7 +6891,7 @@ package body Sem_Util is
-- returned on the secondary stack, the secondary stack allocation is
-- done by the front end, see Expand_Simple_Function_Return.
- elsif Returns_On_Secondary_Stack (Typ)
+ elsif Needs_Secondary_Stack (Typ)
and then CW_Or_Needs_Finalization (Underlying_Type (Typ))
then
Set_Returns_By_Ref (Func);
@@ -23265,6 +23265,267 @@ package body Sem_Util is
end if;
end Needs_Result_Accessibility_Level;
+ ----------------------------
+ -- Needs_Secondary_Stack --
+ ----------------------------
+
+ function Needs_Secondary_Stack (Id : Entity_Id) return Boolean is
+ pragma Assert (if Present (Id) then Ekind (Id) in E_Void | Type_Kind);
+
+ function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
+ -- Called for untagged record and protected types. Return True if the
+ -- size of function results is known in the caller for Typ.
+
+ function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean;
+ -- Returns True if Typ is a nonlimited record with defaulted
+ -- discriminants whose max size makes it unsuitable for allocating on
+ -- the primary stack.
+
+ ------------------------------
+ -- Caller_Known_Size_Record --
+ ------------------------------
+
+ function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is
+ pragma Assert (Typ = Underlying_Type (Typ));
+
+ function Depends_On_Discriminant (Typ : Entity_Id) return Boolean;
+ -- Called for untagged record and protected types. Return True if Typ
+ -- depends on discriminants, either directly when it is unconstrained
+ -- or indirectly when it is constrained by uplevel discriminants.
+
+ -----------------------------
+ -- Depends_On_Discriminant --
+ -----------------------------
+
+ function Depends_On_Discriminant (Typ : Entity_Id) return Boolean is
+ Cons : Elmt_Id;
+
+ begin
+ if Has_Discriminants (Typ) then
+ if not Is_Constrained (Typ) then
+ return True;
+
+ else
+ Cons := First_Elmt (Discriminant_Constraint (Typ));
+ while Present (Cons) loop
+ if Nkind (Node (Cons)) = N_Identifier
+ and then Ekind (Entity (Node (Cons))) = E_Discriminant
+ then
+ return True;
+ end if;
+
+ Next_Elmt (Cons);
+ end loop;
+ end if;
+ end if;
+
+ return False;
+ end Depends_On_Discriminant;
+
+ begin
+ -- First see if we have a variant part and return False if it depends
+ -- on discriminants.
+
+ if Has_Variant_Part (Typ) and then Depends_On_Discriminant (Typ) then
+ return False;
+ end if;
+
+ -- Then loop over components and return False if their subtype has a
+ -- caller-unknown size, possibly recursively.
+
+ -- ??? This is overly conservative, an array could be nested inside
+ -- some other record that is constrained by nondiscriminants. That
+ -- is, the recursive calls are too conservative.
+
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ declare
+ Comp_Type : constant Entity_Id :=
+ Underlying_Type (Etype (Comp));
+
+ begin
+ if Is_Record_Type (Comp_Type)
+ or else
+ Is_Protected_Type (Comp_Type)
+ then
+ if not Caller_Known_Size_Record (Comp_Type) then
+ return False;
+ end if;
+
+ elsif Is_Array_Type (Comp_Type) then
+ if Size_Depends_On_Discriminant (Comp_Type) then
+ return False;
+ end if;
+ end if;
+ end;
+
+ Next_Component (Comp);
+ end loop;
+ end;
+
+ return True;
+ end Caller_Known_Size_Record;
+
+ ------------------------------
+ -- Large_Max_Size_Mutable --
+ ------------------------------
+
+ function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is
+ pragma Assert (Typ = Underlying_Type (Typ));
+
+ function Is_Large_Discrete_Type (T : Entity_Id) return Boolean;
+ -- Returns true if the discrete type T has a large range
+
+ ----------------------------
+ -- Is_Large_Discrete_Type --
+ ----------------------------
+
+ function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is
+ Threshold : constant Int := 16;
+ -- Arbitrary threshold above which we consider it "large". We want
+ -- a fairly large threshold, because these large types really
+ -- shouldn't have default discriminants in the first place, in
+ -- most cases.
+
+ begin
+ return UI_To_Int (RM_Size (T)) > Threshold;
+ end Is_Large_Discrete_Type;
+
+ -- Start of processing for Large_Max_Size_Mutable
+
+ begin
+ if Is_Record_Type (Typ)
+ and then not Is_Limited_View (Typ)
+ and then Has_Defaulted_Discriminants (Typ)
+ then
+ -- Loop through the components, looking for an array whose upper
+ -- bound(s) depends on discriminants, where both the subtype of
+ -- the discriminant and the index subtype are too large.
+
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ declare
+ Comp_Type : constant Entity_Id :=
+ Underlying_Type (Etype (Comp));
+
+ Hi : Node_Id;
+ Indx : Node_Id;
+ Ityp : Entity_Id;
+
+ begin
+ if Is_Array_Type (Comp_Type) then
+ Indx := First_Index (Comp_Type);
+
+ while Present (Indx) loop
+ Ityp := Etype (Indx);
+ Hi := Type_High_Bound (Ityp);
+
+ if Nkind (Hi) = N_Identifier
+ and then Ekind (Entity (Hi)) = E_Discriminant
+ and then Is_Large_Discrete_Type (Ityp)
+ and then Is_Large_Discrete_Type
+ (Etype (Entity (Hi)))
+ then
+ return True;
+ end if;
+
+ Next_Index (Indx);
+ end loop;
+ end if;
+ end;
+
+ Next_Component (Comp);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Large_Max_Size_Mutable;
+
+ -- Local declarations
+
+ Typ : constant Entity_Id := Underlying_Type (Id);
+
+ -- Start of processing for Needs_Secondary_Stack
+
+ begin
+ -- This is a private type which is not completed yet. This can only
+ -- happen in a default expression (of a formal parameter or of a
+ -- record component). Do not expand transient scope in this case.
+
+ if No (Typ) then
+ return False;
+ end if;
+
+ -- Do not expand transient scope for non-existent procedure return or
+ -- string literal types.
+
+ if Typ = Standard_Void_Type
+ or else Ekind (Typ) = E_String_Literal_Subtype
+ then
+ return False;
+
+ -- If Typ is a generic formal incomplete type, then we want to look at
+ -- the actual type.
+
+ elsif Ekind (Typ) = E_Record_Subtype
+ and then Present (Cloned_Subtype (Typ))
+ then
+ return Needs_Secondary_Stack (Cloned_Subtype (Typ));
+
+ -- Functions returning specific tagged types may dispatch on result, so
+ -- their returned value is allocated on the secondary stack, even in the
+ -- definite case. We must treat nondispatching functions the same way,
+ -- because access-to-function types can point at both, so the calling
+ -- conventions must be compatible.
+
+ elsif Is_Tagged_Type (Typ) then
+ return True;
+
+ -- If the return slot of the back end cannot be accessed, then there
+ -- is no way to call Adjust at the right time for the return object if
+ -- the type needs finalization, so the return object must be allocated
+ -- on the secondary stack.
+
+ elsif not Back_End_Return_Slot and then Needs_Finalization (Typ) then
+ return True;
+
+ -- Untagged definite subtypes are known size. This includes all
+ -- elementary [sub]types. Tasks are known size even if they have
+ -- discriminants. So we return False here, with one exception:
+ -- For a type like:
+ -- type T (Last : Natural := 0) is
+ -- X : String (1 .. Last);
+ -- end record;
+ -- we return True. That's because for "P(F(...));", where F returns T,
+ -- we don't know the size of the result at the call site, so if we
+ -- allocated it on the primary stack, we would have to allocate the
+ -- maximum size, which is way too big.
+
+ elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
+ return Large_Max_Size_Mutable (Typ);
+
+ -- Indefinite (discriminated) untagged record or protected type
+
+ elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
+ return not Caller_Known_Size_Record (Typ);
+
+ -- Unconstrained array
+
+ else
+ pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ));
+ return True;
+ end if;
+ end Needs_Secondary_Stack;
+
---------------------------------
-- Needs_Simple_Initialization --
---------------------------------
@@ -27406,7 +27667,7 @@ package body Sem_Util is
function Requires_Transient_Scope (Typ : Entity_Id) return Boolean is
begin
- return Returns_On_Secondary_Stack (Typ) or else Needs_Finalization (Typ);
+ return Needs_Secondary_Stack (Typ) or else Needs_Finalization (Typ);
end Requires_Transient_Scope;
--------------------------
@@ -27454,267 +27715,6 @@ package body Sem_Util is
SPARK_Mode_Pragma := Prag;
end Restore_SPARK_Mode;
- ---------------------------------
- -- Returns_On_Secondary_Stack --
- ---------------------------------
-
- function Returns_On_Secondary_Stack (Id : Entity_Id) return Boolean is
- pragma Assert (if Present (Id) then Ekind (Id) in E_Void | Type_Kind);
-
- function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
- -- Called for untagged record and protected types. Return True if the
- -- size of function results is known in the caller for Typ.
-
- function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean;
- -- Returns True if Typ is a nonlimited record with defaulted
- -- discriminants whose max size makes it unsuitable for allocating on
- -- the primary stack.
-
- ------------------------------
- -- Caller_Known_Size_Record --
- ------------------------------
-
- function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is
- pragma Assert (Typ = Underlying_Type (Typ));
-
- function Depends_On_Discriminant (Typ : Entity_Id) return Boolean;
- -- Called for untagged record and protected types. Return True if Typ
- -- depends on discriminants, either directly when it is unconstrained
- -- or indirectly when it is constrained by uplevel discriminants.
-
- -----------------------------
- -- Depends_On_Discriminant --
- -----------------------------
-
- function Depends_On_Discriminant (Typ : Entity_Id) return Boolean is
- Cons : Elmt_Id;
-
- begin
- if Has_Discriminants (Typ) then
- if not Is_Constrained (Typ) then
- return True;
-
- else
- Cons := First_Elmt (Discriminant_Constraint (Typ));
- while Present (Cons) loop
- if Nkind (Node (Cons)) = N_Identifier
- and then Ekind (Entity (Node (Cons))) = E_Discriminant
- then
- return True;
- end if;
-
- Next_Elmt (Cons);
- end loop;
- end if;
- end if;
-
- return False;
- end Depends_On_Discriminant;
-
- begin
- -- First see if we have a variant part and return False if it depends
- -- on discriminants.
-
- if Has_Variant_Part (Typ) and then Depends_On_Discriminant (Typ) then
- return False;
- end if;
-
- -- Then loop over components and return False if their subtype has a
- -- caller-unknown size, possibly recursively.
-
- -- ??? This is overly conservative, an array could be nested inside
- -- some other record that is constrained by nondiscriminants. That
- -- is, the recursive calls are too conservative.
-
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Component (Typ);
- while Present (Comp) loop
- declare
- Comp_Type : constant Entity_Id :=
- Underlying_Type (Etype (Comp));
-
- begin
- if Is_Record_Type (Comp_Type)
- or else
- Is_Protected_Type (Comp_Type)
- then
- if not Caller_Known_Size_Record (Comp_Type) then
- return False;
- end if;
-
- elsif Is_Array_Type (Comp_Type) then
- if Size_Depends_On_Discriminant (Comp_Type) then
- return False;
- end if;
- end if;
- end;
-
- Next_Component (Comp);
- end loop;
- end;
-
- return True;
- end Caller_Known_Size_Record;
-
- ------------------------------
- -- Large_Max_Size_Mutable --
- ------------------------------
-
- function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is
- pragma Assert (Typ = Underlying_Type (Typ));
-
- function Is_Large_Discrete_Type (T : Entity_Id) return Boolean;
- -- Returns true if the discrete type T has a large range
-
- ----------------------------
- -- Is_Large_Discrete_Type --
- ----------------------------
-
- function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is
- Threshold : constant Int := 16;
- -- Arbitrary threshold above which we consider it "large". We want
- -- a fairly large threshold, because these large types really
- -- shouldn't have default discriminants in the first place, in
- -- most cases.
-
- begin
- return UI_To_Int (RM_Size (T)) > Threshold;
- end Is_Large_Discrete_Type;
-
- -- Start of processing for Large_Max_Size_Mutable
-
- begin
- if Is_Record_Type (Typ)
- and then not Is_Limited_View (Typ)
- and then Has_Defaulted_Discriminants (Typ)
- then
- -- Loop through the components, looking for an array whose upper
- -- bound(s) depends on discriminants, where both the subtype of
- -- the discriminant and the index subtype are too large.
-
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Component (Typ);
- while Present (Comp) loop
- declare
- Comp_Type : constant Entity_Id :=
- Underlying_Type (Etype (Comp));
-
- Hi : Node_Id;
- Indx : Node_Id;
- Ityp : Entity_Id;
-
- begin
- if Is_Array_Type (Comp_Type) then
- Indx := First_Index (Comp_Type);
-
- while Present (Indx) loop
- Ityp := Etype (Indx);
- Hi := Type_High_Bound (Ityp);
-
- if Nkind (Hi) = N_Identifier
- and then Ekind (Entity (Hi)) = E_Discriminant
- and then Is_Large_Discrete_Type (Ityp)
- and then Is_Large_Discrete_Type
- (Etype (Entity (Hi)))
- then
- return True;
- end if;
-
- Next_Index (Indx);
- end loop;
- end if;
- end;
-
- Next_Component (Comp);
- end loop;
- end;
- end if;
-
- return False;
- end Large_Max_Size_Mutable;
-
- -- Local declarations
-
- Typ : constant Entity_Id := Underlying_Type (Id);
-
- -- Start of processing for Returns_On_Secondary_Stack
-
- begin
- -- This is a private type which is not completed yet. This can only
- -- happen in a default expression (of a formal parameter or of a
- -- record component). Do not expand transient scope in this case.
-
- if No (Typ) then
- return False;
- end if;
-
- -- Do not expand transient scope for non-existent procedure return or
- -- string literal types.
-
- if Typ = Standard_Void_Type
- or else Ekind (Typ) = E_String_Literal_Subtype
- then
- return False;
-
- -- If Typ is a generic formal incomplete type, then we want to look at
- -- the actual type.
-
- elsif Ekind (Typ) = E_Record_Subtype
- and then Present (Cloned_Subtype (Typ))
- then
- return Returns_On_Secondary_Stack (Cloned_Subtype (Typ));
-
- -- Functions returning specific tagged types may dispatch on result, so
- -- their returned value is allocated on the secondary stack, even in the
- -- definite case. We must treat nondispatching functions the same way,
- -- because access-to-function types can point at both, so the calling
- -- conventions must be compatible.
-
- elsif Is_Tagged_Type (Typ) then
- return True;
-
- -- If the return slot of the back end cannot be accessed, then there
- -- is no way to call Adjust at the right time for the return object if
- -- the type needs finalization, so the return object must be allocated
- -- on the secondary stack.
-
- elsif not Back_End_Return_Slot and then Needs_Finalization (Typ) then
- return True;
-
- -- Untagged definite subtypes are known size. This includes all
- -- elementary [sub]types. Tasks are known size even if they have
- -- discriminants. So we return False here, with one exception:
- -- For a type like:
- -- type T (Last : Natural := 0) is
- -- X : String (1 .. Last);
- -- end record;
- -- we return True. That's because for "P(F(...));", where F returns T,
- -- we don't know the size of the result at the call site, so if we
- -- allocated it on the primary stack, we would have to allocate the
- -- maximum size, which is way too big.
-
- elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
- return Large_Max_Size_Mutable (Typ);
-
- -- Indefinite (discriminated) untagged record or protected type
-
- elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
- return not Caller_Known_Size_Record (Typ);
-
- -- Unconstrained array
-
- else
- pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ));
- return True;
- end if;
- end Returns_On_Secondary_Stack;
-
--------------------------------
-- Returns_Unconstrained_Type --
--------------------------------
@@ -32201,10 +32201,9 @@ package body Sem_Util is
-- type Typ (Len : Natural := 0) is
-- record F : String (1 .. Len); end record;
--
- -- See Large_Max_Size_Mutable function elsewhere in this
- -- file (currently declared inside of
- -- Returns_On_Secondary_Stack, so it would have to be
- -- moved if we want it to be callable from here).
+ -- See Large_Max_Size_Mutable function elsewhere in this file,
+ -- currently declared inside of Needs_Secondary_Stack, so it
+ -- would have to be moved if we want it to be callable from here.
end Indirect_Temp_Needed;
@@ -2677,6 +2677,12 @@ package Sem_Util is
-- parameter to identify the accessibility level of the function result
-- "determined by the point of call".
+ function Needs_Secondary_Stack (Id : Entity_Id) return Boolean;
+ -- Return true if functions whose result type is Id must return on the
+ -- secondary stack, i.e. allocate the return object on this stack.
+
+ -- WARNING: There is a matching C declaration of this subprogram in fe.h
+
function Needs_Simple_Initialization
(Typ : Entity_Id;
Consider_IS : Boolean := True) return Boolean;
@@ -3092,12 +3098,6 @@ package Sem_Util is
-- Set the current SPARK_Mode to Mode and SPARK_Mode_Pragma to Prag. This
-- routine must be used in tandem with Set_SPARK_Mode.
- function Returns_On_Secondary_Stack (Id : Entity_Id) return Boolean;
- -- Return true if functions whose result type is Id must return on the
- -- secondary stack, i.e. allocate the return object on this stack.
-
- -- WARNING: There is a matching C declaration of this subprogram in fe.h
-
function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean;
-- Return true if Subp is a function that returns an unconstrained type