[Ada] constrained discriminated records and SRA

[Ada] constrained discriminated records and SRA

[Eric Botcazou]

[-- Attachment #1: Type: text/plain, Size: 2268 bytes --]

The way gigi translates certain constrained discriminated record types is not 
correct.  Starting with

  type Rec (D : Boolean) is record
    case D is
      when True => I : Integer;
      when False => F : Float;
    end case;
  end record;

gigi translates the 3 constrained subtypes in

  procedure P (B : Boolean) is
    R1 : Rec (True);
    R2 : Rec (False);
    R3 : Rec (B);
  begin
    null;
  end;

the same way, i.e. into flat RECORD_TYPEs.  While that's correct for the 
first 2 subtypes since they are statically constrained, that's wrong for the 
third subtype since the constraint is not static: R3 can contain either I or 
F depending on the value of B so the RECORD_TYPE is built with both fields at 
the same offset.  If SRA happens to break apart the RECORD_TYPE and you have 
code like

  if B then
    R3.I := ...
  else
    R3.F := ...
  end if;

then Bad Things can happen since this can be rewritten as

  r3$i := R3.I;
  r3$f := R3.F;

  if B then
    r3$i := ...
  else
    r3$f := ...
  end if;

  R3.I := r3$i;
  R3.F := r3$f;

and R3.I will not be changed even if B is true.

The attached patch implements a correct approach, which is to build a nest of 
variants using QUAL_UNION_TYPE, modeled on that of the type, if the subtype 
is not statically constrained.


Martin, this should make it possible to get rid of

	  /* Some ADA records are half-unions, treat all of them the same.  */
	  for (fld = TYPE_FIELDS (type); fld; fld = TREE_CHAIN (fld))

and the associated special handling in the new SRA pass.


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


2009-09-29  Eric Botcazou  <ebotcazou@adacore.com>

	* decl.c (gnat_to_gnu_entity) <E_Record_Subtype>: Rewrite the handling
	of constrained discriminated record subtypes.
	(components_to_record): Declare the type of the variants and of the
	qualified union.
	(build_subst_list): Move around.
	(compute_field_positions): Rename into...
 	(build_position_list): ...this.  Return a TREE_VEC.
	(annotate_rep): Adjust for above renaming.
	(build_variant_list): New static function.
	(create_field_decl_from): Likewise.
	(get_rep_part): Likewise.
	(get_variant_part): Likewise.
	(create_variant_part_from): Likewise.
	(copy_and_substitute_in_size): Likewise.

-- 
Eric Botcazou

[-- Attachment #2: p.diff --]
[-- Type: text/x-diff, Size: 31727 bytes --]

Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c	(revision 152264)
+++ gcc-interface/decl.c	(working copy)
@@ -122,7 +122,6 @@ enum alias_set_op
 
 static void relate_alias_sets (tree, tree, enum alias_set_op);
 
-static tree build_subst_list (Entity_Id, Entity_Id, bool);
 static bool allocatable_size_p (tree, bool);
 static void prepend_one_attribute_to (struct attrib **,
 				      enum attr_type, tree, tree, Node_Id);
@@ -142,14 +141,21 @@ static void components_to_record (tree, 
 				  bool, bool, bool, bool, bool);
 static Uint annotate_value (tree);
 static void annotate_rep (Entity_Id, tree);
-static tree compute_field_positions (tree, tree, tree, tree, unsigned int);
+static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
+static tree build_subst_list (Entity_Id, Entity_Id, bool);
+static tree build_variant_list (tree, tree, tree);
 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
 static void set_rm_size (Uint, tree, Entity_Id);
 static tree make_type_from_size (tree, tree, bool);
 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
 static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
 static void check_ok_for_atomic (tree, Entity_Id, bool);
-static int compatible_signatures_p (tree ftype1, tree ftype2);
+static int compatible_signatures_p (tree, tree);
+static tree create_field_decl_from (tree, tree, tree, tree, tree, tree);
+static tree get_rep_part (tree);
+static tree get_variant_part (tree);
+static tree create_variant_part_from (tree, tree, tree, tree, tree);
+static void copy_and_substitute_in_size (tree, tree, tree);
 static void rest_of_type_decl_compilation_no_defer (tree);
 \f
 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
@@ -3085,9 +3091,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	    }
 
 	  /* When the subtype has discriminants and these discriminants affect
-	     the initial shape it has inherited, factor them in.  But for the
-	     of an Unchecked_Union (it must be an Itype), just return the type.
-
+	     the initial shape it has inherited, factor them in.  But for an
+	     Unchecked_Union (it must be an Itype), just return the type.
 	     We can't just test Is_Constrained because private subtypes without
 	     discriminants of types with discriminants with default expressions
 	     are Is_Constrained but aren't constrained!  */
@@ -3101,43 +3106,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	    {
 	      tree gnu_subst_list
 		= build_subst_list (gnat_entity, gnat_base_type, definition);
-	      tree gnu_pos_list, gnu_field_list = NULL_TREE;
-	      tree gnu_unpad_base_type, t;
+	      tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t;
+	      tree gnu_variant_list, gnu_pos_list, gnu_field_list = NULL_TREE;
+	      bool selected_variant = false;
 	      Entity_Id gnat_field;
 
 	      gnu_type = make_node (RECORD_TYPE);
 	      TYPE_NAME (gnu_type) = gnu_entity_name;
 
 	      /* Set the size, alignment and alias set of the new type to
-		 match that of the old one, doing required substitutions.
-		 We do it this early because we need the size of the new
-		 type below to discard old fields if necessary.  */
-	      TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
-	      TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
-	      SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
-	      TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
-	      relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
-
-	      if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
-		for (t = gnu_subst_list; t; t = TREE_CHAIN (t))
-		  TYPE_SIZE (gnu_type)
-		    = substitute_in_expr (TYPE_SIZE (gnu_type),
-					  TREE_PURPOSE (t),
-					  TREE_VALUE (t));
-
-	      if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
-		for (t = gnu_subst_list; t; t = TREE_CHAIN (t))
-		  TYPE_SIZE_UNIT (gnu_type)
-		    = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
-					  TREE_PURPOSE (t),
-					  TREE_VALUE (t));
-
-	      if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
-		for (t = gnu_subst_list; t; t = TREE_CHAIN (t))
-		  SET_TYPE_ADA_SIZE
-		    (gnu_type, substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
-						   TREE_PURPOSE (t),
-						   TREE_VALUE (t)));
+		 match that of the old one, doing required substitutions.  */
+	      copy_and_substitute_in_size (gnu_type, gnu_base_type,
+					   gnu_subst_list);
 
 	      if (TREE_CODE (gnu_base_type) == RECORD_TYPE
 		  && TYPE_IS_PADDING_P (gnu_base_type))
