From patchwork Wed Sep 6 12:06:22 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 810553 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-461593-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="xyIMeCuZ"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3xnMkq1Qbcz9sCZ for ; Wed, 6 Sep 2017 22:06:43 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=wGBoYAdAXWbmd0/4bfMmlor23M5TuRwV1aT5liXtrZm0jp0eu0 +3FvdBiub1L4QUmd4JGWKTdOsbVL6wOUZqy2L5fg8UQpjusgvHH+SUEn0CY2lbdc usTyNrmCJ/vMyp8QAg0+gGdNt4A09PKV8BxxnMV3sElJtoCGJb97hkqCU= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=QlQmwtfIPJFU9PtJxwUtRl1ucWk=; b=xyIMeCuZ2olNK21UjghP +TVD/MrGO0Dc4fsgdKgBrZ39vUGsLL4mOJA/FbxvQ1e/J/7OT8G73munG7Wr+ADC echXxaqLpaGLVEUEjpjkmcT8/rjX2kE30Iud6qqww1vitHkIZ1JnHGmkHAh/QHAN W7pmxUssn6ca/EmeDY5aQRo= Received: (qmail 34712 invoked by alias); 6 Sep 2017 12:06:34 -0000 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 Received: (qmail 34435 invoked by uid 89); 6 Sep 2017 12:06:33 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-11.1 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=ini X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 06 Sep 2017 12:06:24 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id E63D056415; Wed, 6 Sep 2017 08:06:22 -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 x8e+j7aUkon3; Wed, 6 Sep 2017 08:06:22 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id D3F8C5614C; Wed, 6 Sep 2017 08:06:22 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id CFDA34AC; Wed, 6 Sep 2017 08:06:22 -0400 (EDT) Date: Wed, 6 Sep 2017 08:06:22 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Missing finalization of generalized indexed element Message-ID: <20170906120622.GA48003@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch modifies the finalization mechanism to recognize a heavily expanded generalized indexing where the element type requires finalization actions. ------------ -- Source -- ------------ -- types.ads with Ada.Finalization; use Ada.Finalization; package Types is type Element is new Controlled with record Id : Natural := 0; end record; procedure Adjust (Obj : in out Element); procedure Finalize (Obj : in out Element); procedure Initialize (Obj : In out Element); subtype Index is Integer range 1 .. 3; type Collection is array (Index) of Element; type Vector is new Controlled with record Id : Natural := 0; Elements : Collection; end record with Constant_Indexing => Element_At; procedure Adjust (Obj : in out Vector); procedure Finalize (Obj : in out Vector); procedure Initialize (Obj : In out Vector); function Element_At (Obj : Vector; Pos : Index) return Element'Class; function Make_Vector return Vector'Class; end Types; -- types.adb with Ada.Text_IO; use Ada.Text_IO; package body Types is Id_Gen : Natural := 10; procedure Adjust (Obj : in out Element) is Old_Id : constant Natural := Obj.Id; New_Id : constant Natural := Old_Id + 1; begin if Old_Id = 0 then Put_Line (" Element adj ERROR"); else Put_Line (" Element adj" & Old_Id'Img & " ->" & New_Id'Img); Obj.Id := New_Id; end if; end Adjust; procedure Adjust (Obj : in out Vector) is Old_Id : constant Natural := Obj.Id; New_Id : constant Natural := Old_Id + 1; begin if Old_Id = 0 then Put_Line (" Vector adj ERROR"); else Put_Line (" Vector adj" & Old_Id'Img & " ->" & New_Id'Img); Obj.Id := New_Id; end if; end Adjust; function Element_At (Obj : Vector; Pos : Index) return Element'Class is begin return Obj.Elements (Pos); end Element_At; procedure Finalize (Obj : in out Element) is begin if Obj.Id = 0 then Put_Line (" Element fin ERROR"); else Put_Line (" Element fin" & Obj.Id'Img); Obj.Id := 0; end if; end Finalize; procedure Finalize (Obj : in out Vector) is begin if Obj.Id = 0 then Put_Line (" Vector fin ERROR"); else Put_Line (" Vector fin" & Obj.Id'Img); Obj.Id := 0; end if; end Finalize; procedure Initialize (Obj : In out Element) is begin Obj.Id := Id_Gen; Id_Gen := Id_Gen + 10; Put_Line (" Element ini" & Obj.Id'Img); end Initialize; procedure Initialize (Obj : In out Vector) is begin Obj.Id := Id_Gen; Id_Gen := Id_Gen + 10; Put_Line (" Vector ini" & Obj.Id'Img); end Initialize; function Make_Vector return Vector'Class is Result : Vector; begin return Result; end Make_Vector; end Types; -- main.adb with Ada.Text_IO; use Ada.Text_IO; with Types; use Types; procedure Main is begin Put_Line ("Main"); declare Vec : Vector'Class := Make_Vector; Elem : Element'Class := Vec (1); begin Put_Line ("Main middle"); end; Put_Line ("Main end"); end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q main.adb $ ./main.adb Main Element ini 10 Element ini 20 Element ini 30 Vector ini 40 Element adj 10 -> 11 Element adj 20 -> 21 Element adj 30 -> 31 Vector adj 40 -> 41 Vector fin 40 Element fin 30 Element fin 20 Element fin 10 Element adj 11 -> 12 Element adj 21 -> 22 Element adj 31 -> 32 Vector adj 41 -> 42 Vector fin 41 Element fin 31 Element fin 21 Element fin 11 Element adj 12 -> 13 Element adj 13 -> 14 Element fin 13 Main middle Element fin 14 Vector fin 42 Element fin 32 Element fin 22 Element fin 12 Main end Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Hristian Kirtchev * exp_util.adb (Is_Controlled_Indexing): New routine. (Is_Displace_Call): Use routine Strip to remove indirections. (Is_Displacement_Of_Object_Or_Function_Result): Code clean up. Add a missing case of controlled generalized indexing. (Is_Source_Object): Use routine Strip to remove indirections. (Strip): New routine. Index: exp_util.adb =================================================================== --- exp_util.adb (revision 251784) +++ exp_util.adb (working copy) @@ -7590,22 +7590,28 @@ (Obj_Id : Entity_Id) return Boolean is function Is_Controlled_Function_Call (N : Node_Id) return Boolean; - -- Determine if particular node denotes a controlled function call. The - -- call may have been heavily expanded. + -- Determine whether node N denotes a controlled function call + function Is_Controlled_Indexing (N : Node_Id) return Boolean; + -- Determine whether node N denotes a generalized indexing form which + -- involves a controlled result. + function Is_Displace_Call (N : Node_Id) return Boolean; - -- Determine whether a particular node is a call to Ada.Tags.Displace. - -- The call might be nested within other actions such as conversions. + -- Determine whether node N denotes a call to Ada.Tags.Displace function Is_Source_Object (N : Node_Id) return Boolean; -- Determine whether a particular node denotes a source object + function Strip (N : Node_Id) return Node_Id; + -- Examine arbitrary node N by stripping various indirections and return + -- the "real" node. + --------------------------------- -- Is_Controlled_Function_Call -- --------------------------------- function Is_Controlled_Function_Call (N : Node_Id) return Boolean is - Expr : Node_Id := Original_Node (N); + Expr : Node_Id; begin -- When a function call appears in Object.Operation format, the @@ -7617,6 +7623,7 @@ -- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an -- N_Selected_Component + Expr := Original_Node (N); loop if Nkind (Expr) = N_Function_Call then Expr := Name (Expr); @@ -7643,31 +7650,28 @@ and then Needs_Finalization (Etype (Entity (Expr))); end Is_Controlled_Function_Call; + ---------------------------- + -- Is_Controlled_Indexing -- + ---------------------------- + + function Is_Controlled_Indexing (N : Node_Id) return Boolean is + Expr : constant Node_Id := Original_Node (N); + + begin + return + Nkind (Expr) = N_Indexed_Component + and then Present (Generalized_Indexing (Expr)) + and then Needs_Finalization (Etype (Expr)); + end Is_Controlled_Indexing; + ---------------------- -- Is_Displace_Call -- ---------------------- function Is_Displace_Call (N : Node_Id) return Boolean is - Call : Node_Id; + Call : constant Node_Id := Strip (N); begin - -- Strip various actions which may precede a call to Displace - - Call := N; - loop - if Nkind (Call) = N_Explicit_Dereference then - Call := Prefix (Call); - - elsif Nkind_In (Call, N_Type_Conversion, - N_Unchecked_Type_Conversion) - then - Call := Expression (Call); - - else - exit; - end if; - end loop; - return Present (Call) and then Nkind (Call) = N_Function_Call @@ -7679,38 +7683,48 @@ ---------------------- function Is_Source_Object (N : Node_Id) return Boolean is - Obj : Node_Id; + Obj : constant Node_Id := Strip (N); begin - -- Strip various actions which may be associated with the object + return + Present (Obj) + and then Comes_From_Source (Obj) + and then Nkind (Obj) in N_Has_Entity + and then Is_Object (Entity (Obj)); + end Is_Source_Object; - Obj := N; + ----------- + -- Strip -- + ----------- + + function Strip (N : Node_Id) return Node_Id is + Result : Node_Id; + + begin + Result := N; loop - if Nkind (Obj) = N_Explicit_Dereference then - Obj := Prefix (Obj); + if Nkind (Result) = N_Explicit_Dereference then + Result := Prefix (Result); - elsif Nkind_In (Obj, N_Type_Conversion, - N_Unchecked_Type_Conversion) + elsif Nkind_In (Result, N_Type_Conversion, + N_Unchecked_Type_Conversion) then - Obj := Expression (Obj); + Result := Expression (Result); else exit; end if; end loop; - return - Present (Obj) - and then Nkind (Obj) in N_Has_Entity - and then Is_Object (Entity (Obj)) - and then Comes_From_Source (Obj); - end Is_Source_Object; + return Result; + end Strip; -- Local variables - Decl : constant Node_Id := Parent (Obj_Id); + Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id); Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); - Orig_Decl : constant Node_Id := Original_Node (Decl); + Orig_Decl : constant Node_Id := Original_Node (Obj_Decl); + Orig_Expr : Node_Id; -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result @@ -7719,34 +7733,52 @@ -- Obj : CW_Type := Function_Call (...); - -- rewritten into: + -- is rewritten into: - -- Tmp : ... := Function_Call (...)'reference; - -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp)); + -- Temp : ... := Function_Call (...)'reference; + -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp)); -- where the return type of the function and the class-wide type require -- dispatch table pointer displacement. -- Case 2: + -- Obj : CW_Type := Container (...); + + -- is rewritten into: + + -- Temp : ... := Function_Call (Container, ...)'reference; + -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp)); + + -- where the container element type and the class-wide type require + -- dispatch table pointer dispacement. + + -- Case 3: + -- Obj : CW_Type := Src_Obj; - -- rewritten into: + -- is rewritten into: -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); -- where the type of the source object and the class-wide type require -- dispatch table pointer displacement. - return - Nkind (Decl) = N_Object_Renaming_Declaration - and then Nkind (Orig_Decl) = N_Object_Declaration - and then Comes_From_Source (Orig_Decl) - and then Is_Class_Wide_Type (Obj_Typ) - and then Is_Displace_Call (Renamed_Object (Obj_Id)) - and then - (Is_Controlled_Function_Call (Expression (Orig_Decl)) - or else Is_Source_Object (Expression (Orig_Decl))); + if Nkind (Obj_Decl) = N_Object_Renaming_Declaration + and then Is_Class_Wide_Type (Obj_Typ) + and then Is_Displace_Call (Renamed_Object (Obj_Id)) + and then Nkind (Orig_Decl) = N_Object_Declaration + and then Comes_From_Source (Orig_Decl) + then + Orig_Expr := Expression (Orig_Decl); + + return + Is_Controlled_Function_Call (Orig_Expr) + or else Is_Controlled_Indexing (Orig_Expr) + or else Is_Source_Object (Orig_Expr); + end if; + + return False; end Is_Displacement_Of_Object_Or_Function_Result; ------------------------------