From patchwork Thu Jan 11 09:15:18 2018 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: 858963 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-470808-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="TjtJy4Ri"; 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 3zHKyz6kPNz9t3h for ; Thu, 11 Jan 2018 20:17:31 +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:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=w1Oqebx/hF+3CEW3onsBvO92AJ/Af6NwZTkwqIvmwEFybfQGTR V82ywtK59YZijKoP0z+2Y/NBPIjeyG6vthwzx0EGOi3PgLSVrXZMPo2z9po07qYo ifKRv38MkNosz8rFmCGXQlzRU5Oe3CeOLMMGBqHaKSKr+FzJet2kzKWjc= 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=dFmS1tOmYMHBbFKweYzHg5S8mMw=; b=TjtJy4RigaWX06mzc48c W/yxgvjEORq9R7iXaxIVHP0sxkFsAY8dmJzEImRJSxlAKZ6XdQe13FbRsy1E4b8I uO3t5gVENXZU+jS8D1wWXAvOgdZ1sSRnXSx3/2QYh1P+KEaXFAvDltZYmznOgs5b CY+hdQ0x/LiL7YQV4OTSnUE= Received: (qmail 21777 invoked by alias); 11 Jan 2018 09:16:58 -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 20160 invoked by uid 89); 11 Jan 2018 09:15:37 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-11.9 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS, WEIRD_QUOTING autolearn=ham version=3.3.2 spammy=UD:E, contracts, Capture X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 11 Jan 2018 09:15:20 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 83F16117BC3; Thu, 11 Jan 2018 04:15:18 -0500 (EST) 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 T0AUfkyu564j; Thu, 11 Jan 2018 04:15:18 -0500 (EST) 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 729CD117BBE; Thu, 11 Jan 2018 04:15:18 -0500 (EST) Received: by tron.gnat.com (Postfix, from userid 4862) id 7156D50B; Thu, 11 Jan 2018 04:15:18 -0500 (EST) Date: Thu, 11 Jan 2018 04:15:18 -0500 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Crash on build-in-place call with address specification for target Message-ID: <20180111091518.GA105591@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes The presence of an address clause complicates the build-in-place expansion because the indicated address must be processed before the indirect call is generated, including the definition of a local pointer to the object. The address clause may come from an aspect specification or from an explicit attribute specification appearing after the object declaration. These two cases require different processing. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-01-11 Ed Schonberg gcc/ada/ * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): Handle properly object declarations with initializations that are build-in-place function calls, when there is an address specification, either as an aspect specification or an explicit attribute specification clause, for the initialized object. * freeze.adb (Check_Address_Clause): Do not remove side-effects from initial expressions in the case of a build-in-place call. gcc/testsuite/ * gnat.dg/bip_overlay.adb, gnat.dg/bip_overlay.ads: New testcase. --- gcc/ada/exp_ch6.adb +++ gcc/ada/exp_ch6.adb @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Aspects; use Aspects; with Checks; use Checks; with Contracts; use Contracts; with Debug; use Debug; @@ -8418,7 +8419,66 @@ package body Exp_Ch6 is -- freezing. if Definite and then not Is_Return_Object (Obj_Def_Id) then - Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl); + + -- The presence of an address clause complicates the build-in-place + -- expansion because the indicated address must be processed before + -- the indirect call is generated (including the definition of a + -- local pointer to the object). The address clause may come from + -- an aspect specification or from an explicit attribute + -- specification appearing after the object declaration. These two + -- cases require different processing. + + if Has_Aspect (Obj_Def_Id, Aspect_Address) then + + -- Skip non-delayed pragmas that correspond to other aspects, if + -- any, to find proper insertion point for freeze node of object. + + declare + D : Node_Id := Obj_Decl; + N : Node_Id := Next (D); + + begin + while Present (N) + and then Nkind_In (N, N_Pragma, N_Attribute_Reference) + loop + Analyze (N); + D := N; + Next (N); + end loop; + + Insert_After (D, Ptr_Typ_Decl); + + -- Freeze object before pointer declaration, to ensure that + -- generated attribute for address is inserted at the proper + -- place. + + Freeze_Before (Ptr_Typ_Decl, Obj_Def_Id); + end; + + Analyze (Ptr_Typ_Decl); + + elsif Present (Following_Address_Clause (Obj_Decl)) then + + -- Locate explicit address clause, which may also follow pragmas + -- generated by other aspect specifications. + + declare + Addr : constant Node_Id := Following_Address_Clause (Obj_Decl); + D : Node_Id := Next (Obj_Decl); + + begin + while Present (D) loop + Analyze (D); + exit when D = Addr; + Next (D); + end loop; + + Insert_After_And_Analyze (Addr, Ptr_Typ_Decl); + end; + + else + Insert_After_And_Analyze (Obj_Decl, Ptr_Typ_Decl); + end if; else Insert_Action (Obj_Decl, Ptr_Typ_Decl); end if;--- gcc/ada/freeze.adb +++ gcc/ada/freeze.adb @@ -711,11 +711,16 @@ package body Freeze is end; end if; - if Present (Init) then + -- Remove side effects from initial expression, except in the case + -- of a build-in-place call, which has its own later expansion. - -- Capture initialization value at point of declaration, - -- and make explicit assignment legal, because object may - -- be a constant. + if Present (Init) + and then (Nkind (Init) /= N_Function_Call + or else not Is_Expanded_Build_In_Place_Call (Init)) + then + + -- Capture initialization value at point of declaration, and make + -- explicit assignment legal, because object may be a constant. Remove_Side_Effects (Init); Lhs := New_Occurrence_Of (E, Sloc (Decl));--- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/bip_overlay.adb @@ -0,0 +1,23 @@ +-- { dg-do compile } + +with System; + +package body BIP_Overlay +with + SPARK_Mode +is + function Init return X + is + begin + return Result : X do + Result.E := 0; + end return; + end Init; + + I : X := Init + with + Volatile, + Async_Readers, + Address => System'To_Address (16#1234_5678#); + +end BIP_Overlay;--- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/bip_overlay.ads @@ -0,0 +1,22 @@ +package BIP_Overlay + with SPARK_Mode +is + type X (<>) is limited private; + + pragma Warnings (gnatprove, Off, + "volatile function ""Init"" has no volatile effects", + reason => "Init is a pure function but returns a volatile type."); + function Init return X + with + Volatile_Function; + +private + type A is limited record + E : Integer; + end record + with + Volatile; + -- and Async_Readers when implemented; + + type X is limited new A; +end BIP_Overlay;