@@ -3145,10 +3125,57 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	      else
 		gnu_unpad_base_type = gnu_base_type;
 
+	      /* Look for a REP part in the base type.  */
+	      gnu_rep_part = get_rep_part (gnu_unpad_base_type);
+
+	      /* Look for a variant part in the base type.  */
+	      gnu_variant_part = get_variant_part (gnu_unpad_base_type);
+
+	      /* If there is a variant part, we must compute whether the
+		 constraints statically select a particular variant.  If
+		 so, we simply drop the qualified union and flatten the
+		 list of fields.  Otherwise we'll build a new qualified
+		 union for the variants that are still relevant.  */
+	      if (gnu_variant_part)
+		{
+		  gnu_variant_list
+		    = build_variant_list (TREE_TYPE (gnu_variant_part),
+					  gnu_subst_list, NULL_TREE);
+
+		  /* If all the qualifiers are unconditionally true, the
+		     innermost variant is statically selected.  */
+		  selected_variant = true;
+		  for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
+		    if (!integer_onep (TREE_VEC_ELT (TREE_VALUE (t), 1)))
+		      {
+			selected_variant = false;
+			break;
+		      }
+
+		  /* Otherwise, create the new variants.  */
+		  if (!selected_variant)
+		    for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
+		      {
+			tree old_variant = TREE_PURPOSE (t);
+			tree new_variant = make_node (RECORD_TYPE);
+			TYPE_NAME (new_variant)
+			  = DECL_NAME (TYPE_NAME (old_variant));
+			copy_and_substitute_in_size (new_variant, old_variant,
+						     gnu_subst_list);
+			TREE_VEC_ELT (TREE_VALUE (t), 2) = new_variant;
+		      }
+		}
+	      else
+		{
+		  gnu_variant_list = NULL_TREE;
+		  selected_variant = false;
+		}
+
 	      gnu_pos_list
-		= compute_field_positions (gnu_unpad_base_type, NULL_TREE,
-					   size_zero_node, bitsize_zero_node,
-					   BIGGEST_ALIGNMENT);
+		= build_position_list (gnu_unpad_base_type,
+				       gnu_variant_list && !selected_variant,
+				       size_zero_node, bitsize_zero_node,
+				       BIGGEST_ALIGNMENT, NULL_TREE);
 
 	      for (gnat_field = First_Entity (gnat_entity);
 		   Present (gnat_field);
@@ -3166,16 +3193,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 		      = Original_Record_Component (gnat_field);
 		    tree gnu_old_field
 		      = gnat_to_gnu_field_decl (gnat_old_field);
-		    tree gnu_offset
-		      = TREE_VALUE
-			(purpose_member (gnu_old_field, gnu_pos_list));
-		    tree gnu_pos = TREE_PURPOSE (gnu_offset);
-		    tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset));
-		    tree gnu_field, gnu_field_type, gnu_size, gnu_new_pos;
-		    tree gnu_last = NULL_TREE;
-		    unsigned int offset_align
-		      = tree_low_cst
-			(TREE_PURPOSE (TREE_VALUE (gnu_offset)), 1);
+		    tree gnu_context = DECL_CONTEXT (gnu_old_field);
+		    tree gnu_field, gnu_field_type, gnu_size;
+		    tree gnu_cont_type, gnu_last = NULL_TREE;
 
 		    /* If the type is the same, retrieve the GCC type from the
 		       old field to take into account possible adjustments.  */
