From patchwork Mon May 30 08:32:39 2022 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: 54499 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 9B7B33815FF7 for ; Mon, 30 May 2022 08:40:04 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 9B7B33815FF7 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1653900004; bh=7OsakUH9P5Qq3/2ucEPcksPV0zcFthU2Isk3GElctEU=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=yTktsepu+v/xqrP2KuWA/ZTqekhlhgQggulpiXnh8qN5bq1LP+7RvC09fnnc4cxsu ZM6Jb1N6nc8kwRvVH09iJLjmAX/aLlGO4GTh2H8IRGWdjDwP9rZPg9ltpoKKpSKeN0 L8V0sWY0CLcGvuCXGgYAWafAoFEgfB2TC4V53tgc= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42b.google.com (mail-wr1-x42b.google.com [IPv6:2a00:1450:4864:20::42b]) by sourceware.org (Postfix) with ESMTPS id 0F1DA389C45C for ; Mon, 30 May 2022 08:32:41 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 0F1DA389C45C Received: by mail-wr1-x42b.google.com with SMTP id q21so2410009wra.2 for ; Mon, 30 May 2022 01:32:41 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition; bh=7OsakUH9P5Qq3/2ucEPcksPV0zcFthU2Isk3GElctEU=; b=gQufWoVPav3h8JOZXn1R0qDjcMLWVp9+jBRcMrrdmUQGcUVEnih4ptzLbFwDvsl/1r O621gTPJdFKtUcUHC208hsnanvuwRHRxaFa17DwTt3joqRiwT/yLUCfAfc7z9Mt+sNqf JBj1D2Obws+U3z2KwrMF3416Uc/zJlY0bLrOuL34MG1IeI3zXJ5pW8UPYIz7gOj6H68p K+T82wpAwNvva/AswZejr886ygvklN7BLMZs3DlCEgLzoFww0uMFfzZbtCMGvTnqolDV yNLuO0FlbTJbNW38L+W8dAdHXLib6uDvpt8uyf61m1yxd5tuUz/LU5TvP0wFJU2FgfGx gSSQ== X-Gm-Message-State: AOAM5309uMyFg6BxMN/Qltflz2eVUF8Q5MVfqaHkqO9S6t/G38C2GW2z rbuRRqZrecu8KAzHZetG6ggQoDtsUJgxWw== X-Google-Smtp-Source: ABdhPJz9jRIgxPCj4grTWSG9x+4X6nF55jNmMdcK0H+V1dzdKNkK/Q8J1+QX8nKod9n30B4w+PojKA== X-Received: by 2002:adf:d08d:0:b0:20f:fb5a:6b43 with SMTP id y13-20020adfd08d000000b0020ffb5a6b43mr22294414wrh.637.1653899559909; Mon, 30 May 2022 01:32:39 -0700 (PDT) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id k32-20020a05600c1ca000b003975c7058bfsm9543355wms.12.2022.05.30.01.32.39 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 30 May 2022 01:32:39 -0700 (PDT) Date: Mon, 30 May 2022 08:32:39 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Do not freeze profiles for dispatch tables Message-ID: <20220530083239.GA210652@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-12.9 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Pierre-Marie de Rodat via Gcc-patches From: Pierre-Marie de Rodat Reply-To: Pierre-Marie de Rodat Cc: Eric Botcazou Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" When static dispatch tables are built for library-level tagged types, the primitives (the subprogram themselves) are frozen; that's necessary because their address is taken. However, their profile, i.e. all the types present therein, is also frozen, which is not necessary after AI05-019 and is also inconsistent with the handling of attribute references. The change also removes a couple of pragma Inline on subprograms that are too large for inlining to bring any benefit. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_ch3.adb (Expand_N_Object_Declaration): Adjust call to Make_DT. * exp_disp.ads (Building_Static_DT): Remove pragma Inline. (Building_Static_Secondary_DT): Likewise. (Convert_Tag_To_Interface): Likewise. (Make_DT): Remove second parameter. * exp_disp.adb (Make_DT): Likewise. (Check_Premature_Freezing): Delete. Pass Do_Freeze_Profile as False in call to Freeze_Entity. * freeze.ads (Freezing_Library_Level_Tagged_Type): Delete. * freeze.adb (Freeze_Profile): Remove obsolete code. (Freeze_Entity): Tweak comment. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6909,9 +6909,9 @@ package body Exp_Ch3 is begin if Is_Concurrent_Type (Base_Typ) then - New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N); + New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ)); else - New_Nodes := Make_DT (Base_Typ, N); + New_Nodes := Make_DT (Base_Typ); end if; Insert_List_Before (N, New_Nodes); diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -3660,7 +3660,7 @@ package body Exp_Disp is -- replaced by gotos which jump to the end of the routine and restore the -- Ghost mode. - function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is + function Make_DT (Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Typ); Max_Predef_Prims : constant Int := @@ -3678,23 +3678,6 @@ package body Exp_Disp is -- offset to the components that reference secondary dispatch tables. -- Used to compute the offset of components located at fixed position. - procedure Check_Premature_Freezing - (Subp : Entity_Id; - Tagged_Type : Entity_Id; - Typ : Entity_Id); - -- Verify that all untagged types in the profile of a subprogram are - -- frozen at the point the subprogram is frozen. This enforces the rule - -- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram - -- is frozen, enough must be known about it to build the activation - -- record for it, which requires at least that the size of all - -- parameters be known. Controlling arguments are by-reference, - -- and therefore the rule only applies to untagged types. Typical - -- violation of the rule involves an object declaration that freezes a - -- tagged type, when one of its primitive operations has a type in its - -- profile whose full view has not been analyzed yet. More complex cases - -- involve composite types that have one private unfrozen subcomponent. - -- Move this check to sem??? - procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0); -- Export the dispatch table DT of tagged type Typ. Required to generate -- forward references and statically allocate the table. For primary @@ -3733,103 +3716,6 @@ package body Exp_Disp is function Number_Of_Predefined_Prims (Typ : Entity_Id) return Nat; -- Returns the number of predefined primitives of Typ - ------------------------------ - -- Check_Premature_Freezing -- - ------------------------------ - - procedure Check_Premature_Freezing - (Subp : Entity_Id; - Tagged_Type : Entity_Id; - Typ : Entity_Id) - is - Comp : Entity_Id; - - function Is_Actual_For_Formal_Incomplete_Type - (T : Entity_Id) return Boolean; - -- In Ada 2012, if a nested generic has an incomplete formal type, - -- the actual may be (and usually is) a private type whose completion - -- appears later. It is safe to build the dispatch table in this - -- case, gigi will have full views available. - - ------------------------------------------ - -- Is_Actual_For_Formal_Incomplete_Type -- - ------------------------------------------ - - function Is_Actual_For_Formal_Incomplete_Type - (T : Entity_Id) return Boolean - is - Gen_Par : Entity_Id; - F : Node_Id; - - begin - if not Is_Generic_Instance (Current_Scope) - or else not Used_As_Generic_Actual (T) - then - return False; - else - Gen_Par := Generic_Parent (Parent (Current_Scope)); - end if; - - F := - First - (Generic_Formal_Declarations - (Unit_Declaration_Node (Gen_Par))); - while Present (F) loop - if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then - return True; - end if; - - Next (F); - end loop; - - return False; - end Is_Actual_For_Formal_Incomplete_Type; - - -- Start of processing for Check_Premature_Freezing - - begin - -- Note that if the type is a (subtype of) a generic actual, the - -- actual will have been frozen by the instantiation. - - if Present (N) - and then Is_Private_Type (Typ) - and then No (Full_View (Typ)) - and then not Has_Private_Declaration (Typ) - and then not Is_Generic_Type (Typ) - and then not Is_Tagged_Type (Typ) - and then not Is_Frozen (Typ) - and then not Is_Generic_Actual_Type (Typ) - then - Error_Msg_Sloc := Sloc (Subp); - Error_Msg_NE - ("declaration must appear after completion of type &", N, Typ); - Error_Msg_NE - ("\which is an untagged type in the profile of " - & "primitive operation & declared#", N, Subp); - - else - Comp := Private_Component (Typ); - - if not Is_Tagged_Type (Typ) - and then Present (Comp) - and then not Is_Frozen (Comp) - and then not Has_Private_Declaration (Comp) - and then not Is_Actual_For_Formal_Incomplete_Type (Comp) - then - Error_Msg_Sloc := Sloc (Subp); - Error_Msg_NE - ("declaration must appear after completion of type &", - N, Comp); - Error_Msg_Node_2 := Subp; - Error_Msg_Name_1 := Chars (Tagged_Type); - Error_Msg_NE - ("\which is a component of untagged type& in the profile " - & "of primitive & of type % that is frozen by the " - & "declaration", N, Typ); - end if; - end if; - end Check_Premature_Freezing; - --------------- -- Export_DT -- --------------- @@ -4584,55 +4470,31 @@ package body Exp_Disp is end if; -- Ensure that all the primitives are frozen. This is only required when - -- building static dispatch tables --- the primitives must be frozen to - -- be referenced (otherwise we have problems with the backend). It is + -- building static dispatch tables: the primitives must be frozen to be + -- referenced, otherwise we have problems with the back end. But this is -- not a requirement with nonstatic dispatch tables because in this case - -- we generate now an empty dispatch table; the extra code required to - -- register the primitives in the slots will be generated later --- when - -- each primitive is frozen (see Freeze_Subprogram). + -- we generate an empty dispatch table at this point and the extra code + -- required to register the primitives in their slot will be generated + -- later, when each primitive is frozen (see Freeze_Subprogram). if Building_Static_DT (Typ) then declare - Saved_FLLTT : constant Boolean := - Freezing_Library_Level_Tagged_Type; - - Formal : Entity_Id; - Frnodes : List_Id; + F_List : List_Id; Prim : Entity_Id; Prim_Elmt : Elmt_Id; begin - Freezing_Library_Level_Tagged_Type := True; - Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop - Prim := Node (Prim_Elmt); - Frnodes := Freeze_Entity (Prim, Typ); - - -- We disable this check for abstract subprograms, given that - -- they cannot be called directly and thus the state of their - -- untagged formals is of no concern. The RM is unclear in any - -- case concerning the need for this check, and this topic may - -- go back to the ARG. - - if not Is_Abstract_Subprogram (Prim) then - Formal := First_Formal (Prim); - while Present (Formal) loop - Check_Premature_Freezing (Prim, Typ, Etype (Formal)); - Next_Formal (Formal); - end loop; - - Check_Premature_Freezing (Prim, Typ, Etype (Prim)); - end if; + Prim := Node (Prim_Elmt); + F_List := Freeze_Entity (Prim, Typ, Do_Freeze_Profile => False); - if Present (Frnodes) then - Append_List_To (Result, Frnodes); + if Present (F_List) then + Append_List_To (Result, F_List); end if; Next_Elmt (Prim_Elmt); end loop; - - Freezing_Library_Level_Tagged_Type := Saved_FLLTT; end; end if; diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -168,11 +168,9 @@ package Exp_Disp is -- Generate checks required on dispatching calls function Building_Static_DT (Typ : Entity_Id) return Boolean; - pragma Inline (Building_Static_DT); -- Returns true when building statically allocated dispatch tables function Building_Static_Secondary_DT (Typ : Entity_Id) return Boolean; - pragma Inline (Building_Static_Secondary_DT); -- Returns true when building statically allocated secondary dispatch -- tables @@ -187,7 +185,6 @@ package Exp_Disp is function Convert_Tag_To_Interface (Typ : Entity_Id; Expr : Node_Id) return Node_Id; - pragma Inline (Convert_Tag_To_Interface); -- This function is used in class-wide interface conversions; the expanded -- code generated to convert a tagged object to a class-wide interface type -- involves referencing the tag component containing the secondary dispatch @@ -256,11 +253,8 @@ package Exp_Disp is function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean; -- Returns true if N is the expanded code of a dispatching call - function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id; - -- Expand the declarations for the Dispatch Table. The node N is the - -- declaration that forces the generation of the table. It is used to place - -- error messages when the declaration leads to the freezing of a given - -- primitive operation that has an incomplete non- tagged formal. + function Make_DT (Typ : Entity_Id) return List_Id; + -- Expand the declarations for the Dispatch Table of Typ function Make_Disp_Asynchronous_Select_Body (Typ : Entity_Id) return Node_Id; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4631,9 +4631,7 @@ package body Freeze is Result := No_List; return False; - elsif not After_Last_Declaration - and then not Freezing_Library_Level_Tagged_Type - then + elsif not After_Last_Declaration then Error_Msg_NE ("type & must be fully defined before this point", N, @@ -4751,17 +4749,6 @@ package body Freeze is if Is_Access_Type (F_Type) then F_Type := Designated_Type (F_Type); end if; - - -- If the formal is an anonymous_access_to_subprogram - -- freeze the subprogram type as well, to prevent - -- scope anomalies in gigi, because there is no other - -- clear point at which it could be frozen. - - if Is_Itype (Etype (Formal)) - and then Ekind (F_Type) = E_Subprogram_Type - then - Freeze_And_Append (F_Type, N, Result); - end if; end if; Next_Formal (Formal); @@ -6490,9 +6477,10 @@ package body Freeze is -- In Ada 2012, freezing a subprogram does not always freeze the -- corresponding profile (see AI05-019). An attribute reference - -- is not a freezing point of the profile. Flag Do_Freeze_Profile + -- is not a freezing point of the profile. Similarly, we do not + -- freeze the profile of primitives of a library-level tagged type + -- when we are building its dispatch table. Flag Do_Freeze_Profile -- indicates whether the profile should be frozen now. - -- Other constructs that should not freeze ??? -- This processing doesn't apply to internal entities (see below) diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads --- a/gcc/ada/freeze.ads +++ b/gcc/ada/freeze.ads @@ -120,12 +120,6 @@ package Freeze is -- where the freeze node is preallocated at the point of declaration, so -- that the First_Subtype_Link field can be set. - Freezing_Library_Level_Tagged_Type : Boolean := False; - -- Flag used to indicate that we are freezing the primitives of a library - -- level tagged type. Used to disable checks on premature freezing. - -- More documentation needed??? why is this flag needed? what are these - -- checks? why do they need disabling in some cases? - ----------------- -- Subprograms -- -----------------