From: Ed Schonberg <schonberg@adacore.com>
Date: Mon, 1 Jul 2019 13:36:56 +0000 (+0000)
Subject: [Ada] Wrong code with -gnatVa on lock-free protected objects
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=90fd73bbeaad8438a3251e061f8f6525691f3c30;p=gcc.git

[Ada] Wrong code with -gnatVa on lock-free protected objects

This patch fixes the handling of validity checks on protected objects
that use the Lock-Free implementation when validity checks are enabled,
previous to this patch the compiler would report improperly that a
condition in a protected operation was always True (when comoipled with
-gnatwa) and would generate incorrect code fhat operation.

2019-07-01  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* checks.adb (Insert_Valid_Check): Do not apply validity check
	to variable declared within a protected object that uses the
	Lock_Free implementation, to prevent unwarranted constant
	folding, because entities within such an object msut be treated
	as volatile.

gcc/testsuite/

	* gnat.dg/prot7.adb, gnat.dg/prot7.ads: New testcase.

From-SVN: r272873
---

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c60b957641b..bf6e1c386a0 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,11 @@
+2019-07-01  Ed Schonberg  <schonberg@adacore.com>
+
+	* checks.adb (Insert_Valid_Check): Do not apply validity check
+	to variable declared within a protected object that uses the
+	Lock_Free implementation, to prevent unwarranted constant
+	folding, because entities within such an object msut be treated
+	as volatile.
+
 2019-07-01  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* exp_ch9.adb (Check_Inlining): Deal with Has_Pragma_No_Inline.
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index fcfaec7d470..e851c5f702f 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -7429,6 +7429,19 @@ package body Checks is
          return;
       end if;
 
+      --  Entities declared in Lock_free protected types must be treated
+      --  as volatile, and we must inhibit validity checks to prevent
+      --  improper constant folding.
+
+      if Is_Entity_Name (Expr)
+        and then Is_Subprogram (Scope (Entity (Expr)))
+        and then Present (Protected_Subprogram (Scope (Entity (Expr))))
+        and then Uses_Lock_Free
+           (Scope (Protected_Subprogram (Scope (Entity (Expr)))))
+      then
+         return;
+      end if;
+
       --  If we have a checked conversion, then validity check applies to
       --  the expression inside the conversion, not the result, since if
       --  the expression inside is valid, then so is the conversion result.
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ef255f5a312..4d49ad3de83 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2019-07-01  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/prot7.adb, gnat.dg/prot7.ads: New testcase.
+
 2019-07-01  Richard Biener  <rguenther@suse.de>
 
 	* gcc.dg/gimplefe-42.c: New testcase.
diff --git a/gcc/testsuite/gnat.dg/prot7.adb b/gcc/testsuite/gnat.dg/prot7.adb
new file mode 100644
index 00000000000..6051ef0054f
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/prot7.adb
@@ -0,0 +1,22 @@
+--  { dg-do compile }
+--  { dg-options "-gnatwa -gnatVa" }
+
+package body Prot7 is
+   protected body Default_Slice is
+      function Get return Instance_Pointer is
+      begin
+         return Default;
+      end Get;
+
+      procedure Set (
+        Discard : in out Boolean;
+        Slice   : in     Instance_Pointer
+      ) is
+      begin
+         Discard := Default /= null;
+         if not Discard then
+            Default := Slice;
+         end if;
+      end Set;
+   end Default_Slice;
+end Prot7;
diff --git a/gcc/testsuite/gnat.dg/prot7.ads b/gcc/testsuite/gnat.dg/prot7.ads
new file mode 100644
index 00000000000..5e06e26db35
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/prot7.ads
@@ -0,0 +1,16 @@
+package Prot7 is
+   type Instance_Pointer is access Integer;
+
+   protected Default_Slice
+        with Lock_Free
+   is
+      function Get return Instance_Pointer;
+
+      procedure Set (
+        Discard : in out Boolean;
+        Slice   : in     Instance_Pointer
+      );
+   private
+      Default : Instance_Pointer;
+   end Default_Slice;
+end Prot7;