@@ -3219,67 +3239,50 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 		    else
 		      gnu_size = TYPE_SIZE (gnu_field_type);
 
-		    if (CONTAINS_PLACEHOLDER_P (gnu_pos))
-		      for (t = gnu_subst_list; t; t = TREE_CHAIN (t))
-			gnu_pos = substitute_in_expr (gnu_pos,
-						      TREE_PURPOSE (t),
-						      TREE_VALUE (t));
-
-		    /* If the position is now a constant, we can set it as the
-		       position of the field when we make it.  Otherwise, we
-		       need to deal with it specially below.  */
-		    if (TREE_CONSTANT (gnu_pos))
+		    /* If the context of the old field is the base type or its
+		       REP part (if any), put the field directly in the new
+		       type; otherwise look up the context in the variant list
+		       and put the field either in the new type if there is a
+		       selected variant or in one of the new variants.  */
+		    if (gnu_context == gnu_unpad_base_type
+		        || (gnu_rep_part
+			    && gnu_context == TREE_TYPE (gnu_rep_part)))
+		      gnu_cont_type = gnu_type;
+		    else
 		      {
-		        gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
-
-			/* Discard old fields that are outside the new type.
-			   This avoids confusing code scanning it to decide
-			   how to pass it to functions on some platforms.  */
-			if (TREE_CODE (gnu_new_pos) == INTEGER_CST
-			    && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST
-			    && !integer_zerop (gnu_size)
-			    && !tree_int_cst_lt (gnu_new_pos,
-						 TYPE_SIZE (gnu_type)))
+			t = purpose_member (gnu_context, gnu_variant_list);
+			if (t)
+			  {
+			    if (selected_variant)
+			      gnu_cont_type = gnu_type;
+			    else
+			      gnu_cont_type = TREE_VEC_ELT (TREE_VALUE (t), 2);
+			  }
+			else
+			  /* The front-end may pass us "ghost" components if
+			     it fails to recognize that a constrained subtype
+			     is statically constrained.  Discard them.  */
 			  continue;
 		      }
-		    else
-		      gnu_new_pos = NULL_TREE;
 
+		    /* Now create the new field modeled on the old one.  */
 		    gnu_field
-		      = create_field_decl
-			(DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
-			 DECL_PACKED (gnu_old_field), gnu_size, gnu_new_pos,
-			 !DECL_NONADDRESSABLE_P (gnu_old_field));
+		      = create_field_decl_from (gnu_old_field, gnu_field_type,
+						gnu_cont_type, gnu_size,
+						gnu_pos_list, gnu_subst_list);
 
-		    if (!TREE_CONSTANT (gnu_pos))
+		    /* Put it in one of the new variants directly.  */
+		    if (gnu_cont_type != gnu_type)
 		      {
-			normalize_offset (&gnu_pos, &gnu_bitpos, offset_align);
-			DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
-			DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
-			SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
-			DECL_SIZE (gnu_field) = gnu_size;
-			DECL_SIZE_UNIT (gnu_field)
-			  = convert (sizetype,
-				     size_binop (CEIL_DIV_EXPR, gnu_size,
-						 bitsize_unit_node));
-			layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
+			TREE_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
+			TYPE_FIELDS (gnu_cont_type) = gnu_field;
 		      }
 
-		    DECL_INTERNAL_P (gnu_field)
-		      = DECL_INTERNAL_P (gnu_old_field);
-		    SET_DECL_ORIGINAL_FIELD
-		      (gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field)
-				   ? DECL_ORIGINAL_FIELD (gnu_old_field)
-				   : gnu_old_field));
-		    DECL_DISCRIMINANT_NUMBER (gnu_field)
-		      = DECL_DISCRIMINANT_NUMBER (gnu_old_field);
-		    TREE_THIS_VOLATILE (gnu_field)
-		      = TREE_THIS_VOLATILE (gnu_old_field);
-
 		    /* To match the layout crafted in components_to_record,
 		       if this is the _Tag or _Parent field, put it before
 		       any other fields.  */
-		    if (gnat_name == Name_uTag || gnat_name == Name_uParent)
+		    else if (gnat_name == Name_uTag
+			     || gnat_name == Name_uParent)
 		      gnu_field_list = chainon (gnu_field_list, gnu_field);
 
 		    /* Similarly, if this is the _Controller field, put
@@ -3304,6 +3307,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 		    save_gnu_tree (gnat_field, gnu_field, false);
 		  }
 
+	      /* If there is a variant list and no selected variant, we need
+		 to create the nest of variant parts from the old nest.  */
+	      if (gnu_variant_list && !selected_variant)
+		{
+		  tree new_variant_part
+		    = create_variant_part_from (gnu_variant_part,
+						gnu_variant_list, gnu_type,
+						gnu_pos_list, gnu_subst_list);
+		  TREE_CHAIN (new_variant_part) = gnu_field_list;
+		  gnu_field_list = new_variant_part;
+		}
+
 	      /* Now go through the entities again looking for Itypes that
 		 we have not elaborated but should (e.g., Etypes of fields
 		 that have Original_Components).  */
