utils.c (update_pointer_to): Make a copy of the couple of FIELD_DECLs when...

2007-04-06  Eric Botcazou <botcazou@adacore.com>
	    Olivier Hainque  <hainque@adacore.com>

	* utils.c (update_pointer_to): Make a copy of the couple of FIELD_DECLs
	when updating the contents of the old pointer to an unconstrained array.
	(end_subprog_body): Set error_gnat_node to Empty.
	(write_record_type_debug_info): Do not be unduly sparing with our bytes.
	(unchecked_convert): For subtype to base type conversions, require that
	the source be a subtype if it is an integer type.
	(builtin_decls): New global, vector of available builtin functions.
	(gnat_pushdecl): Add global builtin function declaration nodes to the
	builtin_decls list.
	(gnat_install_builtins): Adjust comments.
	(builtin_function): Set DECL_BUILTIN_CLASS and DECL_FUNCTION_CODE before
	calling gnat_pushdecl, so that it knows when it handed a builtin
	function declaration node.
	(builtin_decl_for): Search the builtin_decls list.

From-SVN: r123609

gcc/ada/utils.c

@@ -150,6 +150,9 @@ static GTY((deletable)) struct gnat_binding_level *free_binding_level;
 /* An array of global declarations.  */
 static GTY(()) VEC (tree,gc) *global_decls;
 
+/* An array of builtin declarations.  */
+static GTY(()) VEC (tree,gc) *builtin_decls;
+
 /* An array of global renaming pointers.  */
 static GTY(()) VEC (tree,gc) *global_renaming_pointers;
 
