From patchwork Mon Jul 9 13:15:38 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 169826 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 6CDB02C0994 for ; Mon, 9 Jul 2012 23:16:30 +1000 (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=1342444590; 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=plTVAiIvNbJuWVxiJB2m Gaj4mM8=; b=eoyS8FxIbGiANCPCP8IFIJtbQsrUW/+eBJWlmK6jReZik1iJaNOc CtJR81F3cX11vVgBorhCpogu2vRv3DIyMhQUmAh1FXX8N30FFx69x0vwNH2gdYRg kdqyHRH9uorZctSStvWK5c2nsceEbU320Lc/e5vGG+GLZ2X+sAweIDQ= 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=w6jlLV7X5QjeidTkvnP9G43q47nDrwcr0ANnRCOcLzrjKPvr2PwNfUyIbFYuaK BSivS8qhsnnSvwPqqvP6Yijf9HqDeFqOwFzyqN+K8czuHwM3BxSmD/L0FDQWP+Pj QIpqFkSpa6dfcqh36gxiiZGciDz8QK8UXphUVazo/51ns=; Received: (qmail 27569 invoked by alias); 9 Jul 2012 13:16:16 -0000 Received: (qmail 27237 invoked by uid 22791); 9 Jul 2012 13:16:07 -0000 X-SWARE-Spam-Status: No, hits=-1.9 required=5.0 tests=AWL, BAYES_00, RCVD_IN_HOSTKARMA_NO 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; Mon, 09 Jul 2012 13:15:39 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id DC2521C68F1; Mon, 9 Jul 2012 09:15:38 -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 8D6IeTcLUHwR; Mon, 9 Jul 2012 09:15:38 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id BDA321C67F4; Mon, 9 Jul 2012 09:15:38 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id BB0D692BF6; Mon, 9 Jul 2012 09:15:38 -0400 (EDT) Date: Mon, 9 Jul 2012 09:15:38 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Vincent Pucci Subject: [Ada] Lock_Free implementation for protected object Message-ID: <20120709131538.GA27296@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 reorganizes the Lock_Free restrictions. The compiler issues a warning whenever a Priority aspect/pragma is given while the lock-free implementation has been forced by an aspect/pragma. ------------ -- Source -- ------------ package T is protected type P1 with Lock_Free is pragma Priority (1); end P1; end T; ----------------- -- Compilation -- ----------------- gnatmake -q -gnat12 t.ads ------------ -- Output -- ------------ t.ads:5:07: warning: pragma "Priority" for "P1" has no effect when Lock_Free given gnatmake: "t.ads" compilation error Tested on x86_64-pc-linux-gnu, committed on trunk 2012-07-09 Vincent Pucci * sem_ch9.adb (Allows_Lock_Free_Implementation): type must support atomic operation moved to the protected body case. No non-elementary out parameter moved to the protected declaration case. Functions have only one lock-free restriction. (Analyze_Protected_Type_Declaration): Issue a warning when Priority given with Lock_Free. Index: sem_ch9.adb =================================================================== --- sem_ch9.adb (revision 189367) +++ sem_ch9.adb (working copy) @@ -139,87 +139,69 @@ Priv_Decls : constant List_Id := Private_Declarations (Pdef); Vis_Decls : constant List_Id := Visible_Declarations (Pdef); - Comp_Id : Entity_Id; - Comp_Size : Int; - Comp_Type : Entity_Id; - Decl : Node_Id; + Decl : Node_Id; begin - -- Examine the visible declarations. Entries and entry families - -- are not allowed by the lock-free restrictions. + -- Examine the visible and the private declarations Decl := First (Vis_Decls); while Present (Decl) loop + + -- Entries and entry families are not allowed by the lock-free + -- restrictions. + if Nkind (Decl) = N_Entry_Declaration then if Complain then - Error_Msg_N ("entry not allowed for lock-free " & - "implementation", + Error_Msg_N ("entry not allowed when Lock_Free given", Decl); end if; return False; - end if; - Next (Decl); - end loop; + -- Non-elementary out parameters in protected procedure are not + -- allowed by the lock-free restrictions. - -- Examine the private declarations + elsif Nkind (Decl) = N_Subprogram_Declaration + and then Nkind (Specification (Decl)) = + N_Procedure_Specification + and then Present + (Parameter_Specifications (Specification (Decl))) + then + declare + Par_Specs : constant List_Id := + Parameter_Specifications + (Specification (Decl)); + Par : constant Node_Id := First (Par_Specs); + Par_Typ : constant Entity_Id := + Etype (Parameter_Type (Par)); - Decl := First (Priv_Decls); - while Present (Decl) loop - - -- The protected type must define at least one scalar component - - if Nkind (Decl) = N_Component_Declaration then - Comp_Id := Defining_Identifier (Decl); - Comp_Type := Etype (Comp_Id); - - -- Make sure the protected component type has size and - -- alignment fields set at this point whenever this is - -- possible. - - Layout_Type (Comp_Type); - - if Known_Esize (Comp_Type) then - Comp_Size := UI_To_Int (Esize (Comp_Type)); - - -- If the Esize (Object_Size) is unknown at compile-time, - -- look at the RM_Size (Value_Size) since it may have been - -- set by an explicit representation clause. - - else - Comp_Size := UI_To_Int (RM_Size (Comp_Type)); - end if; - - -- Check that the size of the component is 8, 16, 32 or 64 - -- bits. - - case Comp_Size is - when 8 | 16 | 32 | 64 => - null; - when others => + begin + if Out_Present (Par) + and then not Is_Elementary_Type (Par_Typ) + then if Complain then - Error_Msg_N ("must support atomic operations for " & - "lock-free implementation", - Decl); + Error_Msg_NE + ("non-elementary out parameter& not allowed " & + "when Lock_Free given", + Par, + Defining_Identifier (Par)); end if; return False; - end case; + end if; + end; + end if; - -- Entries and entry families are not allowed + -- Examine the private declarations after the visible + -- declarations. - elsif Nkind (Decl) = N_Entry_Declaration then - if Complain then - Error_Msg_N ("entry not allowed for lock-free " & - "implementation", - Decl); - end if; - - return False; + if No (Next (Decl)) + and then List_Containing (Decl) = Vis_Decls + then + Decl := First (Priv_Decls); + else + Next (Decl); end if; - - Next (Decl); end loop; end; @@ -248,6 +230,11 @@ function Satisfies_Lock_Free_Requirements (Sub_Body : Node_Id) return Boolean is + Is_Procedure : constant Boolean := + Ekind (Corresponding_Spec (Sub_Body)) = + E_Procedure; + -- Indicates if Sub_Body is a procedure body + Comp : Entity_Id := Empty; -- Track the current component which the body references @@ -260,152 +247,160 @@ function Check_Node (N : Node_Id) return Traverse_Result is begin - -- Function calls and attribute references must be static + if Is_Procedure then + -- Function calls and attribute references must be static - if Nkind (N) = N_Attribute_Reference - and then not Is_Static_Expression (N) - then - if Complain then - Error_Msg_N - ("non-static attribute reference not allowed", - N); - end if; + if Nkind (N) = N_Attribute_Reference + and then not Is_Static_Expression (N) + then + if Complain then + Error_Msg_N + ("non-static attribute reference not allowed", N); + end if; - return Abandon; + return Abandon; - elsif Nkind (N) = N_Function_Call - and then not Is_Static_Expression (N) - then - if Complain then - Error_Msg_N ("non-static function call not allowed", - N); - end if; + elsif Nkind (N) = N_Function_Call + and then not Is_Static_Expression (N) + then + if Complain then + Error_Msg_N ("non-static function call not allowed", + N); + end if; - return Abandon; + return Abandon; - -- Loop statements and procedure calls are prohibited + -- Loop statements and procedure calls are prohibited - elsif Nkind (N) = N_Loop_Statement then - if Complain then - Error_Msg_N ("loop not allowed", N); - end if; + elsif Nkind (N) = N_Loop_Statement then + if Complain then + Error_Msg_N ("loop not allowed", N); + end if; - return Abandon; + return Abandon; - elsif Nkind (N) = N_Procedure_Call_Statement then - if Complain then - Error_Msg_N ("procedure call not allowed", N); + elsif Nkind (N) = N_Procedure_Call_Statement then + if Complain then + Error_Msg_N ("procedure call not allowed", N); + end if; + + return Abandon; + + -- References + + elsif Nkind (N) = N_Identifier + and then Present (Entity (N)) + then + declare + Id : constant Entity_Id := Entity (N); + Sub_Id : constant Entity_Id := + Corresponding_Spec (Sub_Body); + + begin + -- Prohibit references to non-constant entities + -- outside the protected subprogram scope. + + if Ekind (Id) in Assignable_Kind + and then not Scope_Within_Or_Same (Scope (Id), + Sub_Id) + and then not Scope_Within_Or_Same (Scope (Id), + Protected_Body_Subprogram (Sub_Id)) + then + if Complain then + Error_Msg_NE + ("reference to global variable& not " & + "allowed", N, Id); + end if; + + return Abandon; + end if; + end; end if; + end if; - return Abandon; + -- A protected subprogram (function or procedure) may + -- reference only one component of the protected type, plus + -- the type of the component must support atomic operation. - -- References - - elsif Nkind (N) = N_Identifier + if Nkind (N) = N_Identifier and then Present (Entity (N)) then declare - Id : constant Entity_Id := Entity (N); - Sub_Id : constant Entity_Id := - Corresponding_Spec (Sub_Body); + Id : constant Entity_Id := Entity (N); + Comp_Decl : Node_Id; + Comp_Id : Entity_Id := Empty; + Comp_Size : Int; + Comp_Type : Entity_Id; begin - -- Prohibit references to non-constant entities - -- outside the protected subprogram scope. + if Ekind (Id) = E_Component then + Comp_Id := Id; - if Ekind (Id) in Assignable_Kind - and then not Scope_Within_Or_Same (Scope (Id), - Sub_Id) - and then not Scope_Within_Or_Same (Scope (Id), - Protected_Body_Subprogram (Sub_Id)) + elsif Ekind_In (Id, E_Constant, E_Variable) + and then Present (Prival_Link (Id)) then - if Complain then - Error_Msg_NE - ("reference to global variable& not allowed", - N, Id); - end if; + Comp_Id := Prival_Link (Id); + end if; - return Abandon; + if Present (Comp_Id) then + Comp_Decl := Parent (Comp_Id); + Comp_Type := Etype (Comp_Id); - -- Prohibit non-scalar out parameters (scalar - -- parameters are passed by copy). + if Nkind (Comp_Decl) = N_Component_Declaration + and then Is_List_Member (Comp_Decl) + and then List_Containing (Comp_Decl) = Priv_Decls + then + -- Make sure the protected component type has + -- size and alignment fields set at this point + -- whenever this is possible. - elsif Ekind_In (Id, E_Out_Parameter, - E_In_Out_Parameter) - and then not Is_Elementary_Type (Etype (Id)) - and then Scope_Within_Or_Same (Scope (Id), Sub_Id) - then - if Complain then - Error_Msg_NE - ("non-elementary out parameter& not allowed", - N, Id); - end if; + Layout_Type (Comp_Type); - return Abandon; + if Known_Esize (Comp_Type) then + Comp_Size := UI_To_Int (Esize (Comp_Type)); - -- A protected subprogram may reference only one - -- component of the protected type. + -- If the Esize (Object_Size) is unknown at + -- compile-time, look at the RM_Size + -- (Value_Size) since it may have been set by an + -- explicit representation clause. - elsif Ekind (Id) = E_Component then - declare - Comp_Decl : constant Node_Id := Parent (Id); - begin - if Nkind (Comp_Decl) = N_Component_Declaration - and then Is_List_Member (Comp_Decl) - and then List_Containing (Comp_Decl) = - Priv_Decls - then - if No (Comp) then - Comp := Id; + else + Comp_Size := UI_To_Int (RM_Size (Comp_Type)); + end if; - -- Check if another protected component has - -- already been accessed by the subprogram - -- body. + -- Check that the size of the component is 8, + -- 16, 32 or 64 bits. - elsif Comp /= Id then + case Comp_Size is + when 8 | 16 | 32 | 64 => + null; + when others => if Complain then - Error_Msg_N - ("only one protected component " & - "allowed", - N); + Error_Msg_NE + ("type of& must support atomic " & + "operations", + N, Comp_Id); end if; return Abandon; - end if; - end if; - end; + end case; - elsif Ekind_In (Id, E_Constant, E_Variable) - and then Present (Prival_Link (Id)) - then - declare - Comp_Decl : constant Node_Id := - Parent (Prival_Link (Id)); - begin - if Nkind (Comp_Decl) = N_Component_Declaration - and then Is_List_Member (Comp_Decl) - and then List_Containing (Comp_Decl) = - Priv_Decls - then - if No (Comp) then - Comp := Prival_Link (Id); + -- Check if another protected component has + -- already been accessed by the subprogram body. - -- Check if another protected component has - -- already been accessed by the subprogram - -- body. + if No (Comp) then + Comp := Id; - elsif Comp /= Prival_Link (Id) then - if Complain then - Error_Msg_N - ("only one protected component " & - "allowed", - N); - end if; + elsif Comp /= Id then + if Complain then + Error_Msg_N + ("only one protected component allowed", + N); + end if; - return Abandon; - end if; + return Abandon; end if; - end; + end if; end if; end; end if; @@ -444,7 +439,7 @@ and then not Satisfies_Lock_Free_Requirements (Decl) then if Complain then - Error_Msg_N ("body prevents lock-free implementation", + Error_Msg_N ("body not allowed when Lock_Free given", Decl); end if; @@ -1787,6 +1782,43 @@ -- issued by Allows_Lock_Free_Implementation. if Uses_Lock_Free (Defining_Identifier (N)) then + -- Complain when there is an explicit aspect/pragma Priority (or + -- Interrupt_Priority) while the lock-free implementation is forced + -- by an aspect/pragma. + + declare + Id : constant Entity_Id := + Defining_Identifier (Original_Node (N)); + -- The warning must be issued on the original identifier in order + -- to deal properly with the case of a single protected object. + + Prio_Item : constant Node_Id := + Get_Rep_Item + (Defining_Identifier (N), + Name_Priority, + Check_Parents => False); + + begin + if Present (Prio_Item) then + -- Aspect case + + if Nkind (Prio_Item) = N_Aspect_Specification + or else From_Aspect_Specification (Prio_Item) + then + Error_Msg_Name_1 := Chars (Identifier (Prio_Item)); + Error_Msg_NE ("?aspect% for & has no effect when Lock_Free" & + " given", Prio_Item, Id); + + -- Pragma case + + else + Error_Msg_Name_1 := Pragma_Name (Prio_Item); + Error_Msg_NE ("?pragma% for & has no effect when Lock_Free" & + " given", Prio_Item, Id); + end if; + end if; + end; + if not Allows_Lock_Free_Implementation (N, Complain => True) then return; end if;