@@ -3318,11 +3333,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	      gnu_field_list = nreverse (gnu_field_list);
 	      finish_record_type (gnu_type, gnu_field_list, 2, true);
 
-	      /* Finalize size and mode.  */
-	      TYPE_SIZE (gnu_type) = variable_size (TYPE_SIZE (gnu_type));
-	      TYPE_SIZE_UNIT (gnu_type)
-		= variable_size (TYPE_SIZE_UNIT (gnu_type));
-
 	      /* See the E_Record_Type case for the rationale.  */
 	      if (Is_Tagged_Type (gnat_entity)
 		  || Is_Limited_Record (gnat_entity))
@@ -5549,37 +5559,6 @@ relate_alias_sets (tree gnu_new_type, tr
   record_component_aliases (gnu_new_type);
 }
 \f
-/* Return a TREE_LIST describing the substitutions needed to reflect the
-   discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE.  They can
-   be in any order.  TREE_PURPOSE gives the tree for the discriminant and
-   TREE_VALUE is the replacement value.  They are in the form of operands
-   to substitute_in_expr.  DEFINITION is true if this is for a definition
-   of GNAT_SUBTYPE.  */
-
-static tree
-build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
-{
-  tree gnu_list = NULL_TREE;
-  Entity_Id gnat_discrim;
-  Node_Id gnat_value;
-
-  for (gnat_discrim = First_Stored_Discriminant (gnat_type),
-       gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
-       Present (gnat_discrim);
-       gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
-       gnat_value = Next_Elmt (gnat_value))
-    /* Ignore access discriminants.  */
-    if (!Is_Access_Type (Etype (Node (gnat_value))))
-      gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
-			    elaborate_expression
-			    (Node (gnat_value), gnat_subtype,
-			     get_entity_name (gnat_discrim), definition,
-			     true, false),
-			    gnu_list);
-
-  return gnu_list;
-}
-\f
 /* Return true if the size represented by GNU_SIZE can be handled by an
    allocation.  If STATIC_P is true, consider only what can be done with a
    static allocation.  */
@@ -6959,6 +6938,8 @@ components_to_record (tree gnu_record_ty
 		 otherwise, the union type definition will be lacking
 		 the fields associated with these empty variants.  */
 	      rest_of_record_type_compilation (gnu_variant_type);
+	      create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
+				NULL, true, debug_info_p, gnat_component_list);
 
 	      gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
 					     gnu_union_type, field_packed,
@@ -7005,6 +6986,9 @@ components_to_record (tree gnu_record_ty
 	      return;
 	    }
 
+	  create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type,
+			    NULL, true, debug_info_p, gnat_component_list);
+
 	  /* Deal with packedness like in gnat_to_gnu_field.  */
 	  union_field_packed
 	    = adjust_packed (gnu_union_type, gnu_record_type, packed);