@@ -441,14 +444,20 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
 
   /* Put the declaration on the list.  The list of declarations is in reverse
      order. The list will be reversed later.  Put global variables in the
-     globals list. Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into the
-     list, as they will cause trouble with the debugger and aren't needed
+     globals list and builtin functions in a dedicated list to speed up
+     further lookups.  Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into
+     the list, as they will cause trouble with the debugger and aren't needed
      anyway.  */
   if (TREE_CODE (decl) != TYPE_DECL
       || TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE)
     {
       if (global_bindings_p ())
-	VEC_safe_push (tree, gc, global_decls, decl);
+	{
+	  VEC_safe_push (tree, gc, global_decls, decl);
+
+	  if (TREE_CODE (decl) == FUNCTION_DECL && DECL_BUILT_IN (decl))
+	    VEC_safe_push (tree, gc, builtin_decls, decl);
+	}
       else
 	{
 	  TREE_CHAIN (decl) = BLOCK_VARS (current_binding_level->block);
@@ -521,12 +530,12 @@ gnat_init_decl_processing (void)
   gnat_install_builtins ();
 }
 
-/* Install the builtin functions the middle-end needs.  */
+/* Install the builtin functions we might need.  */
 
 static void
 gnat_install_builtins ()
 {
-  /* Builtins used by generic optimizers.  */
+  /* Builtins used by generic middle-end optimizers.  */
   build_common_builtin_nodes ();
 
   /* Target specific builtins, such as the AltiVec family on ppc.  */
@@ -1020,7 +1029,30 @@ write_record_type_debug_info (tree record_type)
 	  if (!pos && TREE_CODE (curpos) == MULT_EXPR
 	      && TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST)
 	    {
-	      align = TREE_INT_CST_LOW (TREE_OPERAND (curpos, 1));
+	      /* An offset which is a bit-and operation with a negative
+		 power of 2 means an alignment corresponding to this power
+		 of 2.  */
+	      tree offset = TREE_OPERAND (curpos, 0);
+
+	      /* Strip off any conversions.  */
+	      while (TREE_CODE (offset) == NON_LVALUE_EXPR
+		     || TREE_CODE (offset) == NOP_EXPR
+		     || TREE_CODE (offset) == CONVERT_EXPR)
+		offset = TREE_OPERAND (offset, 0);
+
+	      if (TREE_CODE (offset) == BIT_AND_EXPR)
+		{
+		  int p = exact_log2
+		    (- TREE_INT_CST_LOW (TREE_OPERAND (offset, 1)));
+
+		  if (p < 0)
+		    p = 1;
+
+		  align = p * TREE_INT_CST_LOW (TREE_OPERAND (curpos, 1));
+		}
+	      else
+		align = TREE_INT_CST_LOW (TREE_OPERAND (curpos, 1));
+
 	      pos = compute_related_constant (curpos,
 					      round_up (last_pos, align));
 	    }
@@ -1061,16 +1093,10 @@ write_record_type_debug_info (tree record_type)
 	      var = true;
 	    }
 
-	  /* The heuristics above might get the alignment wrong.
-	     Adjust the obvious case where align is smaller than the
-	     alignments necessary for objects of field_type. */
-	  if (align < TYPE_ALIGN(field_type))
-	    align = TYPE_ALIGN(field_type);
-
 	  /* Make a new field name, if necessary.  */
 	  if (var || align != 0)
 	    {
-	      char suffix[6];
+	      char suffix[16];
 
 	      if (align != 0)
 		sprintf (suffix, "XV%c%u", var ? 'L' : 'A',
@@ -1103,10 +1129,10 @@ write_record_type_debug_info (tree record_type)
       TYPE_FIELDS (new_record_type)
 	= nreverse (TYPE_FIELDS (new_record_type));
 
-      rest_of_type_compilation (new_record_type, global_bindings_p ());
+      rest_of_type_compilation (new_record_type, true);
     }
 
-  rest_of_type_compilation (record_type, global_bindings_p ());
+  rest_of_type_compilation (record_type, true);
 }
 
 /* Utility function of above to merge LAST_SIZE, the previous size of a record
@@ -2098,6 +2124,9 @@ end_subprog_body (tree body)
   current_function_decl = DECL_CONTEXT (fndecl);
   cfun = NULL;
 
+  /* We cannot track the location of errors past this point.  */
+  error_gnat_node = Empty;
+
   /* If we're only annotating types, don't actually compile this function.  */
   if (type_annotate_only)
     return;
@@ -2924,35 +2953,36 @@ update_pointer_to (tree old_type, tree new_type)
   else
     {
       tree new_obj_rec = TYPE_OBJECT_RECORD_TYPE (new_type);
-      tree ptr_temp_type;
-      tree new_ref;
-      tree var;
+      tree fields = TYPE_FIELDS (TYPE_POINTER_TO (new_type));
+      tree new_fields, ptr_temp_type, new_ref, bounds, var;
 
-      SET_DECL_ORIGINAL_FIELD (TYPE_FIELDS (ptr),
-			       TYPE_FIELDS (TYPE_POINTER_TO (new_type)));
+      /* Replace contents of old pointer with those of new pointer.  */
+      new_fields = copy_node (fields);
+      TREE_CHAIN (new_fields) = copy_node (TREE_CHAIN (fields));
+
+      SET_DECL_ORIGINAL_FIELD (TYPE_FIELDS (ptr), new_fields);
       SET_DECL_ORIGINAL_FIELD (TREE_CHAIN (TYPE_FIELDS (ptr)),
-			       TREE_CHAIN (TYPE_FIELDS
-					   (TYPE_POINTER_TO (new_type))));
+			       TREE_CHAIN (new_fields));
 
-      TYPE_FIELDS (ptr) = TYPE_FIELDS (TYPE_POINTER_TO (new_type));
-      DECL_CONTEXT (TYPE_FIELDS (ptr)) = ptr;
-      DECL_CONTEXT (TREE_CHAIN (TYPE_FIELDS (ptr))) = ptr;
+      TYPE_FIELDS (ptr) = new_fields;
+      DECL_CONTEXT (new_fields) = ptr;
+      DECL_CONTEXT (TREE_CHAIN (new_fields)) = ptr;
 
-      /* Rework the PLACEHOLDER_EXPR inside the reference to the
-	 template bounds.
+      /* Rework the PLACEHOLDER_EXPR inside the reference to the template
+	 bounds and update the pointers to them.
 
 	 ??? This is now the only use of gnat_substitute_in_type, which
 	 is now a very "heavy" routine to do this, so it should be replaced
 	 at some point.  */
-      ptr_temp_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (ptr)));
+      bounds = TREE_TYPE (TREE_TYPE (new_fields));
+      ptr_temp_type = TREE_TYPE (TREE_CHAIN (new_fields));
       new_ref = build3 (COMPONENT_REF, ptr_temp_type,
 			build0 (PLACEHOLDER_EXPR, ptr),
-			TREE_CHAIN (TYPE_FIELDS (ptr)), NULL_TREE);
-
-      update_pointer_to
-	(TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
-	 gnat_substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
-				  TREE_CHAIN (TYPE_FIELDS (ptr)), new_ref));
+			TREE_CHAIN (new_fields), NULL_TREE);
+      update_pointer_to (bounds,
+			 gnat_substitute_in_type (bounds,
+						  TREE_CHAIN (fields),
+						  new_ref));
 
       for (var = TYPE_MAIN_VARIANT (ptr); var; var = TYPE_NEXT_VARIANT (var))
 	{
@@ -2960,7 +2990,7 @@ update_pointer_to (tree old_type, tree new_type)
 
 	  /* This may seem a bit gross, in particular wrt DECL_CONTEXT, but
 	     actually is in keeping with what build_qualified_type does.  */
-	  TYPE_FIELDS (var) = TYPE_FIELDS (ptr);
+	  TYPE_FIELDS (var) = new_fields;
 	}
 
       TYPE_POINTER_TO (new_type) = TYPE_REFERENCE_TO (new_type)
