From patchwork Thu Sep 19 13:28:19 2019 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: 1164620 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-509281-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="RnrATXoZ"; 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 46YyQy4z5Vz9sNk for ; Thu, 19 Sep 2019 23:30:50 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=TFJKpiOQ2nY3PQFg/s/9XmeZzkTZ7g8Adnkdu+yaBWrV1SrWo+ X2E2y0HRgBbp05um6gI8QfAUqVKKcKkG39En4DNEB7bDTTYrDq5CJs+NiEmbzHh9 mPD4aNXwkgBGWO2lRzVsFCP/EeOE2B4lEcrJk7HQMSxruNP+UkV4fs0xY= 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:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=ga4lM34Ul702/NNWIXp490WhIFc=; b=RnrATXoZU78S7UpxF06Q fT2VgtAXkseh9IdJxBFA3Tl8VMPGqeYUuceqEif7a2wmy0qai33/VwUhTtSAqR6E ThG+p47dGdhqlRnxRYZQvzRJ/6BBlqTTSLnmal93Xz+gKsX2WKT/DOQ3GcsH9YDC whvJcWYQzRN/H9h2pq1vmlc= Received: (qmail 2339 invoked by alias); 19 Sep 2019 13:28:31 -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 2179 invoked by uid 89); 19 Sep 2019 13:28:30 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.1 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, SPF_NEUTRAL autolearn=ham version=3.3.1 spammy=8192, Typ, exp_aggr, discriminant X-HELO: eggs.gnu.org Received: from eggs.gnu.org (HELO eggs.gnu.org) (209.51.188.92) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 19 Sep 2019 13:28:29 +0000 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1iAwTy-0001Q2-OT for gcc-patches@gcc.gnu.org; Thu, 19 Sep 2019 09:28:28 -0400 Received: from rock.gnat.com ([2620:20:4000:0:a9e:1ff:fe9b:1d1]:58723) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1iAwTy-0001Ob-0y for gcc-patches@gcc.gnu.org; Thu, 19 Sep 2019 09:28:26 -0400 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 217BE5602A; Thu, 19 Sep 2019 09:28:20 -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 DlLfBu0RS91f; Thu, 19 Sep 2019 09:28:20 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id D8AF95601D; Thu, 19 Sep 2019 09:28:19 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id D7B496B4; Thu, 19 Sep 2019 09:28:19 -0400 (EDT) Date: Thu, 19 Sep 2019 09:28:19 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [Ada] Fix copy operation with private discriminated record type Message-ID: <20190919132819.GA41891@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x X-Received-From: 2620:20:4000:0:a9e:1ff:fe9b:1d1 X-IsSubscribed: yes This prevents the object code from reading too many bytes from the source for a copy operation involving a private discriminated record type with default discriminants and generated for the assignment of an aggregate to a variable or the initialization of a constant. The front-end already knows that it needs to convert the operation involving the aggregate into individual assignments if the type of the aggregate has mutable components, but it would not do so if this type is private, which does not change anything for code generation. Running these commands: gnatmake -q p -g -fsanitize=address p On the following sources: with Q; use Q; procedure P is type Rec is record A : T; end record; C : constant Rec := Rec'(A => Default_T); begin null; end; package Q is type T is private; Default_T : constant T; private A : constant := 170; B : constant := 8192; type A_Index is range 1 .. A; type B_Index is range 1 .. B; type A_Array is array (A_Index) of Boolean; type B_Array is array (B_Index) of Boolean; type Data_Type is (A_Type, B_Type); type T (Discriminant : Data_Type := A_Type) is record case Discriminant is when A_Type => Field_A : A_Array; when B_Type => Field_B : B_Array; end case; end record; Default_T : constant T := T'(Discriminant => A_Type, Field_A => (others => True)); end Q; Should execute silently. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-09-19 Eric Botcazou gcc/ada/ * exp_aggr.adb (Has_Mutable_Components): Look at the underlying type of components to find out whether they are mutable. --- gcc/ada/exp_aggr.adb +++ gcc/ada/exp_aggr.adb @@ -8162,13 +8162,15 @@ package body Exp_Aggr is function Has_Mutable_Components (Typ : Entity_Id) return Boolean is Comp : Entity_Id; + Ctyp : Entity_Id; begin Comp := First_Component (Typ); while Present (Comp) loop - if Is_Record_Type (Etype (Comp)) - and then Has_Discriminants (Etype (Comp)) - and then not Is_Constrained (Etype (Comp)) + Ctyp := Underlying_Type (Etype (Comp)); + if Is_Record_Type (Ctyp) + and then Has_Discriminants (Ctyp) + and then not Is_Constrained (Ctyp) then return True; end if;