From patchwork Thu Nov 8 15:58:28 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Eric Botcazou X-Patchwork-Id: 994963 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-489411-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="AHVpNuLD"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 42rSdd5Mbnz9s9h for ; Fri, 9 Nov 2018 02:59:16 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:from :to:subject:date:message-id:mime-version:content-type :content-transfer-encoding; q=dns; s=default; b=qf7UEQTIL7+63W6K W590MByDHl59BJ7mL/ZS36lJd3vlrBtgTQeoD/Es4Vx1IGQsrPRfySkKSl5GyQ7h uobJ9K5/5zLOFcPu5BlOENm6EYs2DblVgpJNTi8fl0FLkLR/zm0Hqa2yAXQOhpop lFw9CgUvR8BQkUQDBMRE5/kVBEg= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:from :to:subject:date:message-id:mime-version:content-type :content-transfer-encoding; s=default; bh=7rnFdRq2OSWlvs7688wnGL a5k4E=; b=AHVpNuLDUcii87tvdfSmyPrn58emBXcPgI3d5LfBMJbGyMDHYUVAMu cSqX5K5Mj9/+tHUKS54tUIlfbyHgC8YM5FW5paul4Qjp4XHeYYXzYxZhR6nVlcQX IkJ3eF0xQt0ajBN1fuQmyyPcnPpnNHlNo95TlvfNDOqhgJuLrZ7+M= Received: (qmail 35586 invoked by alias); 8 Nov 2018 15:59:08 -0000 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 Received: (qmail 35094 invoked by uid 89); 8 Nov 2018 15:59:08 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-10.4 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=Int, sid, 68, Groups X-HELO: smtp.eu.adacore.com Received: from mel.act-europe.fr (HELO smtp.eu.adacore.com) (194.98.77.210) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 08 Nov 2018 15:59:05 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 320688152A for ; Thu, 8 Nov 2018 16:59:03 +0100 (CET) Received: from smtp.eu.adacore.com ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id Ls3MnTe11v-1 for ; Thu, 8 Nov 2018 16:59:03 +0100 (CET) Received: from polaris.localnet (bon31-6-88-161-99-133.fbx.proxad.net [88.161.99.133]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by smtp.eu.adacore.com (Postfix) with ESMTPSA id ED77E8139F for ; Thu, 8 Nov 2018 16:59:02 +0100 (CET) From: Eric Botcazou To: gcc-patches@gcc.gnu.org Subject: [Ada] Fix wrong code for loops with convoluted control flow Date: Thu, 08 Nov 2018 16:58:28 +0100 Message-ID: <11594679.zQ2E7WpiWs@polaris> MIME-Version: 1.0 This is a regression present since the -faggressive-loop-optimizations option was introduced, leading to wrong code in some cases for "while" loops with convoluted control flow. It's caused by a bad interaction between three different things: specific support we have in gigi for -fnon-call-exceptions, loop invariant motion (-ftree-loop-im) and -faggressive-loop-optimizations. In light of this, we have decided to tidy up this area in gigi in order to make the compiler more robust in default mode while losing nothing in terms of run-time performance in -gnatp mode. Tested on x86_64-suse-linux, applied on the mainline, 8 and 7 branches. 2018-11-08 Eric Botcazou * fe.h (Suppress_Checks): Declare. * gcc-interface/misc.c (gnat_init_gcc_eh): Set -fnon-call-exceptions only if checks are not suppressed and -faggressive-loop-optimizations only if they are. * gcc-interface/trans.c (struct loop_info_d): Remove has_checks and warned_aggressive_loop_optimizations fields. (gigi): Do not clear warn_aggressive_loop_optimizations here. (Raise_Error_to_gnu): Do not set has_checks. (gnat_to_gnu) : Remove support for aggressive loop optimizations. 2018-11-08 Eric Botcazou * gnat.dg/null_pointer_deref1.adb: Remove -gnatp and add pragma. * gnat.dg/null_pointer_deref2.adb: Likewise. * gnat.dg/null_pointer_deref3.adb: Likewise. * gnat.dg/opt74.adb: New test. * gnat.dg/opt74_pkg.ad[sb]: New helper. * gnat.dg/warn12.adb: Delete. * gnat.dg/warn12_pkg.ads: Likewise. Index: ada/fe.h =================================================================== --- ada/fe.h (revision 265866) +++ ada/fe.h (working copy) @@ -193,6 +193,7 @@ extern Boolean In_Same_Source_Unit #define GNAT_Mode opt__gnat_mode #define List_Representation_Info opt__list_representation_info #define No_Strict_Aliasing_CP opt__no_strict_aliasing +#define Suppress_Checks opt__suppress_checks typedef enum { Front_End_SJLJ, Back_End_ZCX, Back_End_SJLJ @@ -207,6 +208,7 @@ extern Boolean Generate_SCO_Instance_Tab extern Boolean GNAT_Mode; extern Int List_Representation_Info; extern Boolean No_Strict_Aliasing_CP; +extern Boolean Suppress_Checks; #define ZCX_Exceptions opt__zcx_exceptions #define SJLJ_Exceptions opt__sjlj_exceptions Index: ada/gcc-interface/misc.c =================================================================== --- ada/gcc-interface/misc.c (revision 265866) +++ ada/gcc-interface/misc.c (working copy) @@ -392,7 +392,7 @@ gnat_init_gcc_eh (void) using_eh_for_cleanups (); /* Turn on -fexceptions, -fnon-call-exceptions and -fdelete-dead-exceptions. - The first one triggers the generation of the necessary exception tables. + The first one activates the support for exceptions in the compiler. The second one is useful for two reasons: 1/ we map some asynchronous signals like SEGV to exceptions, so we need to ensure that the insns which can lead to such signals are correctly attached to the exception @@ -402,10 +402,18 @@ gnat_init_gcc_eh (void) for such calls to actually raise in Ada. The third one is an optimization that makes it possible to delete dead instructions that may throw exceptions, most notably loads and stores, - as permitted in Ada. */ + as permitted in Ada. + Turn off -faggressive-loop-optimizations because it may optimize away + out-of-bound array accesses that we want to be able to catch. + If checks are disabled, we use the same settings as the C++ compiler. */ flag_exceptions = 1; - flag_non_call_exceptions = 1; flag_delete_dead_exceptions = 1; + if (!Suppress_Checks) + { + flag_non_call_exceptions = 1; + flag_aggressive_loop_optimizations = 0; + warn_aggressive_loop_optimizations = 0; + } init_eh (); } Index: ada/gcc-interface/trans.c =================================================================== --- ada/gcc-interface/trans.c (revision 265866) +++ ada/gcc-interface/trans.c (working copy) @@ -198,8 +198,6 @@ struct GTY(()) loop_info_d { tree high_bound; vec *checks; bool artificial; - bool has_checks; - bool warned_aggressive_loop_optimizations; }; typedef struct loop_info_d *loop_info; @@ -679,10 +677,6 @@ gigi (Node_Id gnat_root, /* Now translate the compilation unit proper. */ Compilation_Unit_to_gnu (gnat_root); - /* Disable -Waggressive-loop-optimizations since we implement our own - version of the warning. */ - warn_aggressive_loop_optimizations = 0; - /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at the very end to avoid having to second-guess the front-end when we run into dummy nodes during the regular processing. */ @@ -5720,7 +5714,6 @@ Raise_Error_to_gnu (Node_Id gnat_node, t rci->inserted_cond = build1 (SAVE_EXPR, boolean_type_node, boolean_true_node); vec_safe_push (loop->checks, rci); - loop->has_checks = true; gnu_cond = build_noreturn_cond (gnat_to_gnu (gnat_cond)); if (flag_unswitch_loops) gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR, @@ -5733,14 +5726,6 @@ Raise_Error_to_gnu (Node_Id gnat_node, t gnu_cond, rci->inserted_cond); } - - /* Or else, if aggressive loop optimizations are enabled, we just - record that there are checks applied to iteration variables. */ - else if (optimize - && flag_aggressive_loop_optimizations - && inside_loop_p () - && (loop = find_loop_for (gnu_index))) - loop->has_checks = true; } break; @@ -6359,45 +6344,9 @@ gnat_to_gnu (Node_Id gnat_node) gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); gnat_temp = gnat_expr_array[i]; gnu_expr = maybe_character_value (gnat_to_gnu (gnat_temp)); - struct loop_info_d *loop; gnu_result = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr); - - /* Array accesses are bound-checked so they cannot trap, but this - is valid only if they are not hoisted ahead of the check. We - need to mark them as no-trap to get decent loop optimizations - in the presence of -fnon-call-exceptions, so we do it when we - know that the original expression had no side-effects. */ - if (TREE_CODE (gnu_result) == ARRAY_REF - && !(Nkind (gnat_temp) == N_Identifier - && Ekind (Entity (gnat_temp)) == E_Constant)) - TREE_THIS_NOTRAP (gnu_result) = 1; - - /* If aggressive loop optimizations are enabled, we warn for loops - overrunning a simple array of size 1 not at the end of a record. - This is aimed to catch misuses of the trailing array idiom. */ - if (optimize - && flag_aggressive_loop_optimizations - && inside_loop_p () - && TREE_CODE (TREE_TYPE (gnu_type)) != ARRAY_TYPE - && TREE_CODE (gnu_array_object) != ARRAY_REF - && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_type)), - TYPE_MAX_VALUE (TYPE_DOMAIN (gnu_type))) - && !array_at_struct_end_p (gnu_result) - && (loop = find_loop_for (gnu_expr)) - && !loop->artificial - && !loop->has_checks - && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_type)), - loop->low_bound) - && can_be_lower_p (loop->low_bound, loop->high_bound) - && !loop->warned_aggressive_loop_optimizations - && warning (OPT_Waggressive_loop_optimizations, - "out-of-bounds access may be optimized away")) - { - inform (EXPR_LOCATION (loop->stmt), "containing loop"); - loop->warned_aggressive_loop_optimizations = true; - } } gnu_result_type = get_unpadded_type (Etype (gnat_node)); Index: testsuite/gnat.dg/null_pointer_deref1.adb =================================================================== --- testsuite/gnat.dg/null_pointer_deref1.adb (revision 265866) +++ testsuite/gnat.dg/null_pointer_deref1.adb (working copy) @@ -1,11 +1,13 @@ -- { dg-do run } --- { dg-options "-gnatp" } -- This test requires architecture- and OS-specific support code for unwinding -- through signal frames (typically located in *-unwind.h) to pass. Feel free -- to disable it if this code hasn't been implemented yet. procedure Null_Pointer_Deref1 is + + pragma Suppress (All_Checks); + type Int_Ptr is access all Integer; function Ident return Int_Ptr is Index: testsuite/gnat.dg/null_pointer_deref2.adb =================================================================== --- testsuite/gnat.dg/null_pointer_deref2.adb (revision 265866) +++ testsuite/gnat.dg/null_pointer_deref2.adb (working copy) @@ -1,5 +1,4 @@ -- { dg-do run } --- { dg-options "-gnatp" } -- This test requires architecture- and OS-specific support code for unwinding -- through signal frames (typically located in *-unwind.h) to pass. Feel free @@ -7,6 +6,8 @@ procedure Null_Pointer_Deref2 is + pragma Suppress (All_Checks); + task T; task body T is Index: testsuite/gnat.dg/null_pointer_deref3.adb =================================================================== --- testsuite/gnat.dg/null_pointer_deref3.adb (revision 265866) +++ testsuite/gnat.dg/null_pointer_deref3.adb (working copy) @@ -1,5 +1,4 @@ -- { dg-do run } --- { dg-options "-O -gnatp" } -- This test requires architecture- and OS-specific support code for unwinding -- through signal frames (typically located in *-unwind.h) to pass. Feel free @@ -7,6 +6,8 @@ procedure Null_Pointer_Deref3 is + pragma Suppress (All_Checks); + procedure Leaf is type Int_Ptr is access all Integer; function n return Int_Ptr is Index: testsuite/gnat.dg/opt74.adb =================================================================== --- testsuite/gnat.dg/opt74.adb (nonexistent) +++ testsuite/gnat.dg/opt74.adb (working copy) @@ -0,0 +1,13 @@ +-- { dg-do run } +-- { dg-options "-O2" } + +with Opt74_Pkg; use Opt74_Pkg; + +procedure Opt74 is + Index, Found : Integer; +begin + Proc (Found, Index); + if Found = 1 then + raise Program_Error; + end if; +end; Index: testsuite/gnat.dg/opt74_pkg.adb =================================================================== --- testsuite/gnat.dg/opt74_pkg.adb (nonexistent) +++ testsuite/gnat.dg/opt74_pkg.adb (working copy) @@ -0,0 +1,16 @@ +package body Opt74_Pkg is + + procedure Proc (Found : out Integer; Index : out Integer) is + begin + Index := 1; + Found := 0; + while (Index <= A'Last) and (Found = 0) loop + if A (Index) = 2 then + Found := 1; + else + Index := Index + 1; + end if; + end loop; + end; + +end Opt74_Pkg; Index: testsuite/gnat.dg/opt74_pkg.ads =================================================================== --- testsuite/gnat.dg/opt74_pkg.ads (nonexistent) +++ testsuite/gnat.dg/opt74_pkg.ads (working copy) @@ -0,0 +1,7 @@ +package Opt74_Pkg is + + A : array (1 .. 10) of Integer := (others => 0); + + procedure Proc (Found : out Integer; Index : out Integer); + +end Opt74_Pkg; Index: testsuite/gnat.dg/warn12.adb =================================================================== --- testsuite/gnat.dg/warn12.adb (revision 265866) +++ testsuite/gnat.dg/warn12.adb (nonexistent) @@ -1,48 +0,0 @@ --- { dg-do compile } --- { dg-options "-O2" } - -with Text_IO; use Text_IO; -with System.Storage_Elements; use System.Storage_Elements; -with Warn12_Pkg; use Warn12_Pkg; - -procedure Warn12 (N : Natural) is - - Buffer_Size : constant Storage_Offset - := Token_Groups'Size/System.Storage_Unit + 4096; - - Buffer : Storage_Array (1 .. Buffer_Size); - for Buffer'Alignment use 8; - - Tg1 : Token_Groups; - for Tg1'Address use Buffer'Address; - - Tg2 : Token_Groups; - pragma Warnings (Off, Tg2); - - sid : Sid_And_Attributes; - - pragma Suppress (Index_Check, Sid_And_Attributes_Array); - -begin - - for I in 0 .. 7 loop - sid := Tg1.Groups(I); -- { dg-bogus "out-of-bounds access" } - Put_Line("Iteration"); - end loop; - - for I in 0 .. N loop - sid := Tg1.Groups(I); -- { dg-bogus "out-of-bounds access" } - Put_Line("Iteration"); - end loop; - - for I in 0 .. 7 loop - sid := Tg2.Groups(I); -- { dg-warning "out-of-bounds access" } - Put_Line("Iteration"); - end loop; - - for I in 0 .. N loop - sid := Tg2.Groups(I); -- { dg-warning "out-of-bounds access" } - Put_Line("Iteration"); - end loop; - -end; Index: testsuite/gnat.dg/warn12_pkg.ads =================================================================== --- testsuite/gnat.dg/warn12_pkg.ads (revision 265866) +++ testsuite/gnat.dg/warn12_pkg.ads (nonexistent) @@ -1,21 +0,0 @@ -with Interfaces.C; use Interfaces.C; -with System; - -package Warn12_Pkg is - - Anysize_Array: constant := 0; - - type Sid_And_Attributes is record - Sid : System.Address; - Attributes : Interfaces.C.Unsigned_Long; - end record; - - type Sid_And_Attributes_Array - is array (Integer range 0..Anysize_Array) of aliased Sid_And_Attributes; - - type Token_Groups is record - GroupCount : Interfaces.C.Unsigned_Long; - Groups : Sid_And_Attributes_Array; - end record; - -end Warn12_Pkg;