From patchwork Thu May 25 08:05:59 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 98870 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:994d:0:b0:3d9:f83d:47d9 with SMTP id k13csp203095vqr; Thu, 25 May 2023 01:27:12 -0700 (PDT) X-Google-Smtp-Source: ACHHUZ5PBWabn8USklDgp22/k2uNKBc41PnAlGEfNjJOVyNx3EpAF7C24TMi0ekgiy45fkAf4yLa X-Received: by 2002:a05:6402:338:b0:50d:e0d8:cf31 with SMTP id q24-20020a056402033800b0050de0d8cf31mr3949475edw.21.1685003232380; Thu, 25 May 2023 01:27:12 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1685003232; cv=none; d=google.com; s=arc-20160816; b=OFR6jhSI5n61+bbUosS/BnhUFBkWu9aqsjfwWNRQCXndkzsQPRWf2M0+BxKCBv1NX5 eOoSdgO39o7Yv4OEmzbF5QnFUSR+TTA9ElRydiPrXtR4t5cqkq+HiH3p1GyjYZEyuF3/ OVpLc5ggY9pdm1YpN/vkRg6EWsmAf0t7jdyng5RtLQsXetfVJT8WxO3+23qCHQAPnwku yJYYXRYABWAom/yFok27Ydfg+rhrN9L0C+cesT+g0qRxLRe2WrLLIE85jWxPGawtQJ9N BASnrSepf7RugdINlxXYUPEz7Ameqzjg/SxG+N/Rg0kDxi97cK2voy3NF1grPwe7p4IE nQeg== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:reply-to:from:list-subscribe:list-help:list-post :list-archive:list-unsubscribe:list-id:precedence :content-transfer-encoding:mime-version:message-id:date:subject:cc :to:dmarc-filter:delivered-to:dkim-signature:dkim-filter; bh=ddh/gKQJTmnINzBj9QL6jKADKKDAxDzSEcbjOKh56ps=; b=Djt6OaGkWuEb4ilHz/EtV26dFb8Dst7iebX+xRcvEmVmqC6jg/LbOLZyu0I3bNTpxW ZYP4dh6eTpGpWHw9j/Eo74CoXbK6bJZqLn3Pwm/Sc62TeE3AIfSPmrtaV2B/0drS25ZT eD6PNAm+F5gFhTTt6rt/trN00sf1ll97/cG7BDWogrby+AJP52RMhqS5T0BcH8pvYlzE tH4+JCQQPDmXaaZ0UCvY1V55U4+NpUXkxdAIuy8bGwICwoQGxPIkZ9i/Lza5YrNLUZ2M VI00rPSkhXwGwkyJgjRFwrqSChIhI/w/DoC44HyjtmDM4pG8z1P7eJh++fnKxi+ga8ne d1sw== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=K9xfiO3T; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from sourceware.org (server2.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id r17-20020aa7da11000000b005126de40942si614054eds.136.2023.05.25.01.27.11 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 25 May 2023 01:27:12 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) client-ip=8.43.85.97; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=K9xfiO3T; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 2D5C63882AD2 for ; Thu, 25 May 2023 08:17:43 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 2D5C63882AD2 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1685002663; bh=ddh/gKQJTmnINzBj9QL6jKADKKDAxDzSEcbjOKh56ps=; h=To:Cc:Subject:Date:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:List-Subscribe:From:Reply-To:From; b=K9xfiO3TRfLJwZh5gUmQasFea4/rg/HaEVCz4biBKGxHa9iA//YEPdMIxY3ECUrW5 ggzSsGSI3c+WtD/K0F954d1PtvUJ5sYhi/XZX66cINVAcIWjRJjZXEKCJTt6AJss5K KqFe3PgM/ZAhzIwfw1H3jpSb5eRDU6OYAKTvSYiw= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x32c.google.com (mail-wm1-x32c.google.com [IPv6:2a00:1450:4864:20::32c]) by sourceware.org (Postfix) with ESMTPS id 861B73856956 for ; Thu, 25 May 2023 08:06:01 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 861B73856956 Received: by mail-wm1-x32c.google.com with SMTP id 5b1f17b1804b1-3f60410106cso2006705e9.1 for ; Thu, 25 May 2023 01:06:01 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20221208; t=1685001961; x=1687593961; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=ddh/gKQJTmnINzBj9QL6jKADKKDAxDzSEcbjOKh56ps=; b=UPW12vVzkK/ijqvk9cMS2oFbDI4837pBsSVbXjxzVbmdld9M7Xow/mdVprZRAXslZ9 Rmo1Ogm1xUYJ51qy6n+SoylgAwrGkwGUl3OyNmI5G21Awp+FwtMJYTuDzW/jG6rI4kEm tN4fdGlCPIsS2CCZzUMgh+rThk/eiCRFthoVZGyuKr9UJ5CU1mXo1SeBKk04qhJhtr/b Gs5GcZgZOgzqTzSE34vzI8k1vEbcr9PVgxk8BDkm2SFnJr2bleeLq79lf8VlNV62s0wi Wfh/jodtTk/jJmGOHbTOCAjqLIwG5se/xz2YT7uwQzCY55sByfeZTwSOSoEyoptaePb7 A09Q== X-Gm-Message-State: AC+VfDxj/n+fYk6Nwv6SXOMJr8h3f45L4WGYQl+d/Cps/rvAY1F+VnkN P0ZuEtlqStExdAxXr+VfVDculjPXINAj/9E1MTNUTg== X-Received: by 2002:a5d:4805:0:b0:306:2b81:88e1 with SMTP id l5-20020a5d4805000000b003062b8188e1mr1660856wrq.0.1685001960889; Thu, 25 May 2023 01:06:00 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id l16-20020adfe590000000b002fb60c7995esm902095wrm.8.2023.05.25.01.05.59 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 25 May 2023 01:06:00 -0700 (PDT) To: gcc-patches@gcc.gnu.org Cc: Steve Baird Subject: [COMMITTED] ada: Avoid duplicated streaming subprograms Date: Thu, 25 May 2023 10:05:59 +0200 Message-Id: <20230525080559.1956848-1-poulhies@adacore.com> X-Mailer: git-send-email 2.40.0 MIME-Version: 1.0 X-Spam-Status: No, score=-13.2 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_FILL_THIS_FORM_SHORT, 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: =?utf-8?q?Marc_Poulhi=C3=A8s_via_Gcc-patches?= From: =?utf-8?q?Marc_Poulhi=C3=A8s?= Reply-To: =?utf-8?q?Marc_Poulhi=C3=A8s?= Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: =?utf-8?q?INBOX?= X-GMAIL-THRID: =?utf-8?q?1766853949565442052?= X-GMAIL-MSGID: =?utf-8?q?1766853949565442052?= From: Steve Baird In some common cases, a reference to Some_Type'Some_Streaming_Attribute causes the needed subprogram to be generated "on demand". If there are multiple such references (e.g., two calls to Some_Type'Write) then we want to avoid generating multiple essentially-identical subprograms. This change implies that a generated streaming subprogram may now have multiple call sites, so we can no longer use the source position information from the (one and only) call site. If an exception is raised during a streaming operation, this can make a difference in the reported raise location. gcc/ada/ * exp_attr.adb (Cached_Streaming_Ops): A new package, providing maps to save previously-generated Read/Write/Input/Output procedures. (Expand_N_Attribute_Reference): When a new subprogram is generated for a Read/Write/Input/Output attribute reference, record that type/subp pair in the appropriate Cached_Streaming_Ops map. (Find_Stream_Subprogram): Check the appropriate Cached_Streaming_Ops map to see if an appropriate subprogram has already been generated. If so, then return it. The appropriateness test includes a call to a new nested subprogram, In_Available_Context. * exp_strm.ads, exp_strm.adb: Do not pass in a Loc parameter (or a source-location-bearing Nod parameter) to the 16 procedures provided for building streaming-related subprograms. Use the source location of the type instead. * exp_dist.adb, exp_ch3.adb: Adapt to Exp_Strm spec changes. For these calls the source location of the type was already being used. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_attr.adb | 279 +++++++++++++++++++++++++++++++++---------- gcc/ada/exp_ch3.adb | 8 +- gcc/ada/exp_dist.adb | 10 +- gcc/ada/exp_strm.adb | 100 ++++++++-------- gcc/ada/exp_strm.ads | 39 ++---- 5 files changed, 286 insertions(+), 150 deletions(-) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index a5791adf7dd..7235a164e0a 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -77,8 +77,55 @@ with Uname; use Uname; with Urealp; use Urealp; with Validsw; use Validsw; +with GNAT.HTable; + package body Exp_Attr is + package Cached_Streaming_Ops is + + Map_Size : constant := 63; + subtype Header_Num is Integer range 0 .. Map_Size - 1; + + function Streaming_Op_Hash (Id : Entity_Id) return Header_Num is + (Header_Num (Id mod Map_Size)); + + -- Cache used to avoid building duplicate subprograms for a single + -- type/streaming-attribute pair. + + package Read_Map is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Key => Entity_Id, + Element => Entity_Id, + No_Element => Empty, + Hash => Streaming_Op_Hash, + Equal => "="); + + package Write_Map is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Key => Entity_Id, + Element => Entity_Id, + No_Element => Empty, + Hash => Streaming_Op_Hash, + Equal => "="); + + package Input_Map is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Key => Entity_Id, + Element => Entity_Id, + No_Element => Empty, + Hash => Streaming_Op_Hash, + Equal => "="); + + package Output_Map is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Key => Entity_Id, + Element => Entity_Id, + No_Element => Empty, + Hash => Streaming_Op_Hash, + Equal => "="); + + end Cached_Streaming_Ops; + ----------------------- -- Local Subprograms -- ----------------------- @@ -210,13 +257,15 @@ package body Exp_Attr is -- is not a floating-point type. function Find_Stream_Subprogram - (Typ : Entity_Id; - Nam : TSS_Name_Type) return Entity_Id; + (Typ : Entity_Id; + Nam : TSS_Name_Type; + Attr_Ref : Node_Id) return Entity_Id; -- Returns the stream-oriented subprogram attribute for Typ. For tagged -- types, the corresponding primitive operation is looked up, else the -- appropriate TSS from the type itself, or from its closest ancestor -- defining it, is returned. In both cases, inheritance of representation - -- aspects is thus taken into account. + -- aspects is thus taken into account. Attr_Ref is used to identify the + -- point from which the function result will be referenced. function Full_Base (T : Entity_Id) return Entity_Id; -- The stream functions need to examine the underlying representation of @@ -4115,18 +4164,19 @@ package body Exp_Attr is ----------- when Attribute_Input => Input : declare - P_Type : constant Entity_Id := Entity (Pref); - B_Type : constant Entity_Id := Base_Type (P_Type); - U_Type : constant Entity_Id := Underlying_Type (P_Type); - Strm : constant Node_Id := First (Exprs); - Fname : Entity_Id; - Decl : Node_Id; - Call : Node_Id; - Prag : Node_Id; - Arg2 : Node_Id; - Rfunc : Node_Id; + P_Type : constant Entity_Id := Entity (Pref); + B_Type : constant Entity_Id := Base_Type (P_Type); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Strm : constant Node_Id := First (Exprs); + Has_TSS : Boolean := False; + Fname : Entity_Id; + Decl : Node_Id; + Call : Node_Id; + Prag : Node_Id; + Arg2 : Node_Id; + Rfunc : Node_Id; - Cntrl : Node_Id := Empty; + Cntrl : Node_Id := Empty; -- Value for controlling argument in call. Always Empty except in -- the dispatching (class-wide type) case, where it is a reference -- to the dummy object initialized to the right internal tag. @@ -4192,10 +4242,10 @@ package body Exp_Attr is -- If there is a TSS for Input, just call it - Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input); + Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input, N); if Present (Fname) then - null; + Has_TSS := True; else -- If there is a Stream_Convert pragma, use it, we rewrite @@ -4252,7 +4302,7 @@ package body Exp_Attr is if Present (Find_Inherited_TSS (P_Type, TSS_Stream_Read)) then Build_Record_Or_Elementary_Input_Function - (Loc, P_Type, Decl, Fname); + (P_Type, Decl, Fname); Insert_Action (N, Decl); -- For normal cases, we call the I_xxx routine directly @@ -4266,7 +4316,7 @@ package body Exp_Attr is -- Array type case elsif Is_Array_Type (U_Type) then - Build_Array_Input_Function (Loc, U_Type, Decl, Fname); + Build_Array_Input_Function (U_Type, Decl, Fname); Compile_Stream_Body_In_Scope (N, Decl, U_Type); -- Dispatching case with class-wide type @@ -4395,7 +4445,7 @@ package body Exp_Attr is -- constrained discriminants (see Ada 2012 AI05-0192). Build_Record_Or_Elementary_Input_Function - (Loc, U_Type, Decl, Fname); + (U_Type, Decl, Fname); Insert_Action (N, Decl); if Nkind (Parent (N)) = N_Object_Declaration @@ -4413,7 +4463,7 @@ package body Exp_Attr is while Present (Comp) loop Func := Find_Stream_Subprogram - (Etype (Comp), TSS_Stream_Read); + (Etype (Comp), TSS_Stream_Read, N); if Present (Func) then Freeze_Stream_Subprogram (Func); @@ -4443,6 +4493,10 @@ package body Exp_Attr is if Nkind (Parent (N)) = N_Object_Declaration then Freeze_Stream_Subprogram (Fname); end if; + + if not Has_TSS then + Cached_Streaming_Ops.Input_Map.Set (P_Type, Fname); + end if; end Input; ------------------- @@ -5279,13 +5333,14 @@ package body Exp_Attr is ------------ when Attribute_Output => Output : declare - P_Type : constant Entity_Id := Entity (Pref); - U_Type : constant Entity_Id := Underlying_Type (P_Type); - Pname : Entity_Id; - Decl : Node_Id; - Prag : Node_Id; - Arg3 : Node_Id; - Wfunc : Node_Id; + P_Type : constant Entity_Id := Entity (Pref); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Has_TSS : Boolean := False; + Pname : Entity_Id; + Decl : Node_Id; + Prag : Node_Id; + Arg3 : Node_Id; + Wfunc : Node_Id; begin -- If no underlying type, we have an error that will be diagnosed @@ -5310,10 +5365,10 @@ package body Exp_Attr is -- If TSS for Output is present, just call it - Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output); + Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output, N); if Present (Pname) then - null; + Has_TSS := True; else -- If there is a Stream_Convert pragma, use it, we rewrite @@ -5374,7 +5429,7 @@ package body Exp_Attr is if Present (Find_Inherited_TSS (P_Type, TSS_Stream_Write)) then Build_Record_Or_Elementary_Output_Procedure - (Loc, P_Type, Decl, Pname); + (P_Type, Decl, Pname); Insert_Action (N, Decl); -- For normal cases, we call the W_xxx routine directly @@ -5388,7 +5443,7 @@ package body Exp_Attr is -- Array type case elsif Is_Array_Type (U_Type) then - Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname); + Build_Array_Output_Procedure (U_Type, Decl, Pname); Compile_Stream_Body_In_Scope (N, Decl, U_Type); -- Class-wide case, first output external tag, then dispatch @@ -5499,7 +5554,7 @@ package body Exp_Attr is end if; Build_Record_Or_Elementary_Output_Procedure - (Loc, Base_Type (U_Type), Decl, Pname); + (Base_Type (U_Type), Decl, Pname); Insert_Action (N, Decl); end if; end if; @@ -5507,6 +5562,10 @@ package body Exp_Attr is -- If we fall through, Pname is the name of the procedure to call Rewrite_Attribute_Proc_Call (Pname); + + if not Has_TSS then + Cached_Streaming_Ops.Output_Map.Set (P_Type, Pname); + end if; end Output; --------- @@ -6171,16 +6230,17 @@ package body Exp_Attr is ---------- when Attribute_Read => Read : declare - P_Type : constant Entity_Id := Entity (Pref); - B_Type : constant Entity_Id := Base_Type (P_Type); - U_Type : constant Entity_Id := Underlying_Type (P_Type); - Pname : Entity_Id; - Decl : Node_Id; - Prag : Node_Id; - Arg2 : Node_Id; - Rfunc : Node_Id; - Lhs : Node_Id; - Rhs : Node_Id; + P_Type : constant Entity_Id := Entity (Pref); + B_Type : constant Entity_Id := Base_Type (P_Type); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Has_TSS : Boolean := False; + Pname : Entity_Id; + Decl : Node_Id; + Prag : Node_Id; + Arg2 : Node_Id; + Rfunc : Node_Id; + Lhs : Node_Id; + Rhs : Node_Id; begin -- If no underlying type, we have an error that will be diagnosed @@ -6205,10 +6265,10 @@ package body Exp_Attr is -- The simple case, if there is a TSS for Read, just call it - Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read); + Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read, N); if Present (Pname) then - null; + Has_TSS := True; else -- If there is a Stream_Convert pragma, use it, we rewrite @@ -6308,7 +6368,7 @@ package body Exp_Attr is -- Array type case elsif Is_Array_Type (U_Type) then - Build_Array_Read_Procedure (N, U_Type, Decl, Pname); + Build_Array_Read_Procedure (U_Type, Decl, Pname); Compile_Stream_Body_In_Scope (N, Decl, U_Type); -- Tagged type case, use the primitive Read function. Note that @@ -6342,10 +6402,10 @@ package body Exp_Attr is if Has_Defaulted_Discriminants (U_Type) then Build_Mutable_Record_Read_Procedure - (Loc, Full_Base (U_Type), Decl, Pname); + (Full_Base (U_Type), Decl, Pname); else Build_Record_Read_Procedure - (Loc, Full_Base (U_Type), Decl, Pname); + (Full_Base (U_Type), Decl, Pname); end if; Insert_Action (N, Decl); @@ -6353,6 +6413,10 @@ package body Exp_Attr is end if; Rewrite_Attribute_Proc_Call (Pname); + + if not Has_TSS then + Cached_Streaming_Ops.Read_Map.Set (P_Type, Pname); + end if; end Read; --------- @@ -7857,13 +7921,14 @@ package body Exp_Attr is ----------- when Attribute_Write => Write : declare - P_Type : constant Entity_Id := Entity (Pref); - U_Type : constant Entity_Id := Underlying_Type (P_Type); - Pname : Entity_Id; - Decl : Node_Id; - Prag : Node_Id; - Arg3 : Node_Id; - Wfunc : Node_Id; + P_Type : constant Entity_Id := Entity (Pref); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Has_TSS : Boolean := False; + Pname : Entity_Id; + Decl : Node_Id; + Prag : Node_Id; + Arg3 : Node_Id; + Wfunc : Node_Id; begin -- If no underlying type, we have an error that will be diagnosed @@ -7888,10 +7953,10 @@ package body Exp_Attr is -- The simple case, if there is a TSS for Write, just call it - Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write); + Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write, N); if Present (Pname) then - null; + Has_TSS := True; else -- If there is a Stream_Convert pragma, use it, we rewrite @@ -7951,7 +8016,7 @@ package body Exp_Attr is -- Array type case elsif Is_Array_Type (U_Type) then - Build_Array_Write_Procedure (N, U_Type, Decl, Pname); + Build_Array_Write_Procedure (U_Type, Decl, Pname); Compile_Stream_Body_In_Scope (N, Decl, U_Type); -- Tagged type case, use the primitive Write function. Note that @@ -7992,10 +8057,10 @@ package body Exp_Attr is if Has_Defaulted_Discriminants (U_Type) then Build_Mutable_Record_Write_Procedure - (Loc, Full_Base (U_Type), Decl, Pname); + (Full_Base (U_Type), Decl, Pname); else Build_Record_Write_Procedure - (Loc, Full_Base (U_Type), Decl, Pname); + (Full_Base (U_Type), Decl, Pname); end if; Insert_Action (N, Decl); @@ -8005,6 +8070,10 @@ package body Exp_Attr is -- If we fall through, Pname is the procedure to be called Rewrite_Attribute_Proc_Call (Pname); + + if not Has_TSS then + Cached_Streaming_Ops.Write_Map.Set (P_Type, Pname); + end if; end Write; -- The following attributes are handled by the back end (except that @@ -8576,16 +8645,102 @@ package body Exp_Attr is ---------------------------- function Find_Stream_Subprogram - (Typ : Entity_Id; - Nam : TSS_Name_Type) return Entity_Id + (Typ : Entity_Id; + Nam : TSS_Name_Type; + Attr_Ref : Node_Id) return Entity_Id is + + function In_Available_Context (Ent : Entity_Id) return Boolean; + -- Ent is a candidate result for Find_Stream_Subprogram. + -- If, for example, a subprogram is declared within a case + -- alternative then Gigi does not want to see a call to it from + -- outside of the case alternative. Compare placement of Ent and + -- Attr_Ref to prevent this situation (by returning False). + + -------------------------- + -- In_Available_Context -- + -------------------------- + + function In_Available_Context (Ent : Entity_Id) return Boolean is + Decl : Node_Id := Enclosing_Declaration (Ent); + begin + -- Enclosing_Declaration does not always return a declaration; + -- cope with this irregularity. + if Decl in N_Subprogram_Specification_Id + and then Nkind (Parent (Decl)) in + N_Subprogram_Body | N_Subprogram_Declaration + then + Decl := Parent (Decl); + end if; + + if Has_Declarations (Parent (Decl)) then + return In_Subtree (Attr_Ref, Root => Parent (Decl)); + elsif Is_List_Member (Decl) then + declare + List_Elem : Node_Id := Next (Decl); + begin + while Present (List_Elem) loop + if In_Subtree (Attr_Ref, Root => List_Elem) then + return True; + end if; + Next (List_Elem); + end loop; + return False; + end; + else + return False; -- Can this occur ??? + end if; + end In_Available_Context; + + -- Local declarations + Base_Typ : constant Entity_Id := Base_Type (Typ); - Ent : constant Entity_Id := TSS (Typ, Nam); + Ent : Entity_Id := TSS (Typ, Nam); + + -- Start of processing for Find_Stream_Subprogram + begin if Present (Ent) then return Ent; end if; + -- Everything after this point is an optimization. In other words, + -- there should be no *correctness* problems if we were to + -- unconditionally return Empty here. + + if Is_Unchecked_Union (Base_Typ) then + -- Conservatively avoid possible problems (e.g., Write behaves + -- differently for a U_U type when called by Output vs. when + -- called from elsewhere). + + return Empty; + end if; + + if Nam = TSS_Stream_Read then + Ent := Cached_Streaming_Ops.Read_Map.Get (Typ); + elsif Nam = TSS_Stream_Write then + Ent := Cached_Streaming_Ops.Write_Map.Get (Typ); + elsif Nam = TSS_Stream_Input then + Ent := Cached_Streaming_Ops.Input_Map.Get (Typ); + elsif Nam = TSS_Stream_Output then + Ent := Cached_Streaming_Ops.Output_Map.Get (Typ); + end if; + + if Present (Ent) then + -- Can't reuse Ent if it is no longer in scope + + if In_Open_Scopes (Scope (Ent)) + + -- The preceding In_Open_Scopes test may not suffice if + -- case alternatives are involved. + and then In_Available_Context (Ent) + then + return Ent; + else + Ent := Empty; + end if; + end if; + -- Stream attributes for strings are expanded into library calls. The -- following checks are disabled when the run-time is not available or -- when compiling predefined types due to bootstrap issues. As a result, diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index b992a587433..e23a3fde15c 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -12422,14 +12422,14 @@ package body Exp_Ch3 is if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read) and then No (TSS (Tag_Typ, TSS_Stream_Read)) then - Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); + Build_Record_Read_Procedure (Tag_Typ, Decl, Ent); Append_To (Res, Decl); end if; if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write) and then No (TSS (Tag_Typ, TSS_Stream_Write)) then - Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent); + Build_Record_Write_Procedure (Tag_Typ, Decl, Ent); Append_To (Res, Decl); end if; @@ -12441,14 +12441,14 @@ package body Exp_Ch3 is and then No (TSS (Tag_Typ, TSS_Stream_Input)) then Build_Record_Or_Elementary_Input_Function - (Loc, Tag_Typ, Decl, Ent); + (Tag_Typ, Decl, Ent); Append_To (Res, Decl); end if; if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) and then No (TSS (Tag_Typ, TSS_Stream_Output)) then - Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent); + Build_Record_Or_Elementary_Output_Procedure (Tag_Typ, Decl, Ent); Append_To (Res, Decl); end if; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 7805f74e412..8f62bef2c64 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -3118,8 +3118,8 @@ package body Exp_Dist is -- Start of processing for Add_RACW_Read_Attribute begin - Build_Stream_Procedure (Loc, - RACW_Type, Body_Node, Pnam, Statements, Outp => True); + Build_Stream_Procedure + (RACW_Type, Body_Node, Pnam, Statements, Outp => True); Proc_Decl := Make_Subprogram_Declaration (Loc, Copy_Specification (Loc, Specification (Body_Node))); @@ -3354,7 +3354,7 @@ package body Exp_Dist is begin Build_Stream_Procedure - (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); + (RACW_Type, Body_Node, Pnam, Statements, Outp => False); Proc_Decl := Make_Subprogram_Declaration (Loc, Copy_Specification (Loc, Specification (Body_Node))); @@ -5800,7 +5800,7 @@ package body Exp_Dist is begin Build_Stream_Procedure - (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True); + (RACW_Type, Body_Node, Pnam, Statements, Outp => True); Proc_Decl := Make_Subprogram_Declaration (Loc, Copy_Specification (Loc, Specification (Body_Node))); @@ -6103,7 +6103,7 @@ package body Exp_Dist is begin Build_Stream_Procedure - (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); + (RACW_Type, Body_Node, Pnam, Statements, Outp => False); Proc_Decl := Make_Subprogram_Declaration (Loc, diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 2610584cef0..f1203ad9e97 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -51,20 +51,17 @@ package body Exp_Strm is ----------------------- procedure Build_Array_Read_Write_Procedure - (Nod : Node_Id; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : Entity_Id; Nam : Name_Id); -- Common routine shared to build either an array Read procedure or an -- array Write procedure, Nam is Name_Read or Name_Write to select which. -- Pnam is the defining identifier for the constructed procedure. The - -- other parameters are as for Build_Array_Read_Procedure except that - -- the first parameter Nod supplies the Sloc to be used to generate code. + -- other parameters are as for Build_Array_Read_Procedure. procedure Build_Record_Read_Write_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : Entity_Id; Nam : Name_Id); @@ -74,8 +71,7 @@ package body Exp_Strm is -- as for Build_Record_Read_Procedure. procedure Build_Stream_Function - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Fnam : Entity_Id; Decls : List_Id; @@ -140,11 +136,11 @@ package body Exp_Strm is -- reference, so the name must be unique. procedure Build_Array_Input_Function - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Fnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Dim : constant Pos := Number_Dimensions (Typ); Lnam : Name_Id; Hnam : Name_Id; @@ -235,7 +231,7 @@ package body Exp_Strm is Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Input)); - Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms); + Build_Stream_Function (Typ, Decl, Fnam, Decls, Stms); end Build_Array_Input_Function; ---------------------------------- @@ -243,11 +239,11 @@ package body Exp_Strm is ---------------------------------- procedure Build_Array_Output_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Stms : List_Id; Indx : Node_Id; @@ -301,7 +297,7 @@ package body Exp_Strm is Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Output)); - Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => False); + Build_Stream_Procedure (Typ, Decl, Pnam, Stms, Outp => False); end Build_Array_Output_Procedure; -------------------------------- @@ -309,18 +305,17 @@ package body Exp_Strm is -------------------------------- procedure Build_Array_Read_Procedure - (Nod : Node_Id; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is - Loc : constant Source_Ptr := Sloc (Nod); + Loc : constant Source_Ptr := Sloc (Typ); begin Pnam := Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read)); - Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read); + Build_Array_Read_Write_Procedure (Typ, Decl, Pnam, Name_Read); end Build_Array_Read_Procedure; -------------------------------------- @@ -345,13 +340,12 @@ package body Exp_Strm is -- The out keyword for V is supplied in the Read case procedure Build_Array_Read_Write_Procedure - (Nod : Node_Id; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : Entity_Id; Nam : Name_Id) is - Loc : constant Source_Ptr := Sloc (Nod); + Loc : constant Source_Ptr := Sloc (Typ); Ndim : constant Pos := Number_Dimensions (Typ); Ctyp : constant Entity_Id := Component_Type (Typ); @@ -402,7 +396,7 @@ package body Exp_Strm is for J in 1 .. Ndim loop Stm := - Make_Implicit_Loop_Statement (Nod, + Make_Implicit_Loop_Statement (Typ, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => @@ -424,7 +418,7 @@ package body Exp_Strm is end loop; Build_Stream_Procedure - (Loc, Typ, Decl, Pnam, New_List (Stm), Outp => Nam = Name_Read); + (Typ, Decl, Pnam, New_List (Stm), Outp => Nam = Name_Read); end Build_Array_Read_Write_Procedure; --------------------------------- @@ -432,17 +426,16 @@ package body Exp_Strm is --------------------------------- procedure Build_Array_Write_Procedure - (Nod : Node_Id; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is - Loc : constant Source_Ptr := Sloc (Nod); + Loc : constant Source_Ptr := Sloc (Typ); begin Pnam := Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write)); - Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write); + Build_Array_Read_Write_Procedure (Typ, Decl, Pnam, Name_Write); end Build_Array_Write_Procedure; --------------------------------- @@ -894,11 +887,12 @@ package body Exp_Strm is ----------------------------------------- procedure Build_Mutable_Record_Read_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Out_Formal : Node_Id; -- Expression denoting the out formal parameter @@ -951,7 +945,7 @@ package body Exp_Strm is Make_Raise_Program_Error (Loc, Reason => PE_Unchecked_Union_Restriction)); - Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => True); + Build_Stream_Procedure (Typ, Decl, Pnam, Stms, Outp => True); return; end if; @@ -1007,7 +1001,7 @@ package body Exp_Strm is -- Generate reads for the components of the record (including those -- that depend on discriminants). - Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); + Build_Record_Read_Write_Procedure (Typ, Decl, Pnam, Name_Read); -- Save original statement sequence for component assignments, and -- replace it with Stms. @@ -1066,11 +1060,11 @@ package body Exp_Strm is ------------------------------------------ procedure Build_Mutable_Record_Write_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Stms : List_Id; Disc : Entity_Id; D_Ref : Node_Id; @@ -1111,7 +1105,7 @@ package body Exp_Strm is Pnam := Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write)); - Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); + Build_Record_Read_Write_Procedure (Typ, Decl, Pnam, Name_Write); -- Write the discriminants before the rest of the components, so -- that discriminant values are properly set of variants, etc. @@ -1152,11 +1146,11 @@ package body Exp_Strm is -- an elementary type, then no Cn constants are defined. procedure Build_Record_Or_Elementary_Input_Function - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Fnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); B_Typ : constant Entity_Id := Underlying_Type (Base_Type (Typ)); Cn : Name_Id; Constr : List_Id; @@ -1288,7 +1282,7 @@ package body Exp_Strm is Fnam := Make_Stream_Subprogram_Name (Loc, B_Typ, TSS_Stream_Input); - Build_Stream_Function (Loc, B_Typ, Decl, Fnam, Decls, Stms); + Build_Stream_Function (B_Typ, Decl, Fnam, Decls, Stms); end Build_Record_Or_Elementary_Input_Function; ------------------------------------------------- @@ -1296,11 +1290,11 @@ package body Exp_Strm is ------------------------------------------------- procedure Build_Record_Or_Elementary_Output_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Stms : List_Id; Disc : Entity_Id; Disc_Ref : Node_Id; @@ -1356,7 +1350,7 @@ package body Exp_Strm is Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output); - Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => False); + Build_Stream_Procedure (Typ, Decl, Pnam, Stms, Outp => False); end Build_Record_Or_Elementary_Output_Procedure; --------------------------------- @@ -1364,14 +1358,14 @@ package body Exp_Strm is --------------------------------- procedure Build_Record_Read_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); begin Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read); - Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); + Build_Record_Read_Write_Procedure (Typ, Decl, Pnam, Name_Read); end Build_Record_Read_Procedure; --------------------------------------- @@ -1407,12 +1401,12 @@ package body Exp_Strm is -- The out keyword for V is supplied in the Read case procedure Build_Record_Read_Write_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : Entity_Id; Nam : Name_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Rdef : Node_Id; Stms : List_Id; Typt : Entity_Id; @@ -1616,7 +1610,7 @@ package body Exp_Strm is end if; Build_Stream_Procedure - (Loc, Typ, Decl, Pnam, Stms, Outp => Nam = Name_Read); + (Typ, Decl, Pnam, Stms, Outp => Nam = Name_Read); end Build_Record_Read_Write_Procedure; ---------------------------------- @@ -1624,14 +1618,14 @@ package body Exp_Strm is ---------------------------------- procedure Build_Record_Write_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); begin Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write); - Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); + Build_Record_Read_Write_Procedure (Typ, Decl, Pnam, Name_Write); end Build_Record_Write_Procedure; ------------------------------- @@ -1674,13 +1668,13 @@ package body Exp_Strm is --------------------------- procedure Build_Stream_Function - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Fnam : Entity_Id; Decls : List_Id; Stms : List_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Spec : Node_Id; begin @@ -1719,13 +1713,13 @@ package body Exp_Strm is ---------------------------- procedure Build_Stream_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : Entity_Id; Stms : List_Id; Outp : Boolean) is + Loc : constant Source_Ptr := Sloc (Typ); Spec : Node_Id; begin diff --git a/gcc/ada/exp_strm.ads b/gcc/ada/exp_strm.ads index e0d180aacbc..d56a5985989 100644 --- a/gcc/ada/exp_strm.ads +++ b/gcc/ada/exp_strm.ads @@ -57,38 +57,31 @@ package Exp_Strm is -- results are the declaration and name (entity) of the subprogram. procedure Build_Array_Input_Function - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Fnam : out Entity_Id); -- Build function for Input attribute for array type procedure Build_Array_Output_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); -- Build procedure for Output attribute for array type procedure Build_Array_Read_Procedure - (Nod : Node_Id; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); - -- Build procedure for Read attribute for array type. Nod provides the - -- Sloc value for generated code. + -- Build procedure for Read attribute for array type. procedure Build_Array_Write_Procedure - (Nod : Node_Id; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); - -- Build procedure for Write attribute for array type. Nod provides the - -- Sloc value for generated code. + -- Build procedure for Write attribute for array type. procedure Build_Mutable_Record_Read_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); -- Build procedure to Read a record with default discriminants. @@ -96,8 +89,7 @@ package Exp_Strm is -- same manner as is done for 'Input. procedure Build_Mutable_Record_Write_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); -- Build procedure to write a record with default discriminants. @@ -105,8 +97,7 @@ package Exp_Strm is -- the same manner as is done for 'Output. procedure Build_Record_Or_Elementary_Input_Function - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Fnam : out Entity_Id); -- Build function for Input attribute for record type or for an elementary @@ -115,8 +106,7 @@ package Exp_Strm is -- runtime library routine directly). procedure Build_Record_Or_Elementary_Output_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); -- Build procedure for Output attribute for record type or for an @@ -125,22 +115,19 @@ package Exp_Strm is -- Output calls the appropriate runtime library routine directly. procedure Build_Record_Read_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); -- Build procedure for Read attribute for record type procedure Build_Record_Write_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : out Entity_Id); -- Build procedure for Write attribute for record type procedure Build_Stream_Procedure - (Loc : Source_Ptr; - Typ : Entity_Id; + (Typ : Entity_Id; Decl : out Node_Id; Pnam : Entity_Id; Stms : List_Id;