-- --
------------------------------------------------------------------------------
-with Treepr; -- ???For debugging code below
-
with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
-- routine does not take simple flow diagnostics into account, it relies on
-- static facts such as the presence of null exclusions.
- function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
- function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
- -- ???We retain the old and new algorithms for Requires_Transient_Scope for
- -- the time being. New_Requires_Transient_Scope is used by default; the
- -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope
- -- instead. The intent is to use this temporarily to measure before/after
- -- efficiency. Note: when this temporary code is removed, the documentation
- -- of dQ in debug.adb should be removed.
-
- procedure Results_Differ
- (Id : Entity_Id;
- Old_Val : Boolean;
- New_Val : Boolean);
- -- ???Debugging code. Called when the Old_Val and New_Val differ. This
- -- routine will be removed eventially when New_Requires_Transient_Scope
- -- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is
- -- eliminated.
-
function Subprogram_Name (N : Node_Id) return String;
-- Return the fully qualified name of the enclosing subprogram for the
-- given node N, with file:line:col information appended, e.g.
Node := Next_Global (Node);
end Next_Global;
- ----------------------------------
- -- New_Requires_Transient_Scope --
- ----------------------------------
-
- function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
- function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
- -- This is called for untagged records and protected types, with
- -- nondefaulted discriminants. Returns True if the size of function
- -- results is known at the call site, False otherwise. Returns False
- -- if there is a variant part that depends on the discriminants of
- -- this type, or if there is an array constrained by the discriminants
- -- of this type. ???Currently, this is overly conservative (the array
- -- could be nested inside some other record that is constrained by
- -- nondiscriminants). That is, the recursive calls are too conservative.
-
- 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));
-
- begin
- if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then
- return False;
- end if;
-
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Component (Typ);
- while Present (Comp) loop
-
- -- Only look at E_Component entities. No need to look at
- -- E_Discriminant entities, and we must ignore internal
- -- subtypes generated for constrained components.
-
- 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 New_Requires_Transient_Scope
-
- 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;
-
- -- Do not expand transient scope for non-existent procedure return or
- -- string literal types.
-
- elsif 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 New_Requires_Transient_Scope (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. Is_Tagged_Type includes controlled
- -- types and class-wide types. Controlled type temporaries need
- -- finalization.
-
- -- ???It's not clear why we need to return noncontrolled types with
- -- controlled components on the secondary stack.
-
- elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (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 New_Requires_Transient_Scope;
-
------------------------
-- No_Caching_Enabled --
------------------------
return Num;
end Number_Of_Elements_In_Array;
- ----------------------------------
- -- Old_Requires_Transient_Scope --
- ----------------------------------
+ ---------------------------------
+ -- Original_Aspect_Pragma_Name --
+ ---------------------------------
- function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
- Typ : constant Entity_Id := Underlying_Type (Id);
+ function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is
+ Item : Node_Id;
+ Item_Nam : Name_Id;
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.
+ pragma Assert (Nkind (N) in N_Aspect_Specification | N_Pragma);
- if No (Typ) then
- return False;
+ Item := N;
- -- Do not expand transient scope for non-existent procedure return
+ -- The pragma was generated to emulate an aspect, use the original
+ -- aspect specification.
- elsif Typ = Standard_Void_Type then
- return False;
+ if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then
+ Item := Corresponding_Aspect (Item);
+ end if;
- -- Elementary types do not require a transient scope
+ -- Retrieve the name of the aspect/pragma. As assertion pragmas from
+ -- a generic instantiation might have been rewritten into pragma Check,
+ -- we look at the original node for Item. Note also that Pre, Pre_Class,
+ -- Post and Post_Class rewrite their pragma identifier to preserve the
+ -- original name, so we look at the original node for the identifier.
+ -- ??? this is kludgey
- elsif Is_Elementary_Type (Typ) then
- return False;
+ if Nkind (Item) = N_Pragma then
+ Item_Nam :=
+ Chars (Original_Node (Pragma_Identifier (Original_Node (Item))));
- -- Generally, indefinite subtypes require a transient scope, since the
- -- back end cannot generate temporaries, since this is not a valid type
- -- for declaring an object. It might be possible to relax this in the
- -- future, e.g. by declaring the maximum possible space for the type.
-
- elsif not Is_Definite_Subtype (Typ) then
- return True;
-
- -- Functions returning tagged types may dispatch on result so their
- -- returned value is allocated on the secondary stack. Controlled
- -- type temporaries need finalization.
-
- elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
- return True;
-
- -- Record type
-
- elsif Is_Record_Type (Typ) then
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Entity (Typ);
- while Present (Comp) loop
- if Ekind (Comp) = E_Component then
-
- -- ???It's not clear we need a full recursive call to
- -- Old_Requires_Transient_Scope here. Note that the
- -- following can't happen.
-
- pragma Assert (Is_Definite_Subtype (Etype (Comp)));
- pragma Assert (not Has_Controlled_Component (Etype (Comp)));
-
- if Old_Requires_Transient_Scope (Etype (Comp)) then
- return True;
- end if;
- end if;
-
- Next_Entity (Comp);
- end loop;
- end;
-
- return False;
-
- -- String literal types never require transient scope
-
- elsif Ekind (Typ) = E_String_Literal_Subtype then
- return False;
-
- -- Array type. Note that we already know that this is a constrained
- -- array, since unconstrained arrays will fail the indefinite test.
-
- elsif Is_Array_Type (Typ) then
-
- -- If component type requires a transient scope, the array does too
-
- if Old_Requires_Transient_Scope (Component_Type (Typ)) then
- return True;
-
- -- Otherwise, we only need a transient scope if the size depends on
- -- the value of one or more discriminants.
-
- else
- return Size_Depends_On_Discriminant (Typ);
- end if;
-
- -- All other cases do not require a transient scope
-
- else
- pragma Assert (Is_Concurrent_Type (Typ));
- return False;
- end if;
- end Old_Requires_Transient_Scope;
-
- ---------------------------------
- -- Original_Aspect_Pragma_Name --
- ---------------------------------
-
- function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is
- Item : Node_Id;
- Item_Nam : Name_Id;
-
- begin
- pragma Assert (Nkind (N) in N_Aspect_Specification | N_Pragma);
-
- Item := N;
-
- -- The pragma was generated to emulate an aspect, use the original
- -- aspect specification.
-
- if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then
- Item := Corresponding_Aspect (Item);
- end if;
-
- -- Retrieve the name of the aspect/pragma. As assertion pragmas from
- -- a generic instantiation might have been rewritten into pragma Check,
- -- we look at the original node for Item. Note also that Pre, Pre_Class,
- -- Post and Post_Class rewrite their pragma identifier to preserve the
- -- original name, so we look at the original node for the identifier.
- -- ??? this is kludgey
-
- if Nkind (Item) = N_Pragma then
- Item_Nam :=
- Chars (Original_Node (Pragma_Identifier (Original_Node (Item))));
-
- else
- pragma Assert (Nkind (Item) = N_Aspect_Specification);
- Item_Nam := Chars (Identifier (Item));
- end if;
+ else
+ pragma Assert (Nkind (Item) = N_Aspect_Specification);
+ Item_Nam := Chars (Identifier (Item));
+ end if;
-- Deal with 'Class by converting the name to its _XXX form
-- generated before the next instruction.
function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
- Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id);
+ function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
+ -- This is called for untagged records and protected types, with
+ -- nondefaulted discriminants. Returns True if the size of function
+ -- results is known at the call site, False otherwise. Returns False
+ -- if there is a variant part that depends on the discriminants of
+ -- this type, or if there is an array constrained by the discriminants
+ -- of this type. ???Currently, this is overly conservative (the array
+ -- could be nested inside some other record that is constrained by
+ -- nondiscriminants). That is, the recursive calls are too conservative.
procedure Ensure_Minimum_Decoration (Typ : Entity_Id);
-- If Typ is not frozen then add to Typ the minimum decoration required
-- by Requires_Transient_Scope to reliably provide its functionality;
-- otherwise no action is performed.
+ 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));
+
+ begin
+ if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then
+ return False;
+ end if;
+
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+
+ -- Only look at E_Component entities. No need to look at
+ -- E_Discriminant entities, and we must ignore internal
+ -- subtypes generated for constrained components.
+
+ 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;
+
-------------------------------
-- Ensure_Minimum_Decoration --
-------------------------------
procedure Ensure_Minimum_Decoration (Typ : Entity_Id) is
+ Comp : Entity_Id;
begin
-- Do not set Has_Controlled_Component on a class-wide equivalent
-- type. See Make_CW_Equivalent_Type.
or else Is_Incomplete_Or_Private_Type (Typ))
and then not Is_Class_Wide_Equivalent_Type (Typ)
then
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ if Has_Controlled_Component (Etype (Comp))
+ or else
+ (Chars (Comp) /= Name_uParent
+ and then Is_Controlled (Etype (Comp)))
+ or else
+ (Is_Protected_Type (Etype (Comp))
+ and then
+ Present (Corresponding_Record_Type (Etype (Comp)))
+ and then
+ Has_Controlled_Component
+ (Corresponding_Record_Type (Etype (Comp))))
+ then
+ Set_Has_Controlled_Component (Typ);
+ exit;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ end if;
+ end Ensure_Minimum_Decoration;
+
+ ------------------------------
+ -- 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
- if Has_Controlled_Component (Etype (Comp))
- or else
- (Chars (Comp) /= Name_uParent
- and then Is_Controlled (Etype (Comp)))
- or else
- (Is_Protected_Type (Etype (Comp))
- and then
- Present (Corresponding_Record_Type (Etype (Comp)))
- and then
- Has_Controlled_Component
- (Corresponding_Record_Type (Etype (Comp))))
- then
- Set_Has_Controlled_Component (Typ);
- exit;
- end if;
+ 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;
- end Ensure_Minimum_Decoration;
+
+ return False;
+ end Large_Max_Size_Mutable;
+
+ -- Local declarations
+
+ Typ : constant Entity_Id := Underlying_Type (Id);
-- Start of processing for Requires_Transient_Scope
begin
- if Debug_Flag_QQ then
- return Old_Result;
- end if;
-
Ensure_Minimum_Decoration (Id);
- declare
- New_Result : constant Boolean := New_Requires_Transient_Scope (Id);
+ -- 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.
- begin
- -- Assert that we're not putting things on the secondary stack if we
- -- didn't before; we are trying to AVOID secondary stack when
- -- possible.
+ if No (Typ) then
+ return False;
- if not Old_Result then
- pragma Assert (not New_Result);
- null;
- end if;
+ -- Do not expand transient scope for non-existent procedure return or
+ -- string literal types.
- if New_Result /= Old_Result then
- Results_Differ (Id, Old_Result, New_Result);
- end if;
+ elsif Typ = Standard_Void_Type
+ or else Ekind (Typ) = E_String_Literal_Subtype
+ then
+ return False;
- return New_Result;
- end;
- end Requires_Transient_Scope;
+ -- If Typ is a generic formal incomplete type, then we want to look at
+ -- the actual type.
- --------------------
- -- Results_Differ --
- --------------------
+ elsif Ekind (Typ) = E_Record_Subtype
+ and then Present (Cloned_Subtype (Typ))
+ then
+ return Requires_Transient_Scope (Cloned_Subtype (Typ));
- procedure Results_Differ
- (Id : Entity_Id;
- Old_Val : Boolean;
- New_Val : Boolean)
- is
- begin
- if False then -- False to disable; True for debugging
- Treepr.Print_Tree_Node (Id);
+ -- 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. Is_Tagged_Type includes controlled
+ -- types and class-wide types. Controlled type temporaries need
+ -- finalization.
- if Old_Val = New_Val then
- raise Program_Error;
- end if;
+ -- ???It's not clear why we need to return noncontrolled types with
+ -- controlled components on the secondary stack.
+
+ elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (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 Results_Differ;
+ end Requires_Transient_Scope;
--------------------------
-- Reset_Analyzed_Flags --
--
-- See Large_Max_Size_Mutable function elsewhere in this
-- file (currently declared inside of
- -- New_Requires_Transient_Scope, so it would have to be
+ -- Requires_Transient_Scope, so it would have to be
-- moved if we want it to be callable from here).
end Indirect_Temp_Needed;
projects / gcc.git / commitdiff