@@ -7310,8 +7294,9 @@ annotate_rep (Entity_Id gnat_entity, tre
 
   /* We operate by first making a list of all fields and their position (we
      can get the size easily) and then update all the sizes in the tree.  */
-  gnu_list = compute_field_positions (gnu_type, NULL_TREE, size_zero_node,
-				      bitsize_zero_node, BIGGEST_ALIGNMENT);
+  gnu_list
+    = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
+			   BIGGEST_ALIGNMENT, NULL_TREE);
 
   for (gnat_field = First_Entity (gnat_entity);
        Present (gnat_field);
@@ -7346,9 +7331,8 @@ annotate_rep (Entity_Id gnat_entity, tre
 	      (gnat_field,
 	       annotate_value
 		 (size_binop (PLUS_EXPR,
-			      bit_from_pos (TREE_PURPOSE (TREE_VALUE (t)),
-					    TREE_VALUE (TREE_VALUE
-							(TREE_VALUE (t)))),
+			      bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
+					    TREE_VEC_ELT (TREE_VALUE (t), 2)),
 			      parent_offset)));
 
 	    Set_Esize (gnat_field,
@@ -7368,17 +7352,17 @@ annotate_rep (Entity_Id gnat_entity, tre
       }
 }
 \f
-/* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
-   FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
-   position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
-   placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position.  GNU_POS is
-   to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
-   the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
-   so far.  */
+/* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
+   the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
+   value to be placed into DECL_OFFSET_ALIGN and the bit position.  The list
+   of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
+   is set to true.  GNU_POS is to be added to the position, GNU_BITPOS to the
+   bit position, OFFSET_ALIGN is the present offset alignment.  GNU_LIST is a
+   pre-existing list to be chained to the newly created entries.  */
 
 static tree
-compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
-			 tree gnu_bitpos, unsigned int offset_align)
+build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
+		     tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
 {
   tree gnu_field;
 
@@ -7392,20 +7376,109 @@ compute_field_positions (tree gnu_type, 
 					DECL_FIELD_OFFSET (gnu_field));
       unsigned int our_offset_align
 	= MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
+      tree v = make_tree_vec (3);
 
-      gnu_list
-	= tree_cons (gnu_field,
-		     tree_cons (gnu_our_offset,
-				tree_cons (size_int (our_offset_align),
-					   gnu_our_bitpos, NULL_TREE),
-				NULL_TREE),
-		     gnu_list);
+      TREE_VEC_ELT (v, 0) = gnu_our_offset;
+      TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
+      TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
+      gnu_list = tree_cons (gnu_field, v, gnu_list);
 
+      /* Recurse on internal fields, flattening the nested fields except for
+	 those in the variant part, if requested.  */
       if (DECL_INTERNAL_P (gnu_field))
-	gnu_list
-	  = compute_field_positions (TREE_TYPE (gnu_field), gnu_list,
+	{
+	  tree gnu_field_type = TREE_TYPE (gnu_field);
+	  if (do_not_flatten_variant
+	      && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
+	    gnu_list
+	      = build_position_list (gnu_field_type, do_not_flatten_variant,
+				     size_zero_node, bitsize_zero_node,
+				     BIGGEST_ALIGNMENT, gnu_list);
+	  else
+	    gnu_list
+	      = build_position_list (gnu_field_type, do_not_flatten_variant,
 				     gnu_our_offset, gnu_our_bitpos,
-				     our_offset_align);
+				     our_offset_align, gnu_list);
+	}
+    }
+
+  return gnu_list;
+}
+
+/* Return a TREE_LIST describing the substitutions needed to reflect the
+   discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE.  They can
+   be in any order.  TREE_PURPOSE gives the tree for the discriminant and
+   TREE_VALUE is the replacement value.  They are in the form of operands
+   to SUBSTITUTE_IN_EXPR.  DEFINITION is true if this is for a definition
+   of GNAT_SUBTYPE.  */
+
+static tree
+build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
+{
+  tree gnu_list = NULL_TREE;
+  Entity_Id gnat_discrim;
+  Node_Id gnat_value;
+
+  for (gnat_discrim = First_Stored_Discriminant (gnat_type),
+       gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
+       Present (gnat_discrim);
+       gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
+       gnat_value = Next_Elmt (gnat_value))
+    /* Ignore access discriminants.  */
+    if (!Is_Access_Type (Etype (Node (gnat_value))))
+      gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
+			    elaborate_expression
+			    (Node (gnat_value), gnat_subtype,
+			     get_entity_name (gnat_discrim), definition,
+			     true, false),
+			    gnu_list);
+
+  return gnu_list;
+}
+
+/* Scan all fields in QUAL_UNION_TYPE and return a TREE_LIST describing the
+   variants of QUAL_UNION_TYPE that are still relevant after applying the
+   substitutions described in SUBST_LIST.  TREE_PURPOSE is the type of the
+   variant and TREE_VALUE is a TREE_VEC containing the field, the new value
+   of the qualifier and NULL_TREE respectively.  GNU_LIST is a pre-existing
+   list to be chained to the newly created entries.  */
+
+static tree
+build_variant_list (tree qual_union_type, tree subst_list, tree gnu_list)
+{
+  tree gnu_field;
+
+  for (gnu_field = TYPE_FIELDS (qual_union_type);
+       gnu_field;
+       gnu_field = TREE_CHAIN (gnu_field))
+    {
+      tree t, qual = DECL_QUALIFIER (gnu_field);
+
+      for (t = subst_list; t; t = TREE_CHAIN (t))
+	qual = SUBSTITUTE_IN_EXPR (qual, TREE_PURPOSE (t), TREE_VALUE (t));
+
+      /* If the new qualifier is not unconditionally false, its variant may
+	 still be accessed.  */
+      if (!integer_zerop (qual))
+	{
+	  tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
+	  tree v = make_tree_vec (3);
+	  TREE_VEC_ELT (v, 0) = gnu_field;
+	  TREE_VEC_ELT (v, 1) = qual;
+	  TREE_VEC_ELT (v, 2) = NULL_TREE;
+	  gnu_list = tree_cons (variant_type, v, gnu_list);
+
+	  /* Recurse on the variant subpart of the variant, if any.  */
+	  variant_subpart = get_variant_part (variant_type);
+	  if (variant_subpart)
+	    gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
+					   subst_list, gnu_list);
+
+	  /* If the new qualifier is unconditionally true, the subsequent
+	     variants cannot be accessed.  */
+	  if (integer_onep (qual))
+	    break;
+	}
     }
 
   return gnu_list;
@@ -7916,6 +7989,253 @@ compatible_signatures_p (tree ftype1, tr
   return 1;
 }
 \f
+/* Return a FIELD_DECL node modeled on OLD_FIELD.  FIELD_TYPE is its type
+   and RECORD_TYPE is the type of the parent.  If SIZE is nonzero, it is the
+   specified size for this field.  POS_LIST is a position list describing
+   the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
+   to this layout.  */
+
+static tree
+create_field_decl_from (tree old_field, tree field_type, tree record_type,
+			tree size, tree pos_list, tree subst_list)
+{
+  tree t = TREE_VALUE (purpose_member (old_field, pos_list));
+  tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
+  unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1);
+  tree new_pos, new_field;
+
+  if (CONTAINS_PLACEHOLDER_P (pos))
+    for (t = subst_list; t; t = TREE_CHAIN (t))
+      pos = SUBSTITUTE_IN_EXPR (pos, TREE_PURPOSE (t), TREE_VALUE (t));
+
+  /* If the position is now a constant, we can set it as the position of the
+     field when we make it.  Otherwise, we need to deal with it specially.  */
+  if (TREE_CONSTANT (pos))
+    new_pos = bit_from_pos (pos, bitpos);
+  else
+    new_pos = NULL_TREE;
+
+  new_field
+    = create_field_decl (DECL_NAME (old_field), field_type, record_type,
+			 DECL_PACKED (old_field), size, new_pos,
+			 !DECL_NONADDRESSABLE_P (old_field));
+
+  if (!new_pos)
+    {
+      normalize_offset (&pos, &bitpos, offset_align);
+      DECL_FIELD_OFFSET (new_field) = pos;
+      DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
+      SET_DECL_OFFSET_ALIGN (new_field, offset_align);
+      DECL_SIZE (new_field) = size;
+      DECL_SIZE_UNIT (new_field)
+	= convert (sizetype,
+		   size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
+      layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
+    }
+
+  DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
+  t = DECL_ORIGINAL_FIELD (old_field);
+  SET_DECL_ORIGINAL_FIELD (new_field, t ? t : old_field);
+  DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
+  TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
+
+  return new_field;
+}
+
+/* Return the REP part of RECORD_TYPE, if any.  Otherwise return NULL.  */
+
+static tree
+get_rep_part (tree record_type)
+{
+  tree field = TYPE_FIELDS (record_type);
+
+  /* The REP part is the first field, internal, another record, and its name
+     doesn't start with an underscore (i.e. is not generated by the FE).  */
+  if (DECL_INTERNAL_P (field)
+      && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
+      && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_')
+    return field;
+
+  return NULL_TREE;
+}
+
+/* Return the variant part of RECORD_TYPE, if any.  Otherwise return NULL.  */
+
+static tree
+get_variant_part (tree record_type)
+{
+  tree field;
+
+  /* The variant part is the only internal field that is a qualified union.  */
+  for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
+    if (DECL_INTERNAL_P (field)
+	&& TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
+      return field;
+
+  return NULL_TREE;
+}
+
+/* Return a new variant part modeled on OLD_VARIANT_PART.  VARIANT_LIST is
+   the list of variants to be used and RECORD_TYPE is the type of the parent.
+   POS_LIST is a position list describing the layout of fields present in
+   OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
+   layout.  */
+
+static tree
+create_variant_part_from (tree old_variant_part, tree variant_list,
+			  tree record_type, tree pos_list, tree subst_list)
+{
+  tree offset = DECL_FIELD_OFFSET (old_variant_part);
+  tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
+  tree old_union_type = TREE_TYPE (old_variant_part);
+  tree new_union_type, new_variant_part, t;
+  tree union_field_list = NULL_TREE;
+
+  /* First create the type of the variant part from that of the old one.  */
+  new_union_type = make_node (QUAL_UNION_TYPE);
+  TYPE_NAME (new_union_type) = DECL_NAME (TYPE_NAME (old_union_type));
+
+  /* If the position of the variant part is constant, subtract it from the
+     size of the type of the parent to get the new size.  This manual CSE
+     reduces the code size when not optimizing.  */
+  if (TREE_CODE (offset) == INTEGER_CST && TREE_CODE (bitpos) == INTEGER_CST)
+    {
+      tree first_bit = bit_from_pos (offset, bitpos);
+      TYPE_SIZE (new_union_type)
+	= size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
+      TYPE_SIZE_UNIT (new_union_type)
+	= size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
+		      byte_from_pos (offset, bitpos));
+      SET_TYPE_ADA_SIZE (new_union_type,
+			 size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
+ 				     first_bit));
+      TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
+      relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
+    }
+  else
+    copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
+
+  /* Now finish up the new variants and populate the union type.  */
+  for (t = variant_list; t; t = TREE_CHAIN (t))
+    {
+      tree old_field = TREE_VEC_ELT (TREE_VALUE (t), 0), new_field;
+      tree old_variant, old_variant_subpart, new_variant, field_list;
+
+      /* Skip variants that don't belong to this nesting level.  */
+      if (DECL_CONTEXT (old_field) != old_union_type)
+	continue;
+
+      /* Retrieve the list of fields already added to the new variant.  */
+      new_variant = TREE_VEC_ELT (TREE_VALUE (t), 2);
+      field_list = TYPE_FIELDS (new_variant);
+
+      /* If the old variant had a variant subpart, we need to create a new
+	 variant subpart and add it to the field list.  */
+      old_variant = TREE_PURPOSE (t);
+      old_variant_subpart = get_variant_part (old_variant);
+      if (old_variant_subpart)
+	{
+	  tree new_variant_subpart
+	    = create_variant_part_from (old_variant_subpart, variant_list,
+					new_variant, pos_list, subst_list);
+	  TREE_CHAIN (new_variant_subpart) = field_list;
+	  field_list = new_variant_subpart;
+	}
+
+      /* Finish up the new variant and create the field.  */
+      finish_record_type (new_variant, nreverse (field_list), 2, true);
+      compute_record_mode (new_variant);
+      rest_of_record_type_compilation (new_variant);
+
+      /* No need for debug info thanks to the XVS type.  */
+      create_type_decl (TYPE_NAME (new_variant), new_variant, NULL,
+			true, false, Empty);
+
+      new_field
+	= create_field_decl_from (old_field, new_variant, new_union_type,
+				  TYPE_SIZE (new_variant),
+				  pos_list, subst_list);
+      DECL_QUALIFIER (new_field) = TREE_VEC_ELT (TREE_VALUE (t), 1);
+      DECL_INTERNAL_P (new_field) = 1;
+      TREE_CHAIN (new_field) = union_field_list;
+      union_field_list = new_field;
+    }
+
+  /* Finish up the union type and create the variant part.  */
+  finish_record_type (new_union_type, union_field_list, 2, true);
+  compute_record_mode (new_union_type);
+  rest_of_record_type_compilation (new_union_type);
+
+  /* No need for debug info thanks to the XVS type.  */
+  create_type_decl (TYPE_NAME (new_union_type), new_union_type, NULL,
+		    true, false, Empty);
+
+  new_variant_part
+    = create_field_decl_from (old_variant_part, new_union_type, record_type,
+			      TYPE_SIZE (new_union_type),
+			      pos_list, subst_list);
+  DECL_INTERNAL_P (new_variant_part) = 1;
+
+  /* With multiple discriminants it is possible for an inner variant to be
+     statically selected while outer ones are not; in this case, the list
+     of fields of the inner variant is not flattened and we end up with a
+     qualified union with a single member.  Drop the useless container.  */
+  if (!TREE_CHAIN (union_field_list))
+    {
+      DECL_CONTEXT (union_field_list) = record_type;
+      DECL_FIELD_OFFSET (union_field_list)
+	= DECL_FIELD_OFFSET (new_variant_part);
+      DECL_FIELD_BIT_OFFSET (union_field_list)
+	= DECL_FIELD_BIT_OFFSET (new_variant_part);
+      SET_DECL_OFFSET_ALIGN (union_field_list,
+			     DECL_OFFSET_ALIGN (new_variant_part));
+      new_variant_part = union_field_list;
+    }
+
+  return new_variant_part;
+}
+
+/* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
+   which are both RECORD_TYPE, after applying the substitutions described
+   in SUBST_LIST.  */
+
+static void
+copy_and_substitute_in_size (tree new_type, tree old_type, tree subst_list)
+{
+  tree t;
+
+  TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
+  TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
+  SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
+  TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
+  relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
+
+  if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
+    for (t = subst_list; t; t = TREE_CHAIN (t))
+      TYPE_SIZE (new_type)
+	= SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
+			      TREE_PURPOSE (t),
+			      TREE_VALUE (t));
+
+  if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
+    for (t = subst_list; t; t = TREE_CHAIN (t))
+      TYPE_SIZE_UNIT (new_type)
+	= SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
+			      TREE_PURPOSE (t),
+			      TREE_VALUE (t));
+
+  if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
+    for (t = subst_list; t; t = TREE_CHAIN (t))
+      SET_TYPE_ADA_SIZE
+	(new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
+				       TREE_PURPOSE (t),
+				       TREE_VALUE (t)));
+
+  /* Finalize the size.  */
+  TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
+  TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
+}
+\f
 /* Given a type T, a FIELD_DECL F, and a replacement value R, return a
    type with all size expressions that contain F in a PLACEHOLDER_EXPR
    updated by replacing F with R.

Re: [Ada] constrained discriminated records and SRA

[Eric Botcazou]

[-- Attachment #1: Type: text/plain, Size: 424 bytes --]

> Martin, this should make it possible to get rid of
>
> 	  /* Some ADA records are half-unions, treat all of them the same.  */
> 	  for (fld = TYPE_FIELDS (type); fld; fld = TREE_CHAIN (fld))
>
> and the associated special handling in the new SRA pass.

I've installed the attached patchlet.


2009-10-16  Eric Botcazou  <ebotcazou@adacore.com>

	* tree-sra.c (build_ref_for_offset_1): Update comment.


-- 
Eric Botcazou

[-- Attachment #2: p.diff --]
[-- Type: text/x-diff, Size: 598 bytes --]

Index: tree-sra.c
===================================================================
--- tree-sra.c	(revision 152797)
+++ tree-sra.c	(working copy)
@@ -1231,7 +1231,8 @@ build_ref_for_offset_1 (tree *res, tree 
 	case UNION_TYPE:
 	case QUAL_UNION_TYPE:
 	case RECORD_TYPE:
-	  /* Some ADA records are half-unions, treat all of them the same.  */
+	  /* ??? Some records used to be half-unions in Ada so the code treats
+	     the 3 container types the same.  This has been fixed in Ada.  */
 	  for (fld = TYPE_FIELDS (type); fld; fld = TREE_CHAIN (fld))
 	    {
 	      HOST_WIDE_INT pos, size;

Re: [Ada] constrained discriminated records and SRA

[Martin Jambor]

Hi Eric,

On Fri, Oct 16, 2009 at 08:58:13AM +0200, Eric Botcazou wrote:
> > Martin, this should make it possible to get rid of
> >
> > 	  /* Some ADA records are half-unions, treat all of them the same.  */
> > 	  for (fld = TYPE_FIELDS (type); fld; fld = TREE_CHAIN (fld))
> >
> > and the associated special handling in the new SRA pass.
> 

sorry for replying so late.  The reason for this comment was that
originally I handled unions and records differently, recursing only
for unions and picking the right fields and looping for records.  This
did not work because of overlapping fields in records that Ada
produced.  I am happy to learn that is not happening any more,
however, I am not sure that splitting the code paths again now is
worth the effort as the overhead is not probably going to be that big
and shared code paths are also good from the maintenance point of
view.

So my suggestion would be to remove the whole comment, or replace it
with something saying that if looking up stuff in records is deemed
too slow in future, we should be able to simplify it now.

Thanks,

Martin

> I've installed the attached patchlet.
> 
> 
> 2009-10-16  Eric Botcazou  <ebotcazou@adacore.com>
> 
> 	* tree-sra.c (build_ref_for_offset_1): Update comment.
> 
> 
> -- 
> Eric Botcazou

> Index: tree-sra.c
> ===================================================================
> --- tree-sra.c	(revision 152797)
> +++ tree-sra.c	(working copy)
> @@ -1231,7 +1231,8 @@ build_ref_for_offset_1 (tree *res, tree 
>  	case UNION_TYPE:
>  	case QUAL_UNION_TYPE:
>  	case RECORD_TYPE:
> -	  /* Some ADA records are half-unions, treat all of them the same.  */
> +	  /* ??? Some records used to be half-unions in Ada so the code treats
> +	     the 3 container types the same.  This has been fixed in Ada.  */
>  	  for (fld = TYPE_FIELDS (type); fld; fld = TREE_CHAIN (fld))
>  	    {
>  	      HOST_WIDE_INT pos, size;

Re: [Ada] constrained discriminated records and SRA

[Eric Botcazou]

> So my suggestion would be to remove the whole comment, or replace it
> with something saying that if looking up stuff in records is deemed
> too slow in future, we should be able to simplify it now.

FWIW fine with me either way.

-- 
Eric Botcazou

Re: [Ada] constrained discriminated records and SRA

[Martin Jambor]

Hi,

On Thu, Oct 22, 2009 at 01:40:22PM +0200, Eric Botcazou wrote:
> > So my suggestion would be to remove the whole comment, or replace it
> > with something saying that if looking up stuff in records is deemed
> > too slow in future, we should be able to simplify it now.
> 
> FWIW fine with me either way.

I have committed the following change as revision 153751.

Thanks,

Martin

2009-10-30  Martin Jambor  <mjambor@suse.cz>

	* tree-sra.c (build_ref_for_offset_1): Remove a comment.

Index: mine/gcc/tree-sra.c
===================================================================
--- mine.orig/gcc/tree-sra.c
+++ mine/gcc/tree-sra.c
@@ -1231,8 +1231,6 @@ build_ref_for_offset_1 (tree *res, tree
 	case UNION_TYPE:
 	case QUAL_UNION_TYPE:
 	case RECORD_TYPE:
-	  /* ??? Some records used to be half-unions in Ada so the code treats
-	     the 3 container types the same.  This has been fixed in Ada.  */
 	  for (fld = TYPE_FIELDS (type); fld; fld = TREE_CHAIN (fld))
 	    {
 	      HOST_WIDE_INT pos, size;


> 
> -- 
> Eric Botcazou