From patchwork Fri Dec 13 09:55:01 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: 1209062 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-515861-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="iAfeg2LW"; 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 47Z5hD11RGz9sP6 for ; Fri, 13 Dec 2019 20:58:03 +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=mqbkWb1wKbFIJplNlrTss0Zk2ojJGD0x/Bzkce8Om/C9E8+y9n sHM/I1VAF8xmj+WIxdNWaIbY/H+IXuK372WMFTdGMxjG3YIIskCbTgO00hpAFBJB GXNtmXpFgTCI3JUhoAtNgTl4c4ED1gx8+GNfdzi/JpK9FzGvKSXyBpxig= 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=k+T8JJk7wV6wPqnvDEm+XerhGqY=; b=iAfeg2LWl+WWSh2CafOg k40m+zcZc6rIOIypSPxdLUqYbtUsA7AXUXwGcadigVpg7ZIvLeBh8YQaaYG90cN0 kdIZfJwQPiV0Fzucyb+dKppqcaCUiHivoqZYeAFpcFWUarhNZLX1RvxlFE0oHVho rhiK53BqUcGWQ+NV/UX/Q/s= Received: (qmail 37392 invoked by alias); 13 Dec 2019 09:55:14 -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 37109 invoked by uid 89); 13 Dec 2019 09:55:13 -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=covers 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; Fri, 13 Dec 2019 09:55:11 +0000 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ifhf8-0006Pd-Vo for gcc-patches@gcc.gnu.org; Fri, 13 Dec 2019 04:55:08 -0500 Received: from rock.gnat.com ([205.232.38.15]:60338) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1ifhf8-0006Om-PT for gcc-patches@gcc.gnu.org; Fri, 13 Dec 2019 04:55:06 -0500 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id C6B70560A2; Fri, 13 Dec 2019 04:55:01 -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 Zhu+dm9sdoE0; Fri, 13 Dec 2019 04:55:01 -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 AE59E560CF; Fri, 13 Dec 2019 04:55:01 -0500 (EST) Received: by tron.gnat.com (Postfix, from userid 4862) id AD6B6157; Fri, 13 Dec 2019 04:55:01 -0500 (EST) Date: Fri, 13 Dec 2019 04:55:01 -0500 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Deallocation of controlled type implementing interface types Message-ID: <20191213095501.GA13959@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 [fuzzy] X-Received-From: 205.232.38.15 X-IsSubscribed: yes The code generated by the compiler to deallocate a controlled type that has variable size components and implements interface types computes a wrong address (and crashes at runtime). Tested on x86_64-pc-linux-gnu, committed on trunk 2019-12-13 Javier Miranda gcc/ada/ * exp_disp.ads (Expand_Interface_Thunk): Adding one formal (the interface type). * exp_disp.adb (Expand_Interface_Thunk): Using the added formal to ensure the correct profile of the thunk generated for predefined primitives; in addition, the added formal is also used to perform a check that ensures that the controlling type of the thunk is the one expected by the GCC backend. (Make_Secondary_DT, Register_Primitive): Adding the new formal to the calls to Expand_Interface_Thunk. * exp_ch6.adb (Register_Predefined_DT_Entry): Adding the new formal to the call to Expand_Interface_Thunk. * exp_intr.adb (Expand_Unc_Deallocation): When deallocating a controlled type and the call to unchecked deallocation is performed with a pointer to one of the convered interface types, displace the pointer to the object to reference the base of the object to deallocate its memory. * gcc-interface/trans.c (maybe_make_gnu_thunk): Assert that the controlling type of the thunk is an interface type. --- gcc/ada/exp_ch6.adb +++ gcc/ada/exp_ch6.adb @@ -7607,7 +7607,8 @@ package body Exp_Ch6 is and then Ekind (Node (Iface_DT_Ptr)) = E_Constant loop pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); - Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, + Iface => Related_Type (Node (Iface_DT_Ptr))); if Present (Thunk_Code) then Insert_Actions_After (N, New_List ( --- gcc/ada/exp_disp.adb +++ gcc/ada/exp_disp.adb @@ -1850,7 +1850,8 @@ package body Exp_Disp is procedure Expand_Interface_Thunk (Prim : Node_Id; Thunk_Id : out Entity_Id; - Thunk_Code : out Node_Id) + Thunk_Code : out Node_Id; + Iface : Entity_Id) is Loc : constant Source_Ptr := Sloc (Prim); Actuals : constant List_Id := New_List; @@ -1912,12 +1913,38 @@ package body Exp_Disp is -- Use the interface type as the type of the controlling formal (see -- comment above). - if not Is_Controlling_Formal (Formal) or else Is_Predef_Op then + if not Is_Controlling_Formal (Formal) then Ftyp := Etype (Formal); Expr := New_Copy_Tree (Expression (Parent (Formal))); + + -- For predefined primitives the controlling type of the thunk is + -- the interface type passed by the caller (since they don't have + -- available the Interface_Alias attribute; see comment above). + + elsif Is_Predef_Op then + Ftyp := Iface; + Expr := Empty; + else Ftyp := Etype (Iface_Formal); Expr := Empty; + + -- Sanity check performed to ensure the proper controlling type + -- when the thunk has exactly one controlling parameter and it + -- comes first. In such case the GCC backend reuses the C++ + -- thunks machinery which perform a computation equivalent to + -- the code generated by the expander; for other cases the GCC + -- backend translates the expanded code unmodified. However, as + -- a generalization, the check is performed for all controlling + -- types. + + if Is_Access_Type (Ftyp) then + pragma Assert (Base_Type (Designated_Type (Ftyp)) = Iface); + null; + else + Ftyp := Base_Type (Ftyp); + pragma Assert (Ftyp = Iface); + end if; end if; Append_To (Formals, @@ -4073,7 +4100,8 @@ package body Exp_Disp is Alias (Prim); else - Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + Expand_Interface_Thunk + (Prim, Thunk_Id, Thunk_Code, Iface); if Present (Thunk_Id) then Append_To (Result, Thunk_Code); @@ -4379,7 +4407,8 @@ package body Exp_Disp is Prim_Table (Prim_Pos) := Alias (Prim); else - Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + Expand_Interface_Thunk + (Prim, Thunk_Id, Thunk_Code, Iface); if Present (Thunk_Id) then Prim_Pos := @@ -7507,7 +7536,7 @@ package body Exp_Disp is return L; end if; - Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, Iface_Typ); if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True) and then Present (Thunk_Code) --- gcc/ada/exp_disp.ads +++ gcc/ada/exp_disp.ads @@ -242,7 +242,8 @@ package Exp_Disp is procedure Expand_Interface_Thunk (Prim : Node_Id; Thunk_Id : out Entity_Id; - Thunk_Code : out Node_Id); + Thunk_Code : out Node_Id; + Iface : Entity_Id); -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we -- generate additional subprograms (thunks) associated with each primitive -- Prim to have a layout compatible with the C++ ABI. The thunk displaces --- gcc/ada/exp_intr.adb +++ gcc/ada/exp_intr.adb @@ -988,9 +988,31 @@ package body Exp_Intr is -- are allowed, the generated code may lack block statements. if Needs_Fin then - Obj_Ref := - Make_Explicit_Dereference (Loc, - Prefix => Duplicate_Subexpr_No_Checks (Arg)); + + -- Ada 2005 (AI-251): In case of abstract interface type we displace + -- the pointer to reference the base of the object to deallocate its + -- memory, unless we're targetting a VM, in which case no special + -- processing is required. + + if Is_Interface (Directly_Designated_Type (Typ)) + and then Tagged_Type_Expansion + then + Obj_Ref := + Make_Explicit_Dereference (Loc, + Prefix => + Unchecked_Convert_To (Typ, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Base_Address), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + Duplicate_Subexpr_No_Checks (Arg)))))); + + else + Obj_Ref := + Make_Explicit_Dereference (Loc, + Prefix => Duplicate_Subexpr_No_Checks (Arg)); + end if; -- If the designated type is tagged, the finalization call must -- dispatch because the designated type may not be the actual type --- gcc/ada/gcc-interface/trans.c +++ gcc/ada/gcc-interface/trans.c @@ -11287,11 +11287,12 @@ maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk) const Entity_Id gnat_controlling_type = get_controlling_type (gnat_target); const Entity_Id gnat_interface_type = get_controlling_type (gnat_thunk); + /* We must have an interface type at this point. */ + gcc_assert (Is_Interface (gnat_interface_type)); + /* Now compute whether the former covers the latter. */ const Entity_Id gnat_interface_tag - = Is_Interface (gnat_interface_type) - ? Find_Interface_Tag (gnat_controlling_type, gnat_interface_type) - : Empty; + = Find_Interface_Tag (gnat_controlling_type, gnat_interface_type); tree gnu_interface_tag = Present (gnat_interface_tag) ? gnat_to_gnu_field_decl (gnat_interface_tag)