Patchwork [Ada] Runtime check on assignment to tagged types

login
register
mail settings
Submitter Arnaud Charlet
Date Feb. 6, 2013, 10:24 a.m.
Message ID <20130206102430.GA25518@adacore.com>
Download mbox | patch
Permalink /patch/218533/
State New
Headers show

Comments

Arnaud Charlet - Feb. 6, 2013, 10:24 a.m.
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.

Patch

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