This patch updates the mechanism which detects build-in-place function calls returning controlled results on the secondary stack.
------------ -- Source -- ------------ -- types.ads with Ada.Finalization; use Ada.Finalization; package Types is type Ctrl_Comp is new Limited_Controlled with null record; procedure Finalize (Obj : in out Ctrl_Comp); type Root is tagged limited null record; type Root_Ptr is access all Root'Class; function Create (Ctrl : Boolean) return Root'Class; type Empty_Child is new Root with null record; type Ctrl_Child is new Root with record Comp : Ctrl_Comp; end record; end Types; -- types.adb with Ada.Text_IO; use Ada.Text_IO; package body Types is function Create (Ctrl : Boolean) return Root'Class is begin if Ctrl then return Result : Ctrl_Child; else return Result : Empty_Child; end if; end Create; procedure Finalize (Obj : in out Ctrl_Comp) is begin Put_Line (" Finalize"); end Finalize; end Types; -- main.adb with Ada.Text_IO; use Ada.Text_IO; with Types; use Types; procedure Main is pragma Suppress (Accessibility_Check); begin Put_Line ("Empty child"); declare Obj : Root_Ptr := new Root'Class'(Create (False)); begin Put_Line ("Empty child allocated"); end; Put_Line ("Ctrl child"); declare Obj : Root_Ptr := new Root'Class'(Create (True)); begin Put_Line ("Ctrl child allocated"); end; Put_Line ("End"); end Main; ------------------------------------- -- Compilation and expected output -- ------------------------------------- $ gnatmake -q -gnat05 main.adb $ ./main Empty child Empty child allocated Ctrl child Ctrl child allocated End Finalize Tested on x86_64-pc-linux-gnu, committed on trunk 2012-03-30 Hristian Kirtchev <kirtc...@adacore.com> * exp_ch7.adb (Process_Declarations): Replace the call to Is_Null_Access_BIP_Func_Call with Is_Secondary_Stack_BIP_Func_Call. Update the related comment. * exp_util.adb (Is_Null_Access_BIP_Func_Call): Removed. (Is_Secondary_Stack_BIP_Func_Call): New routine. (Requires_Cleanup_Actions): Replace the call to Is_Null_Access_BIP_Func_Call with Is_Secondary_Stack_BIP_Func_Call. Update the related comment. * exp_util.ads (Is_Null_Access_BIP_Func_Call): Removed. (Is_Secondary_Stack_BIP_Func_Call): New routine.
Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 185995) +++ exp_ch7.adb (working copy) @@ -1824,15 +1824,14 @@ -- Obj : Access_Typ := Non_BIP_Function_Call'reference; -- Obj : Access_Typ := - -- BIP_Function_Call - -- (..., BIPaccess => null, ...)'reference; + -- BIP_Function_Call (BIPalloc => 2, ...)'reference; elsif Is_Access_Type (Obj_Typ) and then Needs_Finalization (Available_View (Designated_Type (Obj_Typ))) and then Present (Expr) and then - (Is_Null_Access_BIP_Func_Call (Expr) + (Is_Secondary_Stack_BIP_Func_Call (Expr) or else (Is_Non_BIP_Func_Call (Expr) and then not Is_Related_To_Func_Return (Obj_Id))) Index: exp_util.adb =================================================================== --- exp_util.adb (revision 185995) +++ exp_util.adb (working copy) @@ -4475,74 +4475,6 @@ and then Is_Library_Level_Entity (Typ); end Is_Library_Level_Tagged_Type; - ---------------------------------- - -- Is_Null_Access_BIP_Func_Call -- - ---------------------------------- - - function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean is - Call : Node_Id := Expr; - - begin - -- Build-in-place calls usually appear in 'reference format - - if Nkind (Call) = N_Reference then - Call := Prefix (Call); - end if; - - if Nkind_In (Call, N_Qualified_Expression, - N_Unchecked_Type_Conversion) - then - Call := Expression (Call); - end if; - - if Is_Build_In_Place_Function_Call (Call) then - declare - Access_Nam : Name_Id := No_Name; - Actual : Node_Id; - Param : Node_Id; - Formal : Node_Id; - - begin - -- Examine all parameter associations of the function call - - Param := First (Parameter_Associations (Call)); - while Present (Param) loop - if Nkind (Param) = N_Parameter_Association - and then Nkind (Selector_Name (Param)) = N_Identifier - then - Formal := Selector_Name (Param); - Actual := Explicit_Actual_Parameter (Param); - - -- Construct the name of formal BIPaccess. It is much easier - -- to extract the name of the function using an arbitrary - -- formal's scope rather than the Name field of Call. - - if Access_Nam = No_Name - and then Present (Entity (Formal)) - then - Access_Nam := - New_External_Name - (Chars (Scope (Entity (Formal))), - BIP_Formal_Suffix (BIP_Object_Access)); - end if; - - -- A match for BIPaccess => null has been found - - if Chars (Formal) = Access_Nam - and then Nkind (Actual) = N_Null - then - return True; - end if; - end if; - - Next (Param); - end loop; - end; - end if; - - return False; - end Is_Null_Access_BIP_Func_Call; - -------------------------- -- Is_Non_BIP_Func_Call -- -------------------------- @@ -4949,6 +4881,75 @@ end if; end Is_Renamed_Object; + -------------------------------------- + -- Is_Secondary_Stack_BIP_Func_Call -- + -------------------------------------- + + function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is + Call : Node_Id := Expr; + + begin + -- Build-in-place calls usually appear in 'reference format + + if Nkind (Call) = N_Reference then + Call := Prefix (Call); + end if; + + if Nkind_In (Call, N_Qualified_Expression, + N_Unchecked_Type_Conversion) + then + Call := Expression (Call); + end if; + + if Is_Build_In_Place_Function_Call (Call) then + declare + Access_Nam : Name_Id := No_Name; + Actual : Node_Id; + Param : Node_Id; + Formal : Node_Id; + + begin + -- Examine all parameter associations of the function call + + Param := First (Parameter_Associations (Call)); + while Present (Param) loop + if Nkind (Param) = N_Parameter_Association + and then Nkind (Selector_Name (Param)) = N_Identifier + then + Formal := Selector_Name (Param); + Actual := Explicit_Actual_Parameter (Param); + + -- Construct the name of formal BIPalloc. It is much easier + -- to extract the name of the function using an arbitrary + -- formal's scope rather than the Name field of Call. + + if Access_Nam = No_Name + and then Present (Entity (Formal)) + then + Access_Nam := + New_External_Name + (Chars (Scope (Entity (Formal))), + BIP_Formal_Suffix (BIP_Alloc_Form)); + end if; + + -- A match for BIPalloc => 2 has been found + + if Chars (Formal) = Access_Nam + and then Nkind (Actual) = N_Integer_Literal + and then Intval (Actual) = Uint_2 + then + return True; + end if; + end if; + + Next (Param); + end loop; + end; + end if; + + return False; + end Is_Secondary_Stack_BIP_Func_Call; + ------------------------------------- -- Is_Tag_To_Class_Wide_Conversion -- ------------------------------------- @@ -7123,18 +7124,17 @@ -- Obj : Access_Typ := Non_BIP_Function_Call'reference; -- -- Obj : Access_Typ := - -- BIP_Function_Call - -- (..., BIPaccess => null, ...)'reference; + -- BIP_Function_Call (BIPalloc => 2, ...)'reference; elsif Is_Access_Type (Obj_Typ) and then Needs_Finalization (Available_View (Designated_Type (Obj_Typ))) and then Present (Expr) and then - (Is_Null_Access_BIP_Func_Call (Expr) - or else - (Is_Non_BIP_Func_Call (Expr) - and then not Is_Related_To_Func_Return (Obj_Id))) + (Is_Secondary_Stack_BIP_Func_Call (Expr) + or else + (Is_Non_BIP_Func_Call (Expr) + and then not Is_Related_To_Func_Return (Obj_Id))) then return True; Index: exp_util.ads =================================================================== --- exp_util.ads (revision 185995) +++ exp_util.ads (working copy) @@ -548,13 +548,20 @@ -- Return True if Typ is a library level tagged type. Currently we use -- this information to build statically allocated dispatch tables. - function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean; - -- Determine whether node Expr denotes a build-in-place function call with - -- a value of "null" for extra formal BIPaccess. - function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean; -- Determine whether node Expr denotes a non build-in-place function call + function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean; + -- Node N is an object reference. This function returns True if it is + -- possible that the object may not be aligned according to the normal + -- default alignment requirement for its type (e.g. if it appears in a + -- packed record, or as part of a component that has a component clause.) + + function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean; + -- Determine whether the node P is a slice of an array where the slice + -- result may cause alignment problems because it has an alignment that + -- is not compatible with the type. Return True if so. + function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean; -- Determine whether the node P is a reference to a bit packed array, i.e. -- whether the designated object is a component of a bit packed array, or a @@ -571,17 +578,6 @@ -- Determine whether object Id is related to an expanded return statement. -- The case concerned is "return Id.all;". - function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean; - -- Determine whether the node P is a slice of an array where the slice - -- result may cause alignment problems because it has an alignment that - -- is not compatible with the type. Return True if so. - - function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean; - -- Node N is an object reference. This function returns True if it is - -- possible that the object may not be aligned according to the normal - -- default alignment requirement for its type (e.g. if it appears in a - -- packed record, or as part of a component that has a component clause.) - function Is_Renamed_Object (N : Node_Id) return Boolean; -- Returns True if the node N is a renamed object. An expression is -- considered to be a renamed object if either it is the Name of an object @@ -593,6 +589,10 @@ -- We consider that a (1 .. 2) is a renamed object since it is the prefix -- of the name in the renaming declaration. + function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean; + -- Determine whether Expr denotes a build-in-place function which returns + -- its result on the secondary stack. + function Is_Tag_To_Class_Wide_Conversion (Obj_Id : Entity_Id) return Boolean; -- Determine whether object Obj_Id is the result of a tag-to-class-wide