From patchwork Wed Feb  6 10:24:30 2013
Content-Type: text/plain; charset="utf-8"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Subject: [Ada] Runtime check on assignment to tagged types
From: Arnaud Charlet <charlet@adacore.com>
X-Patchwork-Id: 218533
Message-Id: <20130206102430.GA25518@adacore.com>
To: gcc-patches@gcc.gnu.org
Cc: Javier Miranda <miranda@adacore.com>
Date: Wed, 6 Feb 2013 05:24:30 -0500

On assignments to tagged types the compiler unconditionally generates
the runtime check of the tag (even when compiling with -gnatp). After
this patch such extra runtime check is not generated.

package Test is
   type Tagged_Simple_Record is tagged
      record
         Field1 : Integer;
      end record;
   function F1 (This : Tagged_Simple_Record)
     return Tagged_Simple_Record;

   Global_SR : Tagged_Simple_Record;

   procedure Call_Dispatching_Ops
     (Class_Obj1 : Tagged_Simple_Record'Class;
      Class_Obj2 : out Tagged_Simple_Record'Class);
end Test;

package body Test is

   function F1 (This : Tagged_Simple_Record)
     return Tagged_Simple_Record is
   begin
      return This;
   end F1;

   procedure Call_Dispatching_Ops
     (Class_Obj1 : Tagged_Simple_Record'Class;
      Class_Obj2 : out Tagged_Simple_Record'Class) is
   begin
      Class_Obj2 := F1 (Class_Obj1);
   end Call_Dispatching_Ops;

end Test;

Command:
  gcc -c -gnatp -gnatD test.adb
  grep -i "tag check" test.adb.dg

Output:
  none

Tested on x86_64-pc-linux-gnu, committed on trunk

2013-02-06  Javier Miranda  <miranda@adacore.com>

	* exp_ch5.adb (Expand_N_Assignment_Statement): Do not generate the
	runtime check on assignment to tagged types if compiling with checks
	suppressed.


Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb	(revision 195792)
+++ exp_ch5.adb	(working copy)
@@ -2476,7 +2476,8 @@
                   --  the assignment we generate run-time check to ensure that
                   --  the tags of source and target match.
 
-                  if Is_Class_Wide_Type (Typ)
+                  if not Tag_Checks_Suppressed (Typ)
+                    and then Is_Class_Wide_Type (Typ)
                     and then Is_Tagged_Type (Typ)
                     and then Is_Tagged_Type (Underlying_Type (Etype (Rhs)))
                   then