From patchwork Thu Mar 15 09:16:23 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 146868 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 3EC3BB6F9F for ; Thu, 15 Mar 2012 20:17:09 +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=1332407830; 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=hjPnq+5TJt+Gsm86fLAc azOFBg0=; b=lY5u5EZQ9rqrN0z2YWfAhWRylphCwvHmnyB81/3rQfyorfqA9RUQ 5ax7stYv/L+7f7bnyD0OLGT22lJjrcbX5pzVuf0bnSDrkiG8uR4py3tp3d5wnXFy pBmsFh0s+kcNsKCbHX8pbJQIDVpLR8dpc89L2HfZ2dCUkEfITzTuavQ= 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=aRcoJDZe2E7yxfRMBskgQsXah4GXZjrlb7Qj1gV+zishiPuVR49lrj8Mi1PgX6 xu2pUe70s25vQGmRy6mXXPnOSOJvVUUoNsAwp/5tBkhZkngJEVPymQOZb8nveg3+ 6DP3REAEmMbVIlNpyd6TRJdeYD9kBPD2kBjLlRZzIyjgY=; Received: (qmail 25174 invoked by alias); 15 Mar 2012 09:16:47 -0000 Received: (qmail 25000 invoked by uid 22791); 15 Mar 2012 09:16:41 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00 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; Thu, 15 Mar 2012 09:16:24 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id A05F31C6C1F; Thu, 15 Mar 2012 05:16:23 -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 jpHlo7B-PtVU; Thu, 15 Mar 2012 05:16:23 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 83D3B1C6C1C; Thu, 15 Mar 2012 05:16:23 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 7D78092BF6; Thu, 15 Mar 2012 05:16:23 -0400 (EDT) Date: Thu, 15 Mar 2012 05:16:23 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Bob Duff Subject: [Ada] Indirect calls in static elaboration model Message-ID: <20120315091623.GA12275@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 makes the static elaboration model more conservative in the case of indirect calls, by treating Subp'Access as a call for elaboration purposes. The following test should print 3, even when compiled with the binder switch -p, which enables pessimistic (worst-case) elaboration order. gnatmake -f a4 -bargs -p Expected output: warning: use of -p switch questionable warning: since all units compiled with static elaboration model 3 package a1 is function f return Integer; end a1; with a2; package body a1 is function f return integer is begin return a2.f; end; end a1; package a2 is function f return Integer; end a2; package body a2 is function Ident (X : Integer) return Integer is begin return X; end; Var : Integer := Ident (3); function f return Integer is begin return Var; end f; end a2; with a1; package a3 is type P is access function return Integer; PP : P := a1.f'Access; R : Integer := PP.all; end a3; with a3; with Text_IO; use Text_IO; procedure a4 is begin Put_Line (a3.R'Img); end; Tested on x86_64-pc-linux-gnu, committed on trunk 2012-03-15 Bob Duff * debug.adb: Add new debug switch -gnatd.U, which disables the support added below, in case someone trips over a cycle, and needs to disable this. * sem_attr.adb (Analyze_Access_Attribute): Treat Subp'Access as a call for elaboration purposes. * sem_elab.ads, sem_elab.adb (Check_Elab_Call): Add support for Subp'Access. Index: debug.adb =================================================================== --- debug.adb (revision 185390) +++ debug.adb (working copy) @@ -138,7 +138,7 @@ -- d.R -- d.S Force Optimize_Alignment (Space) -- d.T Force Optimize_Alignment (Time) - -- d.U + -- d.U Ignore indirect calls for static elaboration -- d.V -- d.W Print out debugging information for Walk_Library_Items -- d.X Use Expression_With_Actions @@ -642,6 +642,12 @@ -- d.T Force Optimize_Alignment (Time) mode as the default + -- d.U Ignore indirect calls for static elaboration. The static + -- elaboration model is conservative, especially regarding indirect + -- calls. If you say Proc'Access, it will assume you might call + -- Proc. This can cause elaboration cycles at bind time. This flag + -- reverts to the behavior of earlier compilers. + -- d.W Print out debugging information for Walk_Library_Items, including -- the order in which units are walked. This is primarily for use in -- debugging CodePeer mode. Index: sem_attr.adb =================================================================== --- sem_attr.adb (revision 185420) +++ sem_attr.adb (working copy) @@ -28,6 +28,7 @@ with Atree; use Atree; with Casing; use Casing; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Eval_Fat; @@ -54,6 +55,7 @@ with Sem_Ch10; use Sem_Ch10; with Sem_Dim; use Sem_Dim; with Sem_Dist; use Sem_Dist; +with Sem_Elab; use Sem_Elab; with Sem_Elim; use Sem_Elim; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; @@ -644,6 +646,13 @@ Kill_Current_Values; end if; + -- Treat as call for elaboration purposes and we are all + -- done. Suppress this treatment under debug flag. + + if not Debug_Flag_Dot_UU then + Check_Elab_Call (N); + end if; + return; -- Component is an operation of a protected type Index: sem_elab.adb =================================================================== --- sem_elab.adb (revision 185390) +++ sem_elab.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -180,7 +180,7 @@ Inter_Unit_Only : Boolean; Generate_Warnings : Boolean := True; In_Init_Proc : Boolean := False); - -- This is the internal recursive routine that is called to check for a + -- This is the internal recursive routine that is called to check for -- possible elaboration error. The argument N is a subprogram call or -- generic instantiation to be checked, and E is the entity of the called -- subprogram, or instantiated generic unit. The flag Outer_Scope is the @@ -188,8 +188,11 @@ -- call is only to be checked in the case where it is to another unit (and -- skipped if within a unit). Generate_Warnings is set to False to suppress -- warning messages about missing pragma Elaborate_All's. These messages - -- are not wanted for inner calls in the dynamic model. Flag In_Init_Proc - -- should be set whenever the current context is a type init proc. + -- are not wanted for inner calls in the dynamic model. Note that an + -- instance of the Access attribute applied to a subprogram also generates + -- a call to this procedure (since the referenced subprogram may be called + -- later indirectly). Flag In_Init_Proc should be set whenever the current + -- context is a type init proc. procedure Check_Bad_Instantiation (N : Node_Id); -- N is a node for an instantiation (if called with any other node kind, @@ -270,6 +273,13 @@ -- On entry C_Scope is set to some scope. On return, C_Scope is reset -- to be the enclosing compilation unit of this scope. + function Get_Referenced_Ent (N : Node_Id) return Entity_Id; + -- N is either a function or procedure call or an access attribute that + -- references a subprogram. This call retrieves the relevant entity. If + -- this is a call to a protected subprogram, the entity is a selected + -- component. The callable entity may be absent, in which case Empty is + -- returned. This happens with non-analyzed calls in nested generics. + procedure Set_Elaboration_Constraint (Call : Node_Id; Subp : Entity_Id; @@ -827,15 +837,20 @@ -- the init proc is in the root package, and we start from the entity -- of the name in the call. - if Is_Entity_Name (Name (N)) - and then Is_Init_Proc (Entity (Name (N))) - and then not In_Same_Extended_Unit (N, Entity (Name (N))) - then - W_Scope := Scope (Entity (Name (N))); - else - W_Scope := E; - end if; + declare + Ent : constant Entity_Id := Get_Referenced_Ent (N); + begin + if Is_Init_Proc (Ent) + and then not In_Same_Extended_Unit (N, Ent) + then + W_Scope := Scope (Ent); + else + W_Scope := E; + end if; + end; + -- Now loop through scopes to get to the enclosing compilation unit + while not Is_Compilation_Unit (W_Scope) loop W_Scope := Scope (W_Scope); end loop; @@ -1126,36 +1141,6 @@ Ent : Entity_Id; P : Node_Id; - function Get_Called_Ent return Entity_Id; - -- Retrieve called entity. If this is a call to a protected subprogram, - -- entity is a selected component. The callable entity may be absent, - -- in which case there is no check to perform. This happens with - -- non-analyzed calls in nested generics. - - -------------------- - -- Get_Called_Ent -- - -------------------- - - function Get_Called_Ent return Entity_Id is - Nam : Node_Id; - - begin - Nam := Name (N); - - if No (Nam) then - return Empty; - - elsif Nkind (Nam) = N_Selected_Component then - return Entity (Selector_Name (Nam)); - - elsif not Is_Entity_Name (Nam) then - return Empty; - - else - return Entity (Nam); - end if; - end Get_Called_Ent; - -- Start of processing for Check_Elab_Call begin @@ -1174,11 +1159,12 @@ then Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N); - -- Nothing to do if this is not a call (happens in some error - -- conditions, and in some cases where rewriting occurs). + -- Nothing to do if this is not a call or attribute reference (happens + -- in some error conditions, and in some cases where rewriting occurs). elsif Nkind (N) /= N_Function_Call and then Nkind (N) /= N_Procedure_Call_Statement + and then Nkind (N) /= N_Attribute_Reference then return; @@ -1267,6 +1253,7 @@ if Comes_From_Source (N) and then In_Preelaborated_Unit and then not In_Inlined_Body + and then Nkind (N) /= N_Attribute_Reference then -- This is a warning in GNAT mode allowing such calls to be -- used in the predefined library with appropriate care. @@ -1352,12 +1339,10 @@ elsif Dynamic_Elaboration_Checks then - -- This is a rather new check, going into version - -- 3.14a1 for the first time (V1.80 of this unit), so - -- we provide a debug flag to enable it. That way we - -- have an easy work around for regressions that are - -- caused by this new check. This debug flag can be - -- removed later. + -- We provide a debug flag to disable this check. That + -- way we have an easy work around for regressions + -- that are caused by this new check. This debug flag + -- can be removed later. if Debug_Flag_DD then return; @@ -1373,7 +1358,7 @@ -- but we need to capture local suppress pragmas -- that may inhibit checks on this call. - Ent := Get_Called_Ent; + Ent := Get_Referenced_Ent (N); if No (Ent) then return; @@ -1400,7 +1385,7 @@ end if; end if; - Ent := Get_Called_Ent; + Ent := Get_Referenced_Ent (N); if No (Ent) then return; @@ -2012,6 +1997,20 @@ return OK; + -- If we have an access attribute for a subprogram, check + -- it. Suppress this behavior under debug flag. + + elsif not Debug_Flag_Dot_UU + and then Nkind (N) = N_Attribute_Reference + and then (Attribute_Name (N) = Name_Access + or else + Attribute_Name (N) = Name_Unrestricted_Access) + and then Is_Entity_Name (Prefix (N)) + and then Is_Subprogram (Entity (Prefix (N))) + then + Check_Elab_Call (N, Outer_Scope); + return OK; + -- If we have a generic instantiation, check it elsif Nkind (N) in N_Generic_Instantiation then @@ -2605,6 +2604,34 @@ Set_Suppress_Elaboration_Warnings (Elab_Unit, True); end Set_Elaboration_Constraint; + ------------------------ + -- Get_Referenced_Ent -- + ------------------------ + + function Get_Referenced_Ent (N : Node_Id) return Entity_Id is + Nam : Node_Id; + + begin + if Nkind (N) = N_Attribute_Reference then + Nam := Prefix (N); + else + Nam := Name (N); + end if; + + if No (Nam) then + return Empty; + + elsif Nkind (Nam) = N_Selected_Component then + return Entity (Selector_Name (Nam)); + + elsif not Is_Entity_Name (Nam) then + return Empty; + + else + return Entity (Nam); + end if; + end Get_Referenced_Ent; + ---------------------- -- Has_Generic_Body -- ---------------------- Index: sem_elab.ads =================================================================== --- sem_elab.ads (revision 185390) +++ sem_elab.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -122,8 +122,9 @@ (N : Node_Id; Outer_Scope : Entity_Id := Empty; In_Init_Proc : Boolean := False); - -- Check a call for possible elaboration problems. The node N is either - -- an N_Function_Call or N_Procedure_Call_Statement node. The Outer_Scope + -- Check a call for possible elaboration problems. The node N is either an + -- N_Function_Call or N_Procedure_Call_Statement node or an access + -- attribute reference whose prefix is a subprogram. The Outer_Scope -- argument indicates whether this is an outer level call from Sem_Res -- (Outer_Scope set to Empty), or an internal recursive call (Outer_Scope -- set to entity of outermost call, see body). Flag In_Init_Proc should be