From patchwork Fri Mar 30 09:21:55 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 149593 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 2CF4CB6F6E for ; Fri, 30 Mar 2012 20:22:22 +1100 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1333704143; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Received:Received:Date:From:To:Cc:Subject:Message-ID: MIME-Version:Content-Type:Content-Disposition:User-Agent: Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:Sender:Delivered-To; bh=wxCi3zzO8tnUGpNVMha3 hR9LsTg=; b=hex7uDA+48Kq0+vRixEV64ZHRQZ4x4hcyqa3aD2iUpraaXzV8zsl vng0NB3eKpqSWB70BOAI4BCaGys9/e/VihONWwclfitfvAWy3HE16uGS0P7lF+Bf mzhQEeRZbHTQdx80ziUS2+Q4GR7DDgQvsoI6/hnKKXz2zAuh2++b+4A= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:Received:Received:Date:From:To:Cc:Subject:Message-ID:MIME-Version:Content-Type:Content-Disposition:User-Agent:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=PwsnmjhbJ4YwJykg4C5DoaggSgSTXM8m+o+huiwaHvXZMDEeFNP7XxtiOU+M0Z AWqZDFnvUJmPXf/M/fW12uKoyIXtTb2CVwnLv6joxgNDnUga81loD+SaltnzSmGh GPVIzXRCCGnf8i+hnsf+wg8GHIqj9uK+4d7RdnUB18zQY=; Received: (qmail 19075 invoked by alias); 30 Mar 2012 09:22:14 -0000 Received: (qmail 19063 invoked by uid 22791); 30 Mar 2012 09:22:10 -0000 X-SWARE-Spam-Status: No, hits=-1.9 required=5.0 tests=AWL, BAYES_00, RCVD_IN_HOSTKARMA_NO X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 30 Mar 2012 09:21:56 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 96B5D1C613D; Fri, 30 Mar 2012 05:21:55 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id A3M4D1YuIbIP; Fri, 30 Mar 2012 05:21:55 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 735C31C6133; Fri, 30 Mar 2012 05:21:55 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 6CD7B92BF6; Fri, 30 Mar 2012 05:21:55 -0400 (EDT) Date: Fri, 30 Mar 2012 05:21:55 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Incorrect finalization of build-in-place function result Message-ID: <20120330092155.GA22591@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 * 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