@@ -2974,11 +3004,11 @@ update_pointer_to (tree old_type, tree new_type)
 
       TREE_TYPE (TYPE_FIELDS (new_obj_rec)) = TREE_TYPE (ptr_temp_type);
       TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
-	= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr)));
+	= TREE_TYPE (TREE_TYPE (new_fields));
       DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
-	= TYPE_SIZE (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))));
+	= TYPE_SIZE (TREE_TYPE (TREE_TYPE (new_fields)));
       DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
-	= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))));
+	= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (new_fields)));
 
       TYPE_SIZE (new_obj_rec)
 	= size_binop (PLUS_EXPR,
@@ -3096,29 +3126,18 @@ convert (tree type, tree expr)
   if (type == etype)
     return expr;
 
-  /* If the input type has padding, remove it by doing a component reference
-     to the field.  If the output type has padding, make a constructor
-     to build the record.  If both input and output have padding and are
-     of variable size, do this as an unchecked conversion.  */
+  /* If both input and output have padding and are of variable size, do this
+     as an unchecked conversion.  Likewise if one is a mere variant of the
+     other, so we avoid a pointless unpad/repad sequence.  */
   else if (ecode == RECORD_TYPE && code == RECORD_TYPE
-      && TYPE_IS_PADDING_P (type) && TYPE_IS_PADDING_P (etype)
-      && (!TREE_CONSTANT (TYPE_SIZE (type))
-	  || !TREE_CONSTANT (TYPE_SIZE (etype))))
+	   && TYPE_IS_PADDING_P (type) && TYPE_IS_PADDING_P (etype)
+	   && (!TREE_CONSTANT (TYPE_SIZE (type))
+	       || !TREE_CONSTANT (TYPE_SIZE (etype))
+	       || TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)))
     ;
-  else if (ecode == RECORD_TYPE && TYPE_IS_PADDING_P (etype))
-    {
-      /* If we have just converted to this padded type, just get
-	 the inner expression.  */
-      if (TREE_CODE (expr) == CONSTRUCTOR
-	  && !VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (expr))
-	  && VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->index
-	     == TYPE_FIELDS (etype))
-	return VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->value;
-      else
-	return convert (type,
-			build_component_ref (expr, NULL_TREE,
-					     TYPE_FIELDS (etype), false));
-    }
+
+  /* If the output type has padding, make a constructor to build the
+     record.  */
   else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type))
     {
       /* If we previously converted from another type and our type is
@@ -3154,6 +3173,31 @@ convert (tree type, tree expr)
 					NULL_TREE));
     }
 
+  /* If the input type has padding, remove it and convert to the output type.
+     The conditions ordering is arranged to ensure that the output type is not
+     a padding type here, as it is not clear whether the conversion would
+     always be correct if this was to happen.  */
+  else if (ecode == RECORD_TYPE && TYPE_IS_PADDING_P (etype))
+    {
+      tree unpadded;
+
+      /* If we have just converted to this padded type, just get the
+	 inner expression.  */
+      if (TREE_CODE (expr) == CONSTRUCTOR
+	  && !VEC_empty (constructor_elt, CONSTRUCTOR_ELTS (expr))
+	  && VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->index
+	     == TYPE_FIELDS (etype))
+	unpadded
+	  = VEC_index (constructor_elt, CONSTRUCTOR_ELTS (expr), 0)->value;
+
+      /* Otherwise, build an explicit component reference.  */
+      else
+	unpadded
+	  = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false);
+
+      return convert (type, unpadded);
+    }
+
   /* If the input is a biased type, adjust first.  */
   if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
     return convert (type, fold_build2 (PLUS_EXPR, TREE_TYPE (etype),
@@ -3549,6 +3593,7 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
       || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
     {
       tree rtype = type;
+      bool final_unchecked = false;
 
       if (TREE_CODE (etype) == INTEGER_TYPE
 	  && TYPE_BIASED_REPRESENTATION_P (etype))
@@ -3568,9 +3613,37 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
 	  TYPE_MAIN_VARIANT (rtype) = rtype;
 	}
 
+      /* We have another special case.  If we are unchecked converting subtype
+	 into a base type, we need to ensure that VRP doesn't propagate range
+	 information since this conversion may be done precisely to validate
+	 that the object is within the range it is supposed to have.  */
+      else if (TREE_CODE (type) == INTEGER_TYPE && !TREE_TYPE (type)
+	       && ((TREE_CODE (etype) == INTEGER_TYPE && TREE_TYPE (etype))
+		   || TREE_CODE (etype) == ENUMERAL_TYPE
+		   || TREE_CODE (etype) == BOOLEAN_TYPE))
+	{
+	  /* ??? The pattern to be "preserved" by the middle-end and the
+	     optimizers is a VIEW_CONVERT_EXPR between a pair of different
+	     "base" types (integer types without TREE_TYPE).  But this may
+	     raise addressability/aliasing issues because VIEW_CONVERT_EXPR
+	     gets gimplified as an lvalue, thus causing the address of its
+	     operand to be taken if it is deemed addressable and not already
+	     in GIMPLE form.  */
+	  rtype = gnat_type_for_mode (TYPE_MODE (type), TYPE_UNSIGNED (type));
+
+	  if (rtype == type)
+	    {
+	      rtype = copy_type (rtype);
+	      TYPE_MAIN_VARIANT (rtype) = rtype;
+	    }
+
+	  final_unchecked = true;
+	}
+
       expr = convert (rtype, expr);
       if (type != rtype)
-	expr = build1 (NOP_EXPR, type, expr);
+	expr = build1 (final_unchecked ? VIEW_CONVERT_EXPR : NOP_EXPR,
+		       type, expr);
     }
 
   /* If we are converting TO an integral type whose precision is not the
@@ -3684,14 +3757,19 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
   return expr;
 }
 
-/* Search the chain of currently reachable declarations for a builtin
-   FUNCTION_DECL node corresponding to function NAME (an IDENTIFIER_NODE).
-   Return the first node found, if any, or NULL_TREE otherwise.  */
+/* Search the chain of currently available builtin declarations for a node
+   corresponding to function NAME (an IDENTIFIER_NODE).  Return the first node
+   found, if any, or NULL_TREE otherwise.  */
 tree
-builtin_decl_for (tree name __attribute__ ((unused)))
+builtin_decl_for (tree name)
 {
-  /* ??? not clear yet how to implement this function in tree-ssa, so
-     return NULL_TREE for now */
+  unsigned i;
+  tree decl;
+
+  for (i = 0; VEC_iterate(tree, builtin_decls, i, decl); i++)
+    if (DECL_NAME (decl) == name)
+      return decl;
+
   return NULL_TREE;
 }