From patchwork Wed Aug 14 09:53:12 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1146892 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-506904-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="YlDadBXh"; 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 467lKR04cwz9sDQ for ; Wed, 14 Aug 2019 19:54:02 +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=nFOf2pKWjkIrtbHIE1bzc+9gC134kbM/bhBFYnNdPnUBdr1od5 uYb7ngpevIegCNUMteQg7vm+DRreBXmQ/s7wefZ8Rv96tiHZNvFn3GjXLkL/GLlJ 8sM6B09MuXbryybMFYI62sWUy97j3i4EJdQxrw+aLwly2wOwbXdZb7XII= 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=m9iFXTje3NgMagvdef7Kk5dYG/s=; b=YlDadBXhBea+wbXRfIk5 kvzhz328YTpoHGLoSge8yzcdgEeKwgJpsa9VXWj6bpuPsOcpHf8W3GmwKsvXR3DR 6Zby855ly4YrCjWdglmny4oLYgkvwECmz80n6LMzxIfj6pCgMMBhlu2TEz4+fLyq evDAdTn0HRRdI/epJOeF3j0= Received: (qmail 73242 invoked by alias); 14 Aug 2019 09:53:16 -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 73175 invoked by uid 89); 14 Aug 2019 09:53:16 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-10.6 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy=Node_Id, Present 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, 14 Aug 2019 09:53:13 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 6469556102; Wed, 14 Aug 2019 05:53:12 -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 Xx1zLh0EL66i; Wed, 14 Aug 2019 05:53:12 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 509A311626C; Wed, 14 Aug 2019 05:53:12 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 4F4E36CC; Wed, 14 Aug 2019 05:53:12 -0400 (EDT) Date: Wed, 14 Aug 2019 05:53:12 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [Ada] Fix discrepancy in mechanism tracking private and full views Message-ID: <20190814095312.GA51998@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes This fixes a discrepancy in the mechanism tracking the private and full views of entities when entering and leaving scopes. This mechanism records private entities that are dependent on other private entities, so that the exchange done on entering and leaving scopes can be propagated. The propagation is done recursively on entering child units, but it was not done recursively on leaving them, which would leave the dependency chains in a uncertain state in this case. That's mostly visible when inlining across units is enabled for code involving a lot of generic units. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-08-14 Eric Botcazou gcc/ada/ * sem_ch7.adb (Install_Private_Declarations) : Do not rely solely on the Is_Child_Unit flag on the unit to recurse. (Uninstall_Declarations) : New function. Use it to recurse on the private dependent entities for child units. gcc/testsuite/ * gnat.dg/inline18.adb, gnat.dg/inline18.ads, gnat.dg/inline18_gen1-inner_g.ads, gnat.dg/inline18_gen1.adb, gnat.dg/inline18_gen1.ads, gnat.dg/inline18_gen2.adb, gnat.dg/inline18_gen2.ads, gnat.dg/inline18_gen3.adb, gnat.dg/inline18_gen3.ads, gnat.dg/inline18_pkg1.adb, gnat.dg/inline18_pkg1.ads, gnat.dg/inline18_pkg2-child.ads, gnat.dg/inline18_pkg2.ads: New testcase. --- gcc/ada/sem_ch7.adb +++ gcc/ada/sem_ch7.adb @@ -2261,13 +2261,14 @@ package body Sem_Ch7 is procedure Swap_Private_Dependents (Priv_Deps : Elist_Id); -- When the full view of a private type is made available, we do the -- same for its private dependents under proper visibility conditions. - -- When compiling a grandchild unit this needs to be done recursively. + -- When compiling a child unit this needs to be done recursively. ----------------------------- -- Swap_Private_Dependents -- ----------------------------- procedure Swap_Private_Dependents (Priv_Deps : Elist_Id) is + Cunit : Entity_Id; Deps : Elist_Id; Priv : Entity_Id; Priv_Elmt : Elmt_Id; @@ -2285,6 +2286,7 @@ package body Sem_Ch7 is if Present (Full_View (Priv)) and then Is_Visible_Dependent (Priv) then if Is_Private_Type (Priv) then + Cunit := Cunit_Entity (Current_Sem_Unit); Deps := Private_Dependents (Priv); Is_Priv := True; else @@ -2312,11 +2314,14 @@ package body Sem_Ch7 is Set_Is_Potentially_Use_Visible (Priv, Is_Potentially_Use_Visible (Node (Priv_Elmt))); - -- Within a child unit, recurse, except in generic child unit, - -- which (unfortunately) handle private_dependents separately. + -- Recurse for child units, except in generic child units, + -- which unfortunately handle private_dependents separately. + -- Note that the current unit may not have been analyzed, + -- for example a package body, so we cannot rely solely on + -- the Is_Child_Unit flag, but that's only an optimization. if Is_Priv - and then Is_Child_Unit (Cunit_Entity (Current_Sem_Unit)) + and then (No (Etype (Cunit)) or else Is_Child_Unit (Cunit)) and then not Is_Empty_Elmt_List (Deps) and then not Inside_A_Generic then @@ -2701,13 +2706,16 @@ package body Sem_Ch7 is Decl : constant Node_Id := Unit_Declaration_Node (P); Id : Entity_Id; Full : Entity_Id; - Priv_Elmt : Elmt_Id; - Priv_Sub : Entity_Id; procedure Preserve_Full_Attributes (Priv : Entity_Id; Full : Entity_Id); -- Copy to the private declaration the attributes of the full view that -- need to be available for the partial view also. + procedure Swap_Private_Dependents (Priv_Deps : Elist_Id); + -- When the full view of a private type is made unavailable, we do the + -- same for its private dependents under proper visibility conditions. + -- When compiling a child unit this needs to be done recursively. + function Type_In_Use (T : Entity_Id) return Boolean; -- Check whether type or base type appear in an active use_type clause @@ -2826,6 +2834,66 @@ package body Sem_Ch7 is end if; end Preserve_Full_Attributes; + ----------------------------- + -- Swap_Private_Dependents -- + ----------------------------- + + procedure Swap_Private_Dependents (Priv_Deps : Elist_Id) is + Cunit : Entity_Id; + Deps : Elist_Id; + Priv : Entity_Id; + Priv_Elmt : Elmt_Id; + Is_Priv : Boolean; + + begin + Priv_Elmt := First_Elmt (Priv_Deps); + while Present (Priv_Elmt) loop + Priv := Node (Priv_Elmt); + + -- Before we do the swap, we verify the presence of the Full_View + -- field, which may be empty due to a swap by a previous call to + -- End_Package_Scope (e.g. from the freezing mechanism). + + if Present (Full_View (Priv)) then + if Is_Private_Type (Priv) then + Cunit := Cunit_Entity (Current_Sem_Unit); + Deps := Private_Dependents (Priv); + Is_Priv := True; + else + Is_Priv := False; + end if; + + if Scope (Priv) = P + or else not In_Open_Scopes (Scope (Priv)) + then + Set_Is_Immediately_Visible (Priv, False); + end if; + + if Is_Visible_Dependent (Priv) then + Preserve_Full_Attributes (Priv, Full_View (Priv)); + Replace_Elmt (Priv_Elmt, Full_View (Priv)); + Exchange_Declarations (Priv); + + -- Recurse for child units, except in generic child units, + -- which unfortunately handle private_dependents separately. + -- Note that the current unit may not have been analyzed, + -- for example a package body, so we cannot rely solely on + -- the Is_Child_Unit flag, but that's only an optimization. + + if Is_Priv + and then (No (Etype (Cunit)) or else Is_Child_Unit (Cunit)) + and then not Is_Empty_Elmt_List (Deps) + and then not Inside_A_Generic + then + Swap_Private_Dependents (Deps); + end if; + end if; + end if; + + Next_Elmt (Priv_Elmt); + end loop; + end Swap_Private_Dependents; + ----------------- -- Type_In_Use -- ----------------- @@ -3077,31 +3145,7 @@ package body Sem_Ch7 is -- were compiled in this scope, or installed previously -- by Install_Private_Declarations. - -- Before we do the swap, we verify the presence of the Full_View - -- field which may be empty due to a swap by a previous call to - -- End_Package_Scope (e.g. from the freezing mechanism). - - Priv_Elmt := First_Elmt (Private_Dependents (Id)); - while Present (Priv_Elmt) loop - Priv_Sub := Node (Priv_Elmt); - - if Present (Full_View (Priv_Sub)) then - if Scope (Priv_Sub) = P - or else not In_Open_Scopes (Scope (Priv_Sub)) - then - Set_Is_Immediately_Visible (Priv_Sub, False); - end if; - - if Is_Visible_Dependent (Priv_Sub) then - Preserve_Full_Attributes - (Priv_Sub, Full_View (Priv_Sub)); - Replace_Elmt (Priv_Elmt, Full_View (Priv_Sub)); - Exchange_Declarations (Priv_Sub); - end if; - end if; - - Next_Elmt (Priv_Elmt); - end loop; + Swap_Private_Dependents (Private_Dependents (Id)); -- Now restore the type itself to its private view --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/inline18.adb @@ -0,0 +1,6 @@ +-- { dg-do compile } +-- { dg-options "-O -gnatn" } + +package body Inline18 is + procedure Dummy is null; +end Inline18; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/inline18.ads @@ -0,0 +1,6 @@ +with Inline18_Pkg1; use Inline18_Pkg1; + +package Inline18 is + I : Integer := My_G.Next (0); + procedure Dummy; +end Inline18; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/inline18_gen1-inner_g.ads @@ -0,0 +1,8 @@ +generic +package Inline18_Gen1.Inner_G is + + type T is new Inline18_Gen1.T; + + Val : T; + +end Inline18_Gen1.Inner_G; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/inline18_gen1.adb @@ -0,0 +1,9 @@ +package body Inline18_Gen1 is + + function Complete return T is + Dummy : T; + begin + return Dummy; + end; + +end Inline18_Gen1; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/inline18_gen1.ads @@ -0,0 +1,14 @@ +generic + + type Bound_T is private; + +package Inline18_Gen1 is + + type T is private; + function Complete return T with Inline_Always; + +private + + type T is array (0 .. 1) of Bound_T; + +end Inline18_Gen1; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/inline18_gen2.adb @@ -0,0 +1,10 @@ +package body Inline18_Gen2 is + + function Func (I : Interval_T) return T is + pragma Unreferenced (I); + Dummy : T; + begin + return Dummy; + end; + +end Inline18_Gen2; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/inline18_gen2.ads @@ -0,0 +1,11 @@ +generic + + type Interval_T is private; + +package Inline18_Gen2 is + + type T is new Integer; + + function Func (I : Interval_T) return T; + +end Inline18_Gen2; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/inline18_gen3.adb @@ -0,0 +1,12 @@ +package body Inline18_Gen3 is + + package body Inner_G is + + function Next (Position : Index_T) return Index_T is + begin + return Position; + end; + + end Inner_G; + +end Inline18_Gen3; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/inline18_gen3.ads @@ -0,0 +1,13 @@ +generic + + type Index_T is range <>; + +package Inline18_Gen3 is + + generic + package Inner_G is + function Next (Position : Index_T) return Index_T; + pragma Inline (Next); + end Inner_G; + +end Inline18_Gen3; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/inline18_pkg1.adb @@ -0,0 +1,8 @@ +package body Inline18_Pkg1 is + + procedure Proc (R : in out Rec) is + begin + R.Comp := My_G2.Func (Inline18_Pkg2.Child.General.Val); + end; + +end Inline18_Pkg1; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/inline18_pkg1.ads @@ -0,0 +1,19 @@ +with Inline18_Pkg2.Child; +with Inline18_Gen2; +with Inline18_Gen3; + +package Inline18_Pkg1 is + + package My_G2 is new Inline18_Gen2 (Inline18_Pkg2.Child.General.T); + + package My_G3 is new Inline18_Gen3 (Integer); + + type Rec is record + Comp : My_G2.T; + end record; + + procedure Proc (R : in out Rec); + + package My_G is new My_G3.Inner_G; + +end Inline18_Pkg1; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/inline18_pkg2-child.ads @@ -0,0 +1,9 @@ +with Inline18_Gen1.Inner_G; + +package Inline18_Pkg2.Child is + + package Base is new Inline18_Gen1 (Integer); + + package General is new Base.Inner_G; + +end Inline18_Pkg2.Child; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/inline18_pkg2.ads @@ -0,0 +1,2 @@ +package Inline18_Pkg2 is +end Inline18_Pkg2;