From patchwork Tue Dec 6 14:01:49 2022 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: 61563 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 CFE10384C934 for ; Tue, 6 Dec 2022 14:02:26 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org CFE10384C934 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1670335346; bh=ZMTIl/R25/9ZmTBMabrW21gRTi1f9bIyAH8rAliQ9S4=; h=To:Cc:Subject:Date:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:List-Subscribe:From:Reply-To:From; b=wH15AHr13q7fkCswrqlSCqgItalFVHmLHNcmBcmL6t+Gvx42Jt5xwNHq/HQkgIMss F/P9smMEbbeCUnzgyXDlA/UIgBSFUqgwE2um6NepVNMjNkjlaHcYtjQkTxsjEP7Cmp mqEjXdN9drtld+YfOhg0FccAq/hDzdDzEmYQJbKQ= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x434.google.com (mail-wr1-x434.google.com [IPv6:2a00:1450:4864:20::434]) by sourceware.org (Postfix) with ESMTPS id 01EBD3848E1E for ; Tue, 6 Dec 2022 14:01:56 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 01EBD3848E1E Received: by mail-wr1-x434.google.com with SMTP id f18so23583499wrj.5 for ; Tue, 06 Dec 2022 06:01:55 -0800 (PST) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; 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=ZMTIl/R25/9ZmTBMabrW21gRTi1f9bIyAH8rAliQ9S4=; b=PH43Xt69LfDHKhlC4eY8tjlM6Da0h4K1m/51Gj9RijDhsE2fbOn+gobGnGNOOh2MP+ HUnRZFBlQegCy4JpL9pXfh8S/DhsOajpN/OjiYALvjwAhX+WFaysSMSafvu+WSBhF6A5 Q/hLR3S/yIzrdHGiWW1qBlgfgHSBqUDC6ZyEPXuW7wHXOL6MmbXubLclfjl4oea1AiD7 kdbJwadoyQfXpp+Ieah/48JCLfCZeIaatl4OEuePtY1afnQ13kq8Wy1cZqWPYOOOdgdb gOre9eqqSuNb5tRVK9R93QGD/rOq/0xm1n5gTbwfeNcjK9wGBvndT8r7sJFZQ31iFDhN Ou3Q== X-Gm-Message-State: ANoB5plnyOOHpo9FUu7SBG6H23e/SqEzTa4xhJF9x9H3QdDVW1ZdUzZK DlCYOJ5pDaYA/ywS67OrasKBKE7Qun6vpvo9 X-Google-Smtp-Source: AA0mqf4f1Skqa0Y9umoBvoWlKkAOyFbXs+war1rtRhtlPwkkJJS5q+rzzeuvu5nsXLy8EE4AtlFG6g== X-Received: by 2002:a5d:4943:0:b0:242:3ca3:b7bd with SMTP id r3-20020a5d4943000000b002423ca3b7bdmr13524197wrs.583.1670335313931; Tue, 06 Dec 2022 06:01:53 -0800 (PST) Received: from poulhies-Precision-5550.lan (static-176-191-105-132.ftth.abo.bbox.fr. [176.191.105.132]) by smtp.gmail.com with ESMTPSA id l7-20020a5d4107000000b00242246c2f7csm16907118wrp.101.2022.12.06.06.01.53 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 06 Dec 2022 06:01:53 -0800 (PST) To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Use larger type for membership test of universal value Date: Tue, 6 Dec 2022 15:01:49 +0100 Message-Id: <20221206140149.717127-1-poulhies@adacore.com> X-Mailer: git-send-email 2.34.1 MIME-Version: 1.0 X-Spam-Status: No, score=-13.1 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 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+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" From: Eric Botcazou When a membership test is applied to a nonstatic expression of a universal type, for example an attribute whose type is universal_integer and whose prefix is not static, the operation is performed using the tested type that is determined by the choice list. In particular, a check that the value of the expression lies in the range of the tested type may be generated before the test is actually performed. This goes against the spirit of membership tests, which are typically used to guard a specific operation and ought not to fail a check in doing so. Therefore the resolution of the operands of membership tests is changed in this case to use the universal type instead of the tested type. The final computation of the type used to actually perform the test is left to the expander, which already has the appropriate circuitry. This nevertheless requires fixing an irregularity in the expansion of the subtype_mark form of membership tests, which was dependent on the presence of predicates for the subtype; the confusing name of a routine used by this expansion is also changed in the process. gcc/ada/ * exp_ch4.adb (Expand_N_In) : Rename to... : ...this. Use Is_Entity_Name to test for the presence of entity references. Do not warn or substitute a valid test for a test with a mark for a subtype that is predicated. Apply the same transformation for a test with a mark for a subtype that is predicated as for a subtype that is not. Remove useless return statement. * sem_res.adb (Resolve_Membership_Op): Perform a special resolution if the left operand is of a universal numeric type. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch4.adb | 93 +++++++++++++++++++++++++++++---------------- gcc/ada/sem_res.adb | 46 ++++++++++++++++++++++ 2 files changed, 106 insertions(+), 33 deletions(-) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 00d19e765a6..7edef4c39c3 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6454,15 +6454,15 @@ package body Exp_Ch4 is Rop : constant Node_Id := Right_Opnd (N); Static : constant Boolean := Is_OK_Static_Expression (N); - procedure Substitute_Valid_Check; + procedure Substitute_Valid_Test; -- Replaces node N by Lop'Valid. This is done when we have an explicit -- test for the left operand being in range of its subtype. - ---------------------------- - -- Substitute_Valid_Check -- - ---------------------------- + --------------------------- + -- Substitute_Valid_Test -- + --------------------------- - procedure Substitute_Valid_Check is + procedure Substitute_Valid_Test is function Is_OK_Object_Reference (Nod : Node_Id) return Boolean; -- Determine whether arbitrary node Nod denotes a source object that -- may safely act as prefix of attribute 'Valid. @@ -6502,7 +6502,7 @@ package body Exp_Ch4 is return False; end Is_OK_Object_Reference; - -- Start of processing for Substitute_Valid_Check + -- Start of processing for Substitute_Valid_Test begin Rewrite (N, @@ -6526,7 +6526,7 @@ package body Exp_Ch4 is Error_Msg_N -- CODEFIX ("\??use ''Valid attribute instead", N); end if; - end Substitute_Valid_Check; + end Substitute_Valid_Test; -- Local variables @@ -6579,7 +6579,7 @@ package body Exp_Ch4 is -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow -- checks have changed the type of the left operand. - and then Nkind (Rop) in N_Has_Entity + and then Is_Entity_Name (Rop) and then Ltyp = Entity (Rop) -- Skip this for predicated types, where such expressions are a @@ -6587,7 +6587,7 @@ package body Exp_Ch4 is and then No (Predicate_Function (Ltyp)) then - Substitute_Valid_Check; + Substitute_Valid_Test; return; end if; @@ -6605,26 +6605,42 @@ package body Exp_Ch4 is Lo : constant Node_Id := Low_Bound (Rop); Hi : constant Node_Id := High_Bound (Rop); - Lo_Orig : constant Node_Id := Original_Node (Lo); - Hi_Orig : constant Node_Id := Original_Node (Hi); - - Lcheck : Compare_Result; - Ucheck : Compare_Result; + Lo_Orig : constant Node_Id := Original_Node (Lo); + Hi_Orig : constant Node_Id := Original_Node (Hi); + Rop_Orig : constant Node_Id := Original_Node (Rop); + + Comes_From_Simple_Range_In_Source : constant Boolean := + Comes_From_Source (N) + and then not + (Is_Entity_Name (Rop_Orig) + and then Is_Type (Entity (Rop_Orig)) + and then Present (Predicate_Function (Entity (Rop_Orig)))); + -- This is true for a membership test present in the source with a + -- range or mark for a subtype that is not predicated. As already + -- explained a few lines above, we do not want to give warnings on + -- a test with a mark for a subtype that is predicated. Warn : constant Boolean := Constant_Condition_Warnings - and then Comes_From_Source (N) + and then Comes_From_Simple_Range_In_Source and then not In_Instance; -- This must be true for any of the optimization warnings, we -- clearly want to give them only for source with the flag on. We -- also skip these warnings in an instance since it may be the -- case that different instantiations have different ranges. + Lcheck : Compare_Result; + Ucheck : Compare_Result; + begin - -- If test is explicit x'First .. x'Last, replace by valid check + -- If test is explicit x'First .. x'Last, replace by 'Valid test if Is_Scalar_Type (Ltyp) + -- Only relevant for source comparisons + + and then Comes_From_Simple_Range_In_Source + -- And left operand is X'First where X matches left operand -- type (this eliminates cases of type mismatch, including -- the cases where ELIMINATED/MINIMIZED mode has changed the @@ -6632,21 +6648,17 @@ package body Exp_Ch4 is and then Nkind (Lo_Orig) = N_Attribute_Reference and then Attribute_Name (Lo_Orig) = Name_First - and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity + and then Is_Entity_Name (Prefix (Lo_Orig)) and then Entity (Prefix (Lo_Orig)) = Ltyp -- Same tests for right operand and then Nkind (Hi_Orig) = N_Attribute_Reference and then Attribute_Name (Hi_Orig) = Name_Last - and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity + and then Is_Entity_Name (Prefix (Hi_Orig)) and then Entity (Prefix (Hi_Orig)) = Ltyp - - -- Relevant only for source cases - - and then Comes_From_Source (N) then - Substitute_Valid_Check; + Substitute_Valid_Test; goto Leave; end if; @@ -6655,7 +6667,7 @@ package body Exp_Ch4 is -- for substituting a valid test. We only do this for discrete -- types, since it won't arise in practice for float types. - if Comes_From_Source (N) + if Comes_From_Simple_Range_In_Source and then Is_Discrete_Type (Ltyp) and then Compile_Time_Known_Value (Type_High_Bound (Ltyp)) and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp)) @@ -6668,7 +6680,7 @@ package body Exp_Ch4 is -- have a test in the generic that makes sense with some types -- and not with other types. - -- Similarly, do not rewrite membership as a validity check if + -- Similarly, do not rewrite membership as a 'Valid test if -- within the predicate function for the type. -- Finally, if the original bounds are type conversions, even @@ -6688,7 +6700,7 @@ package body Exp_Ch4 is null; else - Substitute_Valid_Check; + Substitute_Valid_Test; goto Leave; end if; end if; @@ -6823,12 +6835,12 @@ package body Exp_Ch4 is goto Leave; -- If type is scalar type, rewrite as x in t'First .. t'Last. - -- This reason we do this is that the bounds may have the wrong + -- The reason we do this is that the bounds may have the wrong -- type if they come from the original type definition. Also this -- way we get all the processing above for an explicit range. - -- Don't do this for predicated types, since in this case we - -- want to check the predicate. + -- Don't do this for predicated types, since in this case we want + -- to generate the predicate check at the end of the function. elsif Is_Scalar_Type (Typ) then if No (Predicate_Function (Typ)) then @@ -6843,6 +6855,7 @@ package body Exp_Ch4 is Make_Attribute_Reference (Loc, Attribute_Name => Name_Last, Prefix => New_Occurrence_Of (Typ, Loc)))); + Analyze_And_Resolve (N, Restyp); end if; @@ -7150,6 +7163,24 @@ package body Exp_Ch4 is and then Current_Scope /= PFunc and then Nkind (Rop) /= N_Range then + -- First apply the transformation that was skipped above + + if Is_Scalar_Type (Rtyp) then + Rewrite (Rop, + Make_Range (Loc, + Low_Bound => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => New_Occurrence_Of (Rtyp, Loc)), + + High_Bound => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Last, + Prefix => New_Occurrence_Of (Rtyp, Loc)))); + + Analyze_And_Resolve (N, Restyp); + end if; + if not In_Range_Check then -- Indicate via Static_Mem parameter that this predicate -- evaluation is for a membership test. @@ -7169,10 +7200,6 @@ package body Exp_Ch4 is Set_Analyzed (Left_Opnd (N)); Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); - - -- All done, skip attempt at compile time determination of result - - return; end if; end Predicate_Check; end Expand_N_In; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 70c7c7cc9d5..3574afd19ac 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -10105,6 +10105,51 @@ package body Sem_Res is then T := Etype (R); + -- If the left operand is of a universal numeric type and the right + -- operand is not, we do not resolve the operands to the tested type + -- but to the universal type instead. If not conforming to the letter, + -- it's conforming to the spirit of the specification of membership + -- tests, which are typically used to guard a specific operation and + -- ought not to fail a check in doing so. Without this, in the case of + + -- type Small_Length is range 1 .. 16; + + -- function Is_Small_String (S : String) return Boolean is + -- begin + -- return S'Length in Small_Length; + -- end; + + -- the function Is_Small_String would fail a range check for strings + -- larger than 127 characters. + + elsif not Is_Overloaded (L) + and then Is_Universal_Numeric_Type (Etype (L)) + and then (Is_Overloaded (R) + or else not Is_Universal_Numeric_Type (Etype (R))) + then + T := Etype (L); + + -- If the right operand is 'Range, we first need to resolve it (to + -- the tested type) so that it is rewritten as an N_Range, before + -- converting its bounds and resolving it again below. + + if Nkind (R) = N_Attribute_Reference + and then Attribute_Name (R) = Name_Range + then + Resolve (R); + end if; + + -- If the right operand is an N_Range, we convert its bounds to the + -- universal type before resolving it. + + if Nkind (R) = N_Range then + Rewrite (R, + Make_Range (Sloc (R), + Low_Bound => Convert_To (T, Low_Bound (R)), + High_Bound => Convert_To (T, High_Bound (R)))); + Analyze (R); + end if; + -- Ada 2005 (AI-251): Support the following case: -- type I is interface; @@ -10124,6 +10169,7 @@ package body Sem_Res is and then not Is_Interface (Etype (R)) then return; + else T := Intersect_Types (L, R); end if;