diff options
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/fe.h | 4 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/decl.cc | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 533 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 12 |
7 files changed, 283 insertions, 286 deletions
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index f9c6f33..8bbc515 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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; ------------------------------------- diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index d611d0e..206f46a 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -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; diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 1048465..a4ab35e 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -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: */ diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index 50d17f7..318c3be 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -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; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ad6d467..7d595eb 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index eb0a1f1..c231fbb 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 37118cc..4121cf0 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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 |