From patchwork Mon Jul 4 07:50:24 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: 1651848 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: bilbo.ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha256 header.s=default header.b=ERXhiVdk; dkim-atps=neutral Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Received: from sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (2048 bits) server-digest SHA256) (No client certificate requested) by bilbo.ozlabs.org (Postfix) with ESMTPS id 4LbysC1ZHYz9s1l for ; Mon, 4 Jul 2022 18:00:15 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 0EA2538337A1 for ; Mon, 4 Jul 2022 08:00:13 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 0EA2538337A1 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1656921613; bh=GdhXGlRa7ftfKsLOc/u4PEl2yklnmRwT0x8Zlhylf70=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=ERXhiVdkrAf0mRfps9QBwHcuAFBYU8yNrmipd1HDwP3fLLwjUBNUvCGpH+TfZ35ZO jgqI2Sk5roF2BDoAakgIvrqF7x9YVM0MVwt0KdsWelYjlJfO+BQBSWC9c0PUV493Zl 23y/9vUG0iwVShbBjVDZJpU218mlp77wrw2G4XAs= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-ej1-x62e.google.com (mail-ej1-x62e.google.com [IPv6:2a00:1450:4864:20::62e]) by sourceware.org (Postfix) with ESMTPS id C9FAA3852742 for ; Mon, 4 Jul 2022 07:50:25 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org C9FAA3852742 Received: by mail-ej1-x62e.google.com with SMTP id q6so15173213eji.13 for ; Mon, 04 Jul 2022 00:50:25 -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=GdhXGlRa7ftfKsLOc/u4PEl2yklnmRwT0x8Zlhylf70=; b=5a1jOQU0DXgtItaqUQDZwTWGNM5RGQvSnCpVrlIwQyZhd0aVxrv6ofPjl44xaNwEbb VVxdtEFOay8qxxsk8+Meh+dvfmT55v4hcj3vdKnRt0OIyD4UR2paTtzCC0GZ5vvJZfE9 tyArLHZN7u1TSbmDBfIVGeZYNntkGswQY/6kSYQGOfeGISbKqYUS9miSktZZFQf3a9wI nO1LA2ZwN89vzYlnD+/F6e/eq3dsTrhAhWFE9tY6X2SWnQ1EqY3vRQr1Yl2AHqK5ZExw m5FiDJ5qsCSVp1EpehhrGZSoiIWNZPeUd/gobx9u0jQOPD6WuTLYEYGsPc4T//LPEG1z 9ALA== X-Gm-Message-State: AJIora+vhGZKWNovIWdFok64LwE1TPiL6aMa84U4/NCHa6UWrjoZ+V5B uly47hAhouv1UMvIOvNBni5Z+BEV1ga8Hg== X-Google-Smtp-Source: AGRyM1uP/1RNMZDL1cMAdOvaPpnCuI8jIH8f8Vr7TPDHDi4tcFUWK3DgRm4SnVQHaZ0WdaNyACWXzg== X-Received: by 2002:a17:907:270b:b0:72a:b457:4899 with SMTP id w11-20020a170907270b00b0072ab4574899mr8428974ejk.419.1656921025353; Mon, 04 Jul 2022 00:50:25 -0700 (PDT) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id dy10-20020a05640231ea00b004358c3bfb4csm20316023edb.31.2022.07.04.00.50.24 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 04 Jul 2022 00:50:24 -0700 (PDT) Date: Mon, 4 Jul 2022 07:50:24 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Use static stack allocation for small string if-expressions Message-ID: <20220704075024.GA99310@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-9.8 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, SPAM_BODY, 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+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" This changes the expanded code generated for if-expressions of 1-dimensional arrays to create a static temporary on the stack if a small upper bound can be computed for the length of a subtype covering the result. Static stack allocation is preferred over dynamic allocation for code generation purpose. This also contains a couple of enhancements to the support code for checks, so as to avoid generating useless checks during the modified expansion. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * checks.adb (Apply_Length_Check_On_Assignment): Return early if the Suppress_Assignment_Checks flag is set. (Selected_Range_Checks): Deal with conditional expressions. * exp_ch4.adb (Too_Large_Length_For_Array): New constant. (Expand_Concatenate): Use it in lieu of Too_Large_Max_Length. (Expand_N_If_Expression): If the result has a unidimensional array type but the dependent expressions have constrained subtypes with known bounds, create a static temporary on the stack with a subtype covering the result. (Get_First_Index_Bounds): Deal with string literals. * uintp.ads (Uint_256): New deferred constant. * sinfo.ads (Suppress_Assignment_Checks): Document new usage. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2297,6 +2297,15 @@ package body Checks is Assign : constant Node_Id := Parent (Target); begin + -- Do not apply length checks if parent is still an assignment statement + -- with Suppress_Assignment_Checks flag set. + + if Nkind (Assign) = N_Assignment_Statement + and then Suppress_Assignment_Checks (Assign) + then + return; + end if; + -- No check is needed for the initialization of an object whose -- nominal subtype is unconstrained. @@ -6462,7 +6471,7 @@ package body Checks is end if; -- Do not set range check flag if parent is assignment statement or - -- object declaration with Suppress_Assignment_Checks flag set + -- object declaration with Suppress_Assignment_Checks flag set. if Nkind (Parent (N)) in N_Assignment_Statement | N_Object_Declaration and then Suppress_Assignment_Checks (Parent (N)) @@ -10500,6 +10509,11 @@ package body Checks is -- Returns expression to compute: -- N'First or N'Last using Duplicate_Subexpr_No_Checks + function Is_Cond_Expr_Ge (N : Node_Id; V : Node_Id) return Boolean; + function Is_Cond_Expr_Le (N : Node_Id; V : Node_Id) return Boolean; + -- Return True if N is a conditional expression whose dependent + -- expressions are all known and greater/lower than or equal to V. + function Range_E_Cond (Exptyp : Entity_Id; Typ : Entity_Id; @@ -10522,6 +10536,16 @@ package body Checks is -- Return expression to compute: -- Exp'First < Typ'First or else Exp'Last > Typ'Last + function "<" (Left, Right : Node_Id) return Boolean + is (if Is_Floating_Point_Type (S_Typ) + then Expr_Value_R (Left) < Expr_Value_R (Right) + else Expr_Value (Left) < Expr_Value (Right)); + function "<=" (Left, Right : Node_Id) return Boolean + is (if Is_Floating_Point_Type (S_Typ) + then Expr_Value_R (Left) <= Expr_Value_R (Right) + else Expr_Value (Left) <= Expr_Value (Right)); + -- Convenience comparison functions of integer or floating point values + --------------- -- Add_Check -- --------------- @@ -10702,6 +10726,60 @@ package body Checks is Make_Integer_Literal (Loc, Indx))); end Get_N_Last; + --------------------- + -- Is_Cond_Expr_Ge -- + --------------------- + + function Is_Cond_Expr_Ge (N : Node_Id; V : Node_Id) return Boolean is + begin + -- Only if expressions are relevant for the time being + + if Nkind (N) = N_If_Expression then + declare + Cond : constant Node_Id := First (Expressions (N)); + Thenx : constant Node_Id := Next (Cond); + Elsex : constant Node_Id := Next (Thenx); + + begin + return Compile_Time_Known_Value (Thenx) + and then V <= Thenx + and then + ((Compile_Time_Known_Value (Elsex) and then V <= Elsex) + or else Is_Cond_Expr_Ge (Elsex, V)); + end; + + else + return False; + end if; + end Is_Cond_Expr_Ge; + + --------------------- + -- Is_Cond_Expr_Le -- + --------------------- + + function Is_Cond_Expr_Le (N : Node_Id; V : Node_Id) return Boolean is + begin + -- Only if expressions are relevant for the time being + + if Nkind (N) = N_If_Expression then + declare + Cond : constant Node_Id := First (Expressions (N)); + Thenx : constant Node_Id := Next (Cond); + Elsex : constant Node_Id := Next (Thenx); + + begin + return Compile_Time_Known_Value (Thenx) + and then Thenx <= V + and then + ((Compile_Time_Known_Value (Elsex) and then Elsex <= V) + or else Is_Cond_Expr_Le (Elsex, V)); + end; + + else + return False; + end if; + end Is_Cond_Expr_Le; + ------------------ -- Range_E_Cond -- ------------------ @@ -10783,13 +10861,6 @@ package body Checks is Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); end Range_N_Cond; - function "<" (Left, Right : Node_Id) return Boolean - is (if Is_Floating_Point_Type (S_Typ) - then Expr_Value_R (Left) < Expr_Value_R (Right) - else Expr_Value (Left) < Expr_Value (Right)); - -- Convenience comparison function of integer or floating point - -- values. - -- Start of processing for Selected_Range_Checks begin @@ -10885,6 +10956,14 @@ package body Checks is then LB := T_LB; Known_LB := True; + + -- Similarly; deal with the case where the low bound is a + -- conditional expression whose result is greater than or + -- equal to the target low bound. + + elsif Is_Cond_Expr_Ge (LB, T_LB) then + LB := T_LB; + Known_LB := True; end if; -- Likewise for the high bound @@ -10897,6 +10976,10 @@ package body Checks is then HB := T_HB; Known_HB := True; + + elsif Is_Cond_Expr_Le (HB, T_HB) then + HB := T_HB; + Known_HB := True; end if; end if; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -81,6 +81,10 @@ with Warnsw; use Warnsw; package body Exp_Ch4 is + Too_Large_Length_For_Array : constant Unat := Uint_256; + -- Threshold from which we do not try to create static array temporaries in + -- order to eliminate dynamic stack allocations. + ----------------------- -- Local Subprograms -- ----------------------- @@ -2693,9 +2697,6 @@ package body Exp_Ch4 is -- this loop is complete, always contains the last operand (which is not -- the same as Operands (NN), since null operands are skipped). - Too_Large_Max_Length : constant Unat := UI_From_Int (256); - -- Threshold from which the computation of maximum lengths is useless - -- Arrays describing the operands, only the first NN entries of each -- array are set (NN < N when we exclude known null operands). @@ -2711,9 +2712,9 @@ package body Exp_Ch4 is -- corresponding entry in Is_Fixed_Length is True. Max_Length : array (1 .. N) of Unat; - -- Set to the maximum length of operand, or Too_Large_Max_Length if it - -- is not known. Entries in this array are set only if the corresponding - -- entry in Is_Fixed_Length is False; + -- Set to the maximum length of operand, or Too_Large_Length_For_Array + -- if it is not known. Entries in this array are set only if the + -- corresponding entry in Is_Fixed_Length is False; Opnd_Low_Bound : array (1 .. N) of Node_Id; -- Set to lower bound of operand. Either an integer literal in the case @@ -2733,9 +2734,9 @@ package body Exp_Ch4 is -- to just do a Copy_Node to get an appropriate copy. The extra zeroth -- entry always is set to zero. The length is of type Artyp. - Max_Aggr_Length : Unat := Too_Large_Max_Length; - -- Set to the maximum total length, or at least Too_Large_Max_Length if - -- it is not known. + Max_Aggr_Length : Unat := Too_Large_Length_For_Array; + -- Set to the maximum total length, or Too_Large_Length_For_Array at + -- least if it is not known. Low_Bound : Node_Id := Empty; -- A tree node representing the low bound of the result (of type Ityp). @@ -3115,7 +3116,7 @@ package body Exp_Ch4 is end; else - Max_Length (NN) := Too_Large_Max_Length; + Max_Length (NN) := Too_Large_Length_For_Array; end if; Append_To (Actions, @@ -3362,7 +3363,7 @@ package body Exp_Ch4 is if Compile_Time_Known_Value (Low_Bound) and then not Compile_Time_Known_Value (High_Bound) - and then Max_Aggr_Length < Too_Large_Max_Length + and then Max_Aggr_Length < Too_Large_Length_For_Array then declare Known_High_Bound : constant Node_Id := @@ -5860,19 +5861,43 @@ package body Exp_Ch4 is Elsex : constant Node_Id := Next (Thenx); Typ : constant Entity_Id := Etype (N); - Actions : List_Id; - Decl : Node_Id; - Expr : Node_Id; - New_If : Node_Id; - New_N : Node_Id; - + Force_Expand : constant Boolean := Is_Anonymous_Access_Actual (N); -- Determine if we are dealing with a special case of a conditional -- expression used as an actual for an anonymous access type which -- forces us to transform the if expression into an expression with -- actions in order to create a temporary to capture the level of the -- expression in each branch. - Force_Expand : constant Boolean := Is_Anonymous_Access_Actual (N); + function OK_For_Single_Subtype (T1, T2 : Entity_Id) return Boolean; + -- Return true if it is acceptable to use a single subtype for two + -- dependent expressions of subtype T1 and T2 respectively, which are + -- unidimensional arrays whose index bounds are known at compile time. + + --------------------------- + -- OK_For_Single_Subtype -- + --------------------------- + + function OK_For_Single_Subtype (T1, T2 : Entity_Id) return Boolean is + Lo1, Hi1 : Uint; + Lo2, Hi2 : Uint; + + begin + Get_First_Index_Bounds (T1, Lo1, Hi1); + Get_First_Index_Bounds (T2, Lo2, Hi2); + + -- Return true if the length of the covering subtype is not too large + + return + UI_Max (Hi1, Hi2) - UI_Min (Lo1, Lo2) < Too_Large_Length_For_Array; + end OK_For_Single_Subtype; + + -- Local variables + + Actions : List_Id; + Decl : Node_Id; + Expr : Node_Id; + New_If : Node_Id; + New_N : Node_Id; -- Start of processing for Expand_N_If_Expression @@ -6049,6 +6074,223 @@ package body Exp_Ch4 is Prefix => New_Occurrence_Of (Cnn, Loc)); end; + -- If the result is a unidimensional unconstrained array but the two + -- dependent expressions have constrained subtypes with known bounds, + -- then we expand as follows: + + -- subtype Txx is Typ ( .. ); + -- Cnn : Txx; + -- if cond then + -- <> + -- Cnn () := then-expr; + -- else + -- <> + -- Cnn () := else-expr; + -- end if; + + -- and replace the if expression by a slice of Cnn, provided that Txx + -- is not too large. This will create a static temporary instead of the + -- dynamic one of the next case and thus help the code generator. + + -- Note that we need to deal with the case where the else expression is + -- itself such a slice, in order to catch if expressions with more than + -- two dependent expressions in the source code. + + elsif Is_Array_Type (Typ) + and then Number_Dimensions (Typ) = 1 + and then not Is_Constrained (Typ) + and then Is_Constrained (Etype (Thenx)) + and then Compile_Time_Known_Bounds (Etype (Thenx)) + and then + ((Is_Constrained (Etype (Elsex)) + and then Compile_Time_Known_Bounds (Etype (Elsex)) + and then OK_For_Single_Subtype (Etype (Thenx), Etype (Elsex))) + or else + (Nkind (Elsex) = N_Slice + and then Is_Constrained (Etype (Prefix (Elsex))) + and then Compile_Time_Known_Bounds (Etype (Prefix (Elsex))) + and then + OK_For_Single_Subtype (Etype (Thenx), Etype (Prefix (Elsex))))) + and then not Generate_C_Code + then + declare + Ityp : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); + + function Build_New_Bound + (Then_Bnd : Uint; + Else_Bnd : Uint; + Slice_Bnd : Node_Id) return Node_Id; + -- Build a new bound from the bounds of the if expression + + function To_Ityp (V : Uint) return Node_Id; + -- Convert V to an index value in Ityp + + --------------------- + -- Build_New_Bound -- + --------------------- + + function Build_New_Bound + (Then_Bnd : Uint; + Else_Bnd : Uint; + Slice_Bnd : Node_Id) return Node_Id is + + begin + if Nkind (Elsex) = N_Slice then + if Compile_Time_Known_Value (Slice_Bnd) + and then Expr_Value (Slice_Bnd) = Then_Bnd + then + return To_Ityp (Then_Bnd); + + else + return Make_If_Expression (Loc, + Expressions => New_List ( + Duplicate_Subexpr (Cond), + To_Ityp (Then_Bnd), + New_Copy_Tree (Slice_Bnd))); + end if; + + elsif Then_Bnd = Else_Bnd then + return To_Ityp (Then_Bnd); + + else + return Make_If_Expression (Loc, + Expressions => New_List ( + Duplicate_Subexpr (Cond), + To_Ityp (Then_Bnd), + To_Ityp (Else_Bnd))); + end if; + end Build_New_Bound; + + ------------- + -- To_Ityp -- + ------------- + + function To_Ityp (V : Uint) return Node_Id is + Result : constant Node_Id := Make_Integer_Literal (Loc, V); + + begin + if Is_Enumeration_Type (Ityp) then + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ityp, Loc), + Attribute_Name => Name_Val, + Expressions => New_List (Result)); + else + return Result; + end if; + end To_Ityp; + + Ent : Node_Id; + Slice_Lo, Slice_Hi : Node_Id; + Subtyp_Ind : Node_Id; + Else_Lo, Else_Hi : Uint; + Min_Lo, Max_Hi : Uint; + Then_Lo, Then_Hi : Uint; + Then_List, Else_List : List_Id; + + begin + Get_First_Index_Bounds (Etype (Thenx), Then_Lo, Then_Hi); + + if Nkind (Elsex) = N_Slice then + Slice_Lo := Low_Bound (Discrete_Range (Elsex)); + Slice_Hi := High_Bound (Discrete_Range (Elsex)); + Get_First_Index_Bounds + (Etype (Prefix (Elsex)), Else_Lo, Else_Hi); + + else + Slice_Lo := Empty; + Slice_Hi := Empty; + Get_First_Index_Bounds (Etype (Elsex), Else_Lo, Else_Hi); + end if; + + Min_Lo := UI_Min (Then_Lo, Else_Lo); + Max_Hi := UI_Max (Then_Hi, Else_Hi); + + -- Now we construct an array object with appropriate bounds and + -- mark it as internal to prevent useless initialization when + -- Initialize_Scalars is enabled. Also since this is the actual + -- result entity, we make sure we have debug information for it. + + Subtyp_Ind := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => To_Ityp (Min_Lo), + High_Bound => To_Ityp (Max_Hi))))); + + Ent := Make_Temporary (Loc, 'C'); + Set_Is_Internal (Ent); + Set_Debug_Info_Needed (Ent); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => Subtyp_Ind); + + -- If the result of the expression appears as the initializing + -- expression of an object declaration, we can just rename the + -- result, rather than copying it. + + Mutate_Ekind (Ent, E_Variable); + Set_OK_To_Rename (Ent); + + Then_List := New_List ( + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Ent, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => To_Ityp (Then_Lo), + High_Bound => To_Ityp (Then_Hi))), + Expression => Relocate_Node (Thenx))); + + Set_Suppress_Assignment_Checks (Last (Then_List)); + + if Nkind (Elsex) = N_Slice then + Else_List := New_List ( + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Ent, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => New_Copy_Tree (Slice_Lo), + High_Bound => New_Copy_Tree (Slice_Hi))), + Expression => Relocate_Node (Elsex))); + + else + Else_List := New_List ( + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Ent, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => To_Ityp (Else_Lo), + High_Bound => To_Ityp (Else_Hi))), + Expression => Relocate_Node (Elsex))); + end if; + + Set_Suppress_Assignment_Checks (Last (Else_List)); + + New_If := + Make_Implicit_If_Statement (N, + Condition => Duplicate_Subexpr (Cond), + Then_Statements => Then_List, + Else_Statements => Else_List); + + New_N := + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Ent, Loc), + Discrete_Range => Make_Range (Loc, + Low_Bound => Build_New_Bound (Then_Lo, Else_Lo, Slice_Lo), + High_Bound => Build_New_Bound (Then_Hi, Else_Hi, Slice_Hi))); + end; + -- If the result is an unconstrained array and the if expression is in a -- context other than the initializing expression of the declaration of -- an object, then we pull out the if expression as follows: @@ -6223,7 +6465,7 @@ package body Exp_Ch4 is end if; -- For the sake of GNATcoverage, generate an intermediate temporary in - -- the case where the if-expression is a condition in an outer decision, + -- the case where the if expression is a condition in an outer decision, -- in order to make sure that no branch is shared between the decisions. elsif Opt.Suppress_Control_Flow_Optimizations @@ -13400,10 +13642,16 @@ package body Exp_Ch4 is -- This follows Sem_Eval.Compile_Time_Known_Bounds - Typ := Underlying_Type (Etype (First_Index (T))); + if Ekind (T) = E_String_Literal_Subtype then + Lo := Expr_Value (String_Literal_Low_Bound (T)); + Hi := Lo + String_Literal_Length (T) - 1; - Lo := Expr_Value (Type_Low_Bound (Typ)); - Hi := Expr_Value (Type_High_Bound (Typ)); + else + Typ := Underlying_Type (Etype (First_Index (T))); + + Lo := Expr_Value (Type_Low_Bound (Typ)); + Hi := Expr_Value (Type_High_Bound (Typ)); + end if; end Get_First_Index_Bounds; ------------------------ diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -2299,7 +2299,7 @@ package Sinfo is -- can be set in N_Object_Declaration nodes, to similarly suppress any -- checks on the initializing value. In assignment statements it also -- suppresses access checks in the generated code for out- and in-out - -- parameters in entry calls. + -- parameters in entry calls, as well as length checks. -- Suppress_Loop_Warnings -- Used in N_Loop_Statement node to indicate that warnings within the diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -70,6 +70,7 @@ package Uintp is Uint_80 : constant Uint; Uint_127 : constant Uint; Uint_128 : constant Uint; + Uint_256 : constant Uint; Uint_Minus_1 : constant Uint; Uint_Minus_2 : constant Uint; @@ -507,6 +508,7 @@ private Uint_80 : constant Uint := Uint (Uint_Direct_Bias + 80); Uint_127 : constant Uint := Uint (Uint_Direct_Bias + 127); Uint_128 : constant Uint := Uint (Uint_Direct_Bias + 128); + Uint_256 : constant Uint := Uint (Uint_Direct_Bias + 256); Uint_Minus_1 : constant Uint := Uint (Uint_Direct_Bias - 1); Uint_Minus_2 : constant Uint := Uint (Uint_Direct_Bias - 2);