From patchwork Wed Sep 18 08:39:45 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: 1163843 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-509182-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="Z+lbHtUR"; 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 46YD5r0Q0wz9s4Y for ; Wed, 18 Sep 2019 18:43:27 +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=fAsQSg6LwIxLLkGg1Vjn+FStDUJayH9jDusSfhg3AM4mfVHB8T ol3Q+0KXtLab/VbWposw9/VC0t8bMECVHhcb2NGwFNuY3A/P7dFYXLaHvQUPe3a8 bWOCKgE1TdMXmiEFl+eMbSDdMmqzybBdK9dS+n5BkvEvFhySLz9Yt/mp4= 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=0fBnK/0n1/Eje0xN2qcYW4IRzm4=; b=Z+lbHtUR7q6GR/GxxKfY DI9wGXPl5Lt9lldQxKT4veYul1KAtVsGYepirukaoQHsXq8pO65fofe617wLxZln tzxrmo7BAJ3I9fmBI+r4NJJW9Epr5RsZvXTXIjVg04PScoCLBHbQAhoF7dPQ3ohU 5bxw7+yu4awQX8TS0YPK55s= Received: (qmail 104076 invoked by alias); 18 Sep 2019 08:40:15 -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 101891 invoked by uid 89); 18 Sep 2019 08:39:58 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-10.8 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, SPF_NEUTRAL autolearn=ham version=3.3.1 spammy=fat, miranda@adacore.com, U*miranda, mirandaadacorecom 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; Wed, 18 Sep 2019 08:39:55 +0000 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1iAVV9-0008Go-WB for gcc-patches@gcc.gnu.org; Wed, 18 Sep 2019 04:39:54 -0400 Received: from rock.gnat.com ([2620:20:4000:0:a9e:1ff:fe9b:1d1]:53797) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1iAVV7-0008Ew-5m for gcc-patches@gcc.gnu.org; Wed, 18 Sep 2019 04:39:49 -0400 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 617F7117D22; Wed, 18 Sep 2019 04:39:45 -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 NC84OvL4RhLC; Wed, 18 Sep 2019 04:39:45 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 2DDB9117D0C; Wed, 18 Sep 2019 04:39:45 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 2C9A1702; Wed, 18 Sep 2019 04:39:45 -0400 (EDT) Date: Wed, 18 Sep 2019 04:39:45 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Fix portability issues in access to subprograms Message-ID: <20190918083945.GA145176@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: 2620:20:4000:0:a9e:1ff:fe9b:1d1 X-IsSubscribed: yes This patch improves the portability of the code generated by the compiler for access to subprograms. Written by Richard Kenner. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-09-18 Javier Miranda gcc/ada/ * exp_ch4.adb (Expand_N_Op_Eq): The frontend assumes that we can do a bit-for-bit comparison of two access to protected subprogram pointers. However, there are two reasons why we may not be able to do that: (1) there may be padding bits for alignment before the access to subprogram, and (2) the access to subprogram itself may not be compared bit-for- bit because the activation record part is undefined: two pointers are equal iff the subprogram addresses are equal. This patch fixes it by forcing a field-by-field comparison. * bindgen.adb (Gen_Adainit): The type No_Param_Proc is defined in the library as having Favor_Top_Level, but when we create an object of that type in the binder file we don't have that pragma, so the types are different. This patch fixes this issue. * libgnarl/s-interr.adb, libgnarl/s-interr__hwint.adb, libgnarl/s-interr__sigaction.adb, libgnarl/s-interr__vxworks.adb (Is_Registered): This routine erroneously assumes that the access to protected subprogram is two addresses. We need to create the same record that the compiler makes to ensure that any padding is the same. Then we have to look at just the first word of the access to subprogram. This patch fixes this issue. --- gcc/ada/bindgen.adb +++ gcc/ada/bindgen.adb @@ -524,6 +524,7 @@ package body Bindgen is and then not Configurable_Run_Time_On_Target then WBI (" type No_Param_Proc is access procedure;"); + WBI (" pragma Favor_Top_Level (No_Param_Proc);"); WBI (""); end if; --- gcc/ada/exp_ch4.adb +++ gcc/ada/exp_ch4.adb @@ -8221,6 +8221,32 @@ package body Exp_Ch4 is Insert_Actions (N, Bodies, Suppress => All_Checks); Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); end if; + + -- If unnesting, handle elementary types whose Equivalent_Types are + -- records because there may be padding or undefined fields. + + elsif Unnest_Subprogram_Mode + and then Ekind_In (Typl, E_Class_Wide_Type, + E_Class_Wide_Subtype, + E_Access_Subprogram_Type, + E_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type, + E_Access_Subprogram_Type, + E_Exception_Type) + and then Present (Equivalent_Type (Typl)) + and then Is_Record_Type (Equivalent_Type (Typl)) + then + Typl := Equivalent_Type (Typl); + Remove_Side_Effects (Lhs); + Remove_Side_Effects (Rhs); + Rewrite (N, + Expand_Record_Equality (N, Typl, + Unchecked_Convert_To (Typl, Lhs), + Unchecked_Convert_To (Typl, Rhs), + Bodies)); + + Insert_Actions (N, Bodies, Suppress => All_Checks); + Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); end if; -- Test if result is known at compile time @@ -9497,10 +9523,21 @@ package body Exp_Ch4 is Typ : constant Entity_Id := Etype (Left_Opnd (N)); begin - -- Case of elementary type with standard operator + -- Case of elementary type with standard operator. But if + -- unnesting, handle elementary types whose Equivalent_Types are + -- records because there may be padding or undefined fields. if Is_Elementary_Type (Typ) and then Sloc (Entity (N)) = Standard_Location + and then not (Ekind_In (Typ, E_Class_Wide_Type, + E_Class_Wide_Subtype, + E_Access_Subprogram_Type, + E_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type, + E_Access_Subprogram_Type, + E_Exception_Type) + and then Present (Equivalent_Type (Typ)) + and then Is_Record_Type (Equivalent_Type (Typ))) then Binary_Op_Validity_Checks (N); --- gcc/ada/libgnarl/s-interr.adb +++ gcc/ada/libgnarl/s-interr.adb @@ -545,9 +545,11 @@ package body System.Interrupts is function Is_Registered (Handler : Parameterless_Handler) return Boolean is + type Acc_Proc is access procedure; + type Fat_Ptr is record Object_Addr : System.Address; - Handler_Addr : System.Address; + Handler_Addr : Acc_Proc; end record; function To_Fat_Ptr is new Ada.Unchecked_Conversion @@ -565,7 +567,7 @@ package body System.Interrupts is Ptr := Registered_Handler_Head; while Ptr /= null loop - if Ptr.H = Fat.Handler_Addr then + if Ptr.H = Fat.Handler_Addr.all'Address then return True; end if; --- gcc/ada/libgnarl/s-interr__hwint.adb +++ gcc/ada/libgnarl/s-interr__hwint.adb @@ -561,9 +561,12 @@ package body System.Interrupts is ------------------- function Is_Registered (Handler : Parameterless_Handler) return Boolean is + + type Acc_Proc is access procedure; + type Fat_Ptr is record Object_Addr : System.Address; - Handler_Addr : System.Address; + Handler_Addr : Acc_Proc; end record; function To_Fat_Ptr is new Ada.Unchecked_Conversion @@ -581,7 +584,7 @@ package body System.Interrupts is Ptr := Registered_Handler_Head; while Ptr /= null loop - if Ptr.H = Fat.Handler_Addr then + if Ptr.H = Fat.Handler_Addr.all'Address then return True; end if; --- gcc/ada/libgnarl/s-interr__sigaction.adb +++ gcc/ada/libgnarl/s-interr__sigaction.adb @@ -487,9 +487,11 @@ package body System.Interrupts is function Is_Registered (Handler : Parameterless_Handler) return Boolean is Ptr : R_Link := Registered_Handlers; + type Acc_Proc is access procedure; + type Fat_Ptr is record Object_Addr : System.Address; - Handler_Addr : System.Address; + Handler_Addr : Acc_Proc; end record; function To_Fat_Ptr is new Ada.Unchecked_Conversion @@ -505,7 +507,7 @@ package body System.Interrupts is Fat := To_Fat_Ptr (Handler); while Ptr /= null loop - if Ptr.H = Fat.Handler_Addr then + if Ptr.H = Fat.Handler_Addr.all'Address then return True; end if; --- gcc/ada/libgnarl/s-interr__vxworks.adb +++ gcc/ada/libgnarl/s-interr__vxworks.adb @@ -578,9 +578,12 @@ package body System.Interrupts is ------------------- function Is_Registered (Handler : Parameterless_Handler) return Boolean is + + type Acc_Proc is access procedure; + type Fat_Ptr is record Object_Addr : System.Address; - Handler_Addr : System.Address; + Handler_Addr : Acc_Proc; end record; function To_Fat_Ptr is new Ada.Unchecked_Conversion @@ -598,7 +601,7 @@ package body System.Interrupts is Ptr := Registered_Handler_Head; while Ptr /= null loop - if Ptr.H = Fat.Handler_Addr then + if Ptr.H = Fat.Handler_Addr.all'Address then return True; end if;