[Ada] Do not generate VIEW_CONVERT_EXPR for upcasting

[Eric Botcazou <ebotcazou at adacore dot com>]

Unlike the C++ compiler, the Ada compiler generates VIEW_CONVERT_EXPR for even 
the simplest upcast:

  type Root is tagged null record;

  type Derived1 is new Root with record
    I1 : Integer;
  end record;

  R : Root;
  D : Derived1;

  R := Root(D1);

is tranlated into:

assign ((struct root &) &r, (struct root &) &VIEW_CONVERT_EXPR<struct 
root>(d1))


That isn't well defined according to tree.def and unnecessarily cumbersome 
compared with the natural:

p___assign ((struct p__root &) &r, (struct p__root &) &d1._parent);

so the attached patch implements the latter form.


Tested on i586-suse-linux, applied on the mainline.


2010-04-13  Eric Botcazou  <ebotcazou@adacore.com>

	* gcc-interface/gigi.h (standard_datatypes): Add ADT_parent_name_id.
	(parent_name_id): New macro.
	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: Use it.
	* gcc-interface/trans.c (gigi): Initialize it.
	(lvalue_required_p) <N_Type_Conversion>: New case.
	<N_Qualified_Expression>: Likewise.
	<N_Allocator>: Likewise.
	* gcc-interface/utils.c (convert): Try to properly upcast tagged types.


2010-04-13  Eric Botcazou  <ebotcazou@adacore.com>

	* gnat.dg/derived_type1.adb: New test.


-- 
Eric Botcazou

-- { dg-do compile }
-- { dg-options "-gnatws -fdump-tree-original" }

procedure Derived_Type1 is

  type Root is tagged null record;

  type Derived1 is new Root with record
    I1 : Integer;
  end record;

  type Derived2 is new Derived1 with record
    I2: Integer;
  end record;

  R : Root;
  D1 : Derived1;
  D2 : Derived2;

begin
  R  := Root(D1);
  R  := Root(D2);
  D1 := Derived1(D2);
end;

-- { dg-final { scan-tree-dump-not "VIEW_CONVERT_EXPR<struct derived_type1__root>" "original" } }
-- { dg-final { scan-tree-dump-not "VIEW_CONVERT_EXPR<struct derived_type1__derived1>" "original" } }
-- { dg-final { cleanup-tree-dump "original" } }

Index: gcc-interface/utils.c
===================================================================
--- gcc-interface/utils.c	(revision 158254)
+++ gcc-interface/utils.c	(working copy)
@@ -4027,6 +4027,19 @@ convert (tree type, tree expr)
 					   etype)))
     return build1 (VIEW_CONVERT_EXPR, type, expr);
 
+  /* If we are converting between tagged types, try to upcast properly.  */
+  else if (ecode == RECORD_TYPE && code == RECORD_TYPE
+	   && TYPE_ALIGN_OK (etype) && TYPE_ALIGN_OK (type))
+    {
+      tree child_etype = etype;
+      do {
+	tree field = TYPE_FIELDS (child_etype);
+	if (DECL_NAME (field) == parent_name_id && TREE_TYPE (field) == type)
+	  return build_component_ref (expr, NULL_TREE, field, false);
+	child_etype = TREE_TYPE (field);
+      } while (TREE_CODE (child_etype) == RECORD_TYPE);
+    }
+
   /* In all other cases of related types, make a NOP_EXPR.  */
   else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)
 	   || (code == INTEGER_CST && ecode == INTEGER_CST
Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c	(revision 158254)
+++ gcc-interface/decl.c	(working copy)
@@ -2851,8 +2851,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 
 	    /* ...and reference the _Parent field of this record.  */
 	    gnu_field
-	      = create_field_decl (get_identifier
-				   (Get_Name_String (Name_uParent)),
+	      = create_field_decl (parent_name_id,
 				   gnu_parent, gnu_type, 0,
 				   has_rep
 				   ? TYPE_SIZE (gnu_parent) : NULL_TREE,
@@ -4392,6 +4391,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
      handling alignment and possible padding.  */
   if (is_type && (!gnu_decl || this_made_decl))
     {
+      /* Tell the middle-end that objects of tagged types are guaranteed to
+	 be properly aligned.  This is necessary because conversions to the
+	 class-wide type are translated into conversions to the root type,
+	 which can be less aligned than some of its derived types.  */
       if (Is_Tagged_Type (gnat_entity)
 	  || Is_Class_Wide_Equivalent_Type (gnat_entity))
 	TYPE_ALIGN_OK (gnu_type) = 1;
Index: gcc-interface/gigi.h
===================================================================
--- gcc-interface/gigi.h	(revision 158254)
+++ gcc-interface/gigi.h	(working copy)
@@ -374,9 +374,12 @@ enum standard_datatypes
   /* Likewise for freeing memory.  */
   ADT_free_decl,
 
-  /* Function decl node for 64-bit multiplication with overflow checking */
+  /* Function decl node for 64-bit multiplication with overflow checking.  */
   ADT_mulv64_decl,
 
+  /* Identifier for the name of the _Parent field in tagged record types.  */
+  ADT_parent_name_id,
+
   /* Types and decls used by our temporary exception mechanism.  See
      init_gigi_decls for details.  */
   ADT_jmpbuf_type,
@@ -408,6 +411,7 @@ extern GTY(()) tree gnat_raise_decls[(in
 #define malloc32_decl gnat_std_decls[(int) ADT_malloc32_decl]
 #define free_decl gnat_std_decls[(int) ADT_free_decl]
 #define mulv64_decl gnat_std_decls[(int) ADT_mulv64_decl]
+#define parent_name_id gnat_std_decls[(int) ADT_parent_name_id]
 #define jmpbuf_type gnat_std_decls[(int) ADT_jmpbuf_type]
 #define jmpbuf_ptr_type gnat_std_decls[(int) ADT_jmpbuf_ptr_type]
 #define get_jmpbuf_decl gnat_std_decls[(int) ADT_get_jmpbuf_decl]
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c	(revision 158254)
+++ gcc-interface/trans.c	(working copy)
@@ -396,6 +396,9 @@ gigi (Node_Id gnat_root, int max_gnat_no
 						     int64_type, NULL_TREE),
 			   NULL_TREE, false, true, true, NULL, Empty);
 
+  /* Name of the _Parent field in tagged record types.  */
+  parent_name_id = get_identifier (Get_Name_String (Name_uParent));
+
   /* Make the types and functions used for exception processing.  */
   jmpbuf_type
     = build_array_type (gnat_type_for_mode (Pmode, 0),
@@ -794,13 +797,29 @@ lvalue_required_p (Node_Id gnat_node, tr
 	      || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
 		  && Is_Atomic (Entity (Name (gnat_parent)))));
 
+    case N_Type_Conversion:
+    case N_Qualified_Expression:
+      /* We must look through all conversions for composite types because we
+	 may need to bypass an intermediate conversion to a narrower record
+	 type that is generated for a formal conversion, e.g. the conversion
+	 to the root type of a hierarchy of tagged types generated for the
+	 formal conversion to the class-wide type.  */
+      if (!Is_Composite_Type (Underlying_Type (Etype (gnat_node))))
+	return 0;
+
+      /* ... fall through ... */
+
     case N_Unchecked_Type_Conversion:
-      /* Returning 0 is very likely correct but we get better code if we
-	 go through the conversion.  */
       return lvalue_required_p (gnat_parent,
 				get_unpadded_type (Etype (gnat_parent)),
 				constant, address_of_constant, aliased);
 
+    case N_Allocator:
+      /* We should only reach here through the N_Qualified_Expression case
+	 and, therefore, only for composite types.  Force an lvalue since
+	 a block-copy to the newly allocated area of memory is made.  */
+      return 1;
+
    case N_Explicit_Dereference:
       /* We look through dereferences for address of constant because we need
 	 to handle the special cases listed above.  */