From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 26141 invoked by alias); 26 Sep 2011 09:30:32 -0000 Received: (qmail 21207 invoked by uid 22791); 26 Sep 2011 09:21:49 -0000 X-SWARE-Spam-Status: No, hits=-1.9 required=5.0 tests=AWL,BAYES_00 X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (194.98.77.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 26 Sep 2011 09:21:26 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 470D5CB0262 for ; Mon, 26 Sep 2011 11:21:26 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id AyogrBXhG+jA for ; Mon, 26 Sep 2011 11:21:16 +0200 (CEST) Received: from [192.168.1.2] (bon31-9-83-155-120-49.fbx.proxad.net [83.155.120.49]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by mel.act-europe.fr (Postfix) with ESMTP id ADC91CB0215 for ; Mon, 26 Sep 2011 11:21:15 +0200 (CEST) From: Eric Botcazou To: gcc-patches@gcc.gnu.org Subject: [Ada] Fix ICE with unconstrained array types and inlining Date: Mon, 26 Sep 2011 10:22:00 -0000 User-Agent: KMail/1.9.9 MIME-Version: 1.0 Content-Type: Multipart/Mixed; boundary="Boundary-00=_bNEgOVdDZjE3abS" Message-Id: <201109261118.19706.ebotcazou@adacore.com> Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org X-SW-Source: 2011-09/txt/msg01571.txt.bz2 --Boundary-00=_bNEgOVdDZjE3abS Content-Type: text/plain; charset="us-ascii" Content-Transfer-Encoding: 7bit Content-Disposition: inline Content-length: 649 It may arise on platforms with conditional execution because of an awkward CFG, but it ultimately comes from a discrepancy in the way we translate allocation expressions for unconstrained array types in gigi. Tested on i586-suse-linux, applied on the mainline. 2011-09-26 Eric Botcazou * gcc-interface/utils2.c (build_allocator): Set TREE_THIS_NOTRAP on the dereference of the pointer to the storage area. Remove useless type conversions and factor out common code. 2011-09-26 Eric Botcazou * gnat.dg/opt20.ad[sb]: New test. * gnat.dg/opt20_pkg.ads: New helper. -- Eric Botcazou --Boundary-00=_bNEgOVdDZjE3abS Content-Type: text/x-diff; charset="iso 8859-15"; name="p.diff" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="p.diff" Content-length: 5495 Index: gcc-interface/utils2.c =================================================================== --- gcc-interface/utils2.c (revision 179184) +++ gcc-interface/utils2.c (working copy) @@ -2112,9 +2112,9 @@ build_call_alloc_dealloc (tree gnu_obj, } } -/* Build a GCC tree to correspond to allocating an object of TYPE whose +/* Build a GCC tree that corresponds to allocating an object of TYPE whose initial value is INIT, if INIT is nonzero. Convert the expression to - RESULT_TYPE, which must be some type of pointer. Return the tree. + RESULT_TYPE, which must be some pointer type, and return the result. GNAT_PROC and GNAT_POOL optionally give the procedure to call and the storage pool to use. GNAT_NODE is used to provide an error @@ -2127,8 +2127,7 @@ tree build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, Entity_Id gnat_pool, Node_Id gnat_node, bool ignore_init_type) { - tree size = TYPE_SIZE_UNIT (type); - tree result; + tree size, storage, storage_deref, storage_init; /* If the initializer, if present, is a NULL_EXPR, just return a new one. */ if (init && TREE_CODE (init) == NULL_EXPR) @@ -2154,19 +2153,19 @@ build_allocator (tree type, tree init, t get_identifier ("ALLOC"), false); tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type)); tree storage_ptr_type = build_pointer_type (storage_type); - tree storage; size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type), init); - /* If the size overflows, pass -1 so the allocator will raise - storage error. */ + /* If the size overflows, pass -1 so Storage_Error will be raised. */ if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size)) size = ssize_int (-1); storage = build_call_alloc_dealloc (NULL_TREE, size, storage_type, gnat_proc, gnat_pool, gnat_node); storage = convert (storage_ptr_type, gnat_protect_expr (storage)); + storage_deref = build_unary_op (INDIRECT_REF, NULL_TREE, storage); + TREE_THIS_NOTRAP (storage_deref) = 1; /* If there is an initializing expression, then make a constructor for the entire object including the bounds and copy it into the object. @@ -2179,29 +2178,24 @@ build_allocator (tree type, tree init, t build_template (template_type, type, init)); CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (storage_type)), init); - return convert - (result_type, - build2 (COMPOUND_EXPR, storage_ptr_type, - build_binary_op - (MODIFY_EXPR, NULL_TREE, - build_unary_op (INDIRECT_REF, NULL_TREE, - convert (storage_ptr_type, storage)), - gnat_build_constructor (storage_type, v)), - convert (storage_ptr_type, storage))); + storage_init + = build_binary_op (MODIFY_EXPR, NULL_TREE, storage_deref, + gnat_build_constructor (storage_type, v)); } else - return build2 - (COMPOUND_EXPR, result_type, - build_binary_op - (MODIFY_EXPR, NULL_TREE, - build_component_ref - (build_unary_op (INDIRECT_REF, NULL_TREE, - convert (storage_ptr_type, storage)), - NULL_TREE, TYPE_FIELDS (storage_type), false), - build_template (template_type, type, NULL_TREE)), - convert (result_type, convert (storage_ptr_type, storage))); + storage_init + = build_binary_op (MODIFY_EXPR, NULL_TREE, + build_component_ref (storage_deref, NULL_TREE, + TYPE_FIELDS (storage_type), + false), + build_template (template_type, type, NULL_TREE)); + + return build2 (COMPOUND_EXPR, result_type, + storage_init, convert (result_type, storage)); } + size = TYPE_SIZE_UNIT (type); + /* If we have an initializing expression, see if its size is simpler than the size from the type. */ if (!ignore_init_type && init && TYPE_SIZE_UNIT (TREE_TYPE (init)) @@ -2221,32 +2215,28 @@ build_allocator (tree type, tree init, t size = max_size (size, true); } - /* If the size overflows, pass -1 so the allocator will raise - storage error. */ + /* If the size overflows, pass -1 so Storage_Error will be raised. */ if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size)) size = ssize_int (-1); - result = convert (result_type, - build_call_alloc_dealloc (NULL_TREE, size, type, - gnat_proc, gnat_pool, - gnat_node)); + storage = convert (result_type, + build_call_alloc_dealloc (NULL_TREE, size, type, + gnat_proc, gnat_pool, + gnat_node)); /* If we have an initial value, protect the new address, assign the value and return the address with a COMPOUND_EXPR. */ if (init) { - result = gnat_protect_expr (result); - result - = build2 (COMPOUND_EXPR, TREE_TYPE (result), - build_binary_op - (MODIFY_EXPR, NULL_TREE, - build_unary_op (INDIRECT_REF, - TREE_TYPE (TREE_TYPE (result)), result), - init), - result); + storage = gnat_protect_expr (storage); + storage_deref = build_unary_op (INDIRECT_REF, NULL_TREE, storage); + TREE_THIS_NOTRAP (storage_deref) = 1; + storage_init + = build_binary_op (MODIFY_EXPR, NULL_TREE, storage_deref, init); + return build2 (COMPOUND_EXPR, result_type, storage_init, storage); } - return convert (result_type, result); + return storage; } /* Indicate that we need to take the address of T and that it therefore --Boundary-00=_bNEgOVdDZjE3abS Content-Type: text/x-adasrc; charset="iso 8859-15"; name="opt20.adb" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="opt20.adb" Content-length: 450 with Ada.Characters.Handling; use Ada.Characters.Handling; package body Opt20 is type Build_Mode_State is (None, Static, Dynamic, Relocatable); procedure Build_Library (For_Project : Integer) is Project_Name : constant String := Get_Name_String (For_Project); The_Build_Mode : Build_Mode_State := None; begin Fail (Project_Name); Write_Str (To_Lower (Build_Mode_State'Image (The_Build_Mode))); end; end Opt20; --Boundary-00=_bNEgOVdDZjE3abS Content-Type: text/x-adasrc; charset="iso 8859-15"; name="opt20.ads" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="opt20.ads" Content-length: 168 -- { dg-do compile } -- { dg-options "-O2 -gnatpn" } with Opt20_Pkg; use Opt20_Pkg; package Opt20 is procedure Build_Library (For_Project : Integer); end Opt20; --Boundary-00=_bNEgOVdDZjE3abS Content-Type: text/x-adasrc; charset="iso 8859-15"; name="opt20_pkg.ads" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="opt20_pkg.ads" Content-length: 263 package Opt20_Pkg is procedure Write_Str (S : String); type Fail_Proc is access procedure (S : String); procedure My_Fail (S : String); Fail : Fail_Proc := My_Fail'Access; function Get_Name_String (Id : Integer) return String; end Opt20_Pkg; --Boundary-00=_bNEgOVdDZjE3abS--