From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 60970 invoked by alias); 22 May 2017 09:24:53 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 60958 invoked by uid 89); 22 May 2017 09:24:51 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-10.1 required=5.0 tests=AWL,BAYES_00,GIT_PATCH_2,GIT_PATCH_3,KAM_ASCII_DIVIDERS,RCVD_IN_DNSWL_NONE,SPF_PASS,T_FILL_THIS_FORM_SHORT autolearn=ham version=3.3.2 spammy=UD:ad, sk:limited, UD:T, Par X-HELO: smtp.eu.adacore.com Received: from mel.act-europe.fr (HELO smtp.eu.adacore.com) (194.98.77.210) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Mon, 22 May 2017 09:24:49 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 2792F8133F for ; Mon, 22 May 2017 11:24:50 +0200 (CEST) Received: from smtp.eu.adacore.com ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id uR4dkbmN7KEg for ; Mon, 22 May 2017 11:24:50 +0200 (CEST) Received: from polaris.localnet (bon31-6-88-161-99-133.fbx.proxad.net [88.161.99.133]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.eu.adacore.com (Postfix) with ESMTPSA id BA52C8133D for ; Mon, 22 May 2017 11:24:49 +0200 (CEST) From: Eric Botcazou To: gcc-patches@gcc.gnu.org Subject: [Ada] Remove restriction on inlining in related units Date: Mon, 22 May 2017 09:36:00 -0000 Message-ID: <6259223.Gfp2Ksldzo@polaris> User-Agent: KMail/4.14.10 (Linux/3.16.7-53-desktop; KDE/4.14.9; x86_64; ; ) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="nextPart20487680.TmrOh9lvxB" Content-Transfer-Encoding: 7Bit X-SW-Source: 2017-05/txt/msg01658.txt.bz2 This is a multi-part message in MIME format. --nextPart20487680.TmrOh9lvxB Content-Transfer-Encoding: 7Bit Content-Type: text/plain; charset="us-ascii" Content-length: 2371 This change makes it possible for the compiler to inline into a child package a subprogram declared in a parent package, even if the parent package has a with clause for the child package in the body. It also fixes segfaults that can occur when inlining into a package a subprogram coming from an unrelated package containing a Taft Amendment type that closes a dependency cycle with at least one member type declared in the first package. The following code must compile quietly with -O -gnatn -Winline: package Buf.Support is type Sup_T is new Integer; procedure Doit (Obj : T); end Buf.Support; package body Buf.Support is procedure Doit (Obj : T) is begin if Buf.Get_Support (Obj) > 100 then raise Program_Error; end if; end Doit; end Buf.Support; limited with Buf.Support; package Buf is type T is limited private; function Get_Support (Obj : T) return Buf.Support.Sup_T with Inline; private type T is new Integer; end Buf; with Buf.Support; package body Buf is function Get_Support (Obj : T) return Buf.Support.Sup_T is begin return Buf.Support.Sup_T (Obj + 1); end Get_Support; end Buf; Tested on x86_64-suse-linux, applied on the mainline. 2017-05-22 Ed Schonberg Eric Botcazou * sem_ch4.adb (Analyze_Call): In Ada2012 an incomplete type from a limited view may appear in the profile of a function, and a call to that function in another unit in which the full view is available must use this full view to spurious type errors at the point of call. * inline.adb (Analyze_Inlined_Bodies): Remove restriction on loading of parent body with a with clause for the main unit. * gcc-interface/decl.c (defer_limited_with_list): Document new usage. (gnat_to_gnu_entity) : Handle completed Taft Amendment types declared in external units like types from limited with clauses. Adjust final processing of defer_limited_with_list accordingly. * gcc-interface/trans.c (gnat_to_gnu) < N_Selected_Component>: Try again to translate the prefix after the field if it is incomplete. 2017-05-22 Eric Botcazou * gnat.dg/limited_with5.ad[sb]: New test. * gnat.dg/limited_with5_pkg.ad[sb]: New helper. * gnat.dg/limited_with6.ad[sb]: New test. * gnat.dg/limited_with6_pkg.ad[sb]: New helper. -- Eric Botcazou --nextPart20487680.TmrOh9lvxB Content-Disposition: attachment; filename="p.diff" Content-Transfer-Encoding: 7Bit Content-Type: text/x-patch; charset="UTF-8"; name="p.diff" Content-length: 11331 Index: gcc-interface/decl.c =================================================================== --- gcc-interface/decl.c (revision 248320) +++ gcc-interface/decl.c (working copy) @@ -101,8 +101,8 @@ struct incomplete static int defer_incomplete_level = 0; static struct incomplete *defer_incomplete_list; -/* This variable is used to delay expanding From_Limited_With types until the - end of the spec. */ +/* This variable is used to delay expanding types coming from a limited with + clause and completed Taft Amendment types until the end of the spec. */ static struct incomplete *defer_limited_with_list; typedef struct subst_pair_d { @@ -3580,6 +3580,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entit const bool is_from_limited_with = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind) && From_Limited_With (gnat_desig_equiv)); + /* Whether it is a completed Taft Amendment type. Such a type is to + be treated as coming from a limited with clause if it is not in + the main unit, i.e. we break potential circularities here in case + the body of an external unit is loaded for inter-unit inlining. */ + const bool is_completed_taft_type + = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind) + && Has_Completion_In_Body (gnat_desig_equiv) + && Present (Full_View (gnat_desig_equiv))); /* The "full view" of the designated type. If this is an incomplete entity from a limited with, treat its non-limited view as the full view. Otherwise, if this is an incomplete or private type, use the @@ -3646,13 +3654,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entit /* Get the type of the thing we are to point to and build a pointer to it. If it is a reference to an incomplete or private type with a - full view that is a record or an array, make a dummy type node and - get the actual type later when we have verified it is safe. */ + full view that is a record, an array or an access, make a dummy type + and get the actual type later when we have verified it is safe. */ else if ((!in_main_unit && !present_gnu_tree (gnat_desig_equiv) && Present (gnat_desig_full) && (Is_Record_Type (gnat_desig_full) - || Is_Array_Type (gnat_desig_full))) + || Is_Array_Type (gnat_desig_full) + || Is_Access_Type (gnat_desig_full))) /* Likewise if this is a reference to a record, an array or a subprogram type and we are to defer elaborating incomplete types. We do this because this access type may be the full @@ -3763,7 +3772,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entit save_gnu_tree (gnat_entity, gnu_decl, false); saved = true; - if (defer_incomplete_level == 0 && !is_from_limited_with) + if (defer_incomplete_level == 0 + && !is_from_limited_with + && !is_completed_taft_type) { update_pointer_to (TYPE_MAIN_VARIANT (gnu_desig_type), gnat_to_gnu_type (gnat_desig_equiv)); @@ -3772,7 +3783,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit { struct incomplete *p = XNEW (struct incomplete); struct incomplete **head - = (is_from_limited_with + = (is_from_limited_with || is_completed_taft_type ? &defer_limited_with_list : &defer_incomplete_list); p->old_type = gnu_desig_type; @@ -4766,7 +4777,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entit } for (p = defer_limited_with_list; p; p = p->next) - if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity) + if (p->old_type + && (Non_Limited_View (p->full_type) == gnat_entity + || Full_View (p->full_type) == gnat_entity)) { update_pointer_to (TYPE_MAIN_VARIANT (p->old_type), TREE_TYPE (gnu_decl)); Index: gcc-interface/trans.c =================================================================== --- gcc-interface/trans.c (revision 248140) +++ gcc-interface/trans.c (working copy) @@ -6413,7 +6413,6 @@ gnat_to_gnu (Node_Id gnat_node) Entity_Id gnat_prefix = Prefix (gnat_node); Entity_Id gnat_field = Entity (Selector_Name (gnat_node)); tree gnu_prefix = gnat_to_gnu (gnat_prefix); - tree gnu_field; gnu_prefix = maybe_implicit_deref (gnu_prefix); @@ -6442,8 +6441,19 @@ gnat_to_gnu (Node_Id gnat_node) NULL_TREE, gnu_prefix); else { - gnu_field = gnat_to_gnu_field_decl (gnat_field); + tree gnu_field = gnat_to_gnu_field_decl (gnat_field); + /* If the prefix has incomplete type, try again to translate it. + The idea is that the translation of the field just above may + have completed it through gnat_to_gnu_entity, in case it is + the dereference of an access to Taft Amendment type used in + the instantiation of a generic body from an external unit. */ + if (!COMPLETE_TYPE_P (TREE_TYPE (gnu_prefix))) + { + gnu_prefix = gnat_to_gnu (gnat_prefix); + gnu_prefix = maybe_implicit_deref (gnu_prefix); + } + gnu_result = build_component_ref (gnu_prefix, gnu_field, (Nkind (Parent (gnat_node)) Index: inline.adb =================================================================== --- inline.adb (revision 248140) +++ inline.adb (working copy) @@ -667,57 +667,6 @@ package body Inline is Table_Name => "Pending_Inlined"); -- The workpile used to compute the transitive closure - function Is_Ancestor_Of_Main - (U_Name : Entity_Id; - Nam : Node_Id) return Boolean; - -- Determine whether the unit whose body is loaded is an ancestor of - -- the main unit, and has a with_clause on it. The body is not - -- analyzed yet, so the check is purely lexical: the name of the with - -- clause is a selected component, and names of ancestors must match. - - ------------------------- - -- Is_Ancestor_Of_Main -- - ------------------------- - - function Is_Ancestor_Of_Main - (U_Name : Entity_Id; - Nam : Node_Id) return Boolean - is - Pref : Node_Id; - - begin - if Nkind (Nam) /= N_Selected_Component then - return False; - - else - if Chars (Selector_Name (Nam)) /= - Chars (Cunit_Entity (Main_Unit)) - then - return False; - end if; - - Pref := Prefix (Nam); - if Nkind (Pref) = N_Identifier then - - -- Par is an ancestor of Par.Child. - - return Chars (Pref) = Chars (U_Name); - - elsif Nkind (Pref) = N_Selected_Component - and then Chars (Selector_Name (Pref)) = Chars (U_Name) - then - -- Par.Child is an ancestor of Par.Child.Grand. - - return True; -- should check that ancestor match - - else - -- A is an ancestor of A.B.C if it is an ancestor of A.B - - return Is_Ancestor_Of_Main (U_Name, Pref); - end if; - end if; - end Is_Ancestor_Of_Main; - -- Start of processing for Analyze_Inlined_Bodies begin @@ -766,7 +715,7 @@ package body Inline is begin if not Is_Loaded (Bname) then Style_Check := False; - Load_Needed_Body (Comp_Unit, OK, Do_Analyze => False); + Load_Needed_Body (Comp_Unit, OK); if not OK then @@ -780,43 +729,6 @@ package body Inline is Error_Msg_File_1 := Get_File_Name (Bname, Subunit => False); Error_Msg_N ("\but file{ was not found!??", Comp_Unit); - - else - -- If the package to be inlined is an ancestor unit of - -- the main unit, and it has a semantic dependence on - -- it, the inlining cannot take place to prevent an - -- elaboration circularity. The desired body is not - -- analyzed yet, to prevent the completion of Taft - -- amendment types that would lead to elaboration - -- circularities in gigi. - - declare - U_Id : constant Entity_Id := - Defining_Entity (Unit (Comp_Unit)); - Body_Unit : constant Node_Id := - Library_Unit (Comp_Unit); - Item : Node_Id; - - begin - Item := First (Context_Items (Body_Unit)); - while Present (Item) loop - if Nkind (Item) = N_With_Clause - and then - Is_Ancestor_Of_Main (U_Id, Name (Item)) - then - Set_Is_Inlined (U_Id, False); - exit; - end if; - - Next (Item); - end loop; - - -- If no suspicious with_clauses, analyze the body - - if Is_Inlined (U_Id) then - Semantics (Body_Unit); - end if; - end; end if; end if; end; Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 248140) +++ sem_ch4.adb (working copy) @@ -1469,18 +1469,26 @@ package body Sem_Ch4 is -- can also happen when the function declaration appears before the -- full view of the type (which is legal in Ada 2012) and the call -- appears in a different unit, in which case the incomplete view - -- must be replaced with the full view to prevent subsequent type - -- errors. + -- must be replaced with the full view (or the non-limited view) + -- to prevent subsequent type errors. Note that the usual install/ + -- removal of limited_with clauses is not sufficient to handle this + -- case, because the limited view may have been captured is another + -- compilation unit that defines the current function. - if Is_Incomplete_Type (Etype (N)) - and then Present (Full_View (Etype (N))) - then - if Is_Entity_Name (Nam) then - Set_Etype (Nam, Full_View (Etype (N))); - Set_Etype (Entity (Nam), Full_View (Etype (N))); - end if; + if Is_Incomplete_Type (Etype (N)) then + if Present (Full_View (Etype (N))) then + if Is_Entity_Name (Nam) then + Set_Etype (Nam, Full_View (Etype (N))); + Set_Etype (Entity (Nam), Full_View (Etype (N))); + end if; + + Set_Etype (N, Full_View (Etype (N))); - Set_Etype (N, Full_View (Etype (N))); + elsif From_Limited_With (Etype (N)) + and then Present (Non_Limited_View (Etype (N))) + then + Set_Etype (N, Non_Limited_View (Etype (N))); + end if; end if; end if; end Analyze_Call; --nextPart20487680.TmrOh9lvxB Content-Disposition: attachment; filename="limited_with5.adb" Content-Transfer-Encoding: 7Bit Content-Type: text/x-adasrc; charset="UTF-8"; name="limited_with5.adb" Content-length: 290 -- { dg-do compile } -- { dg-options "-O -gnatn -Winline" } package body Limited_With5 is procedure Doit (Obj : Limited_With5_Pkg.T) is begin if Limited_With5_Pkg.Get_Expression_Support (Obj) > Sup_T'(100) then raise Program_Error; end if; end Doit; end Limited_With5; --nextPart20487680.TmrOh9lvxB Content-Disposition: attachment; filename="limited_with5.ads" Content-Transfer-Encoding: 7Bit Content-Type: text/x-adasrc; charset="UTF-8"; name="limited_with5.ads" Content-length: 144 with Limited_With5_Pkg; package Limited_With5 is type Sup_T is new Integer; procedure Doit (Obj : Limited_With5_Pkg.T); end Limited_With5; --nextPart20487680.TmrOh9lvxB Content-Disposition: attachment; filename="limited_with6.ads" Content-Transfer-Encoding: 7Bit Content-Type: text/x-adasrc; charset="UTF-8"; name="limited_with6.ads" Content-length: 216 with Limited_With6_Pkg; package Limited_With6 is type Sup_T is new Integer; procedure Doit (Obj : Limited_With6_Pkg.T); type Rec is record A : Limited_With6_Pkg.Taft_Ptr; end record; end Limited_With6; --nextPart20487680.TmrOh9lvxB Content-Disposition: attachment; filename="limited_with5_pkg.adb" Content-Transfer-Encoding: 7Bit Content-Type: text/x-adasrc; charset="UTF-8"; name="limited_with5_pkg.adb" Content-length: 232 with Limited_With5; package body Limited_With5_Pkg is function Get_Expression_Support (Obj : T) return Limited_With5.Sup_T is begin return Limited_With5.Sup_T (Obj + 1); end Get_Expression_Support; end Limited_With5_Pkg; --nextPart20487680.TmrOh9lvxB Content-Disposition: attachment; filename="limited_with5_pkg.ads" Content-Transfer-Encoding: 7Bit Content-Type: text/x-adasrc; charset="UTF-8"; name="limited_with5_pkg.ads" Content-length: 227 limited with Limited_With5; package Limited_With5_Pkg is type T is limited private; function Get_Expression_Support (Obj : T) return Limited_With5.Sup_T with Inline; private type T is new Integer; end Limited_With5_Pkg; --nextPart20487680.TmrOh9lvxB Content-Disposition: attachment; filename="limited_with6_pkg.adb" Content-Transfer-Encoding: 7Bit Content-Type: text/x-adasrc; charset="UTF-8"; name="limited_with6_pkg.adb" Content-length: 276 with Limited_With6; package body Limited_With6_Pkg is function Get_Expression_Support (Obj : T) return Limited_With6.Sup_T is begin return Limited_With6.Sup_T (Obj + 1); end Get_Expression_Support; type TT is access all Limited_With6.Rec; end Limited_With6_Pkg; --nextPart20487680.TmrOh9lvxB Content-Disposition: attachment; filename="limited_with6.adb" Content-Transfer-Encoding: 7Bit Content-Type: text/x-adasrc; charset="UTF-8"; name="limited_with6.adb" Content-length: 290 -- { dg-do compile } -- { dg-options "-O -gnatn -Winline" } package body Limited_With6 is procedure Doit (Obj : Limited_With6_Pkg.T) is begin if Limited_With6_Pkg.Get_Expression_Support (Obj) > Sup_T'(100) then raise Program_Error; end if; end Doit; end Limited_With6; --nextPart20487680.TmrOh9lvxB Content-Disposition: attachment; filename="limited_with6_pkg.ads" Content-Transfer-Encoding: 7Bit Content-Type: text/x-adasrc; charset="UTF-8"; name="limited_with6_pkg.ads" Content-length: 299 limited with Limited_With6; package Limited_With6_Pkg is type T is limited private; function Get_Expression_Support (Obj : T) return Limited_With6.Sup_T with Inline; type Taft_Ptr is private; private type T is new Integer; type TT; type Taft_Ptr is access TT; end Limited_With6_Pkg; --nextPart20487680.TmrOh9lvxB--