DWARF: add a language hook for fixed-point types

Support for fixed-point types in GCC is not powerful enough for Ada
fixed-point types: GNAT uses regular scalar types to implement them.
This new language hook makes it possible to output the desired debugging
information anyway.

gcc/ada/ChangeLog:

	* gcc-interface/ada-tree.def (POWER_EXPR): New binary operation.
	* gcc-interface/ada-tree.h (TYPE_FIXED_POINT_P): New macro.
	(TYPE_IS_FIXED_POINT_P): New macro.
	(TYPE_SCALE_FACTOR): New macro.
	(SET_TYPE_SCALE_FACTOR): New macro.
	* gcc-interface/decl.c: Include urealp.h
	(gnat_to_gnu_entity): Attach trees to encode scale factors to
	fixed-point types.
	* gcc-interface/misc.c (gnat_print_type): Print scale factors
	for fixed-point types.
	(gnat_get_fixed_point_type_info): New.
	(gnat_init_ts): Initialize data for the POWER_EXPR binary
	operation.
	(LANG_HOOKS_GET_FIXED_POINT_INFO): Redefine macro to implement
	the get_fixed_point_type_info language hook.

gcc/ChangeLog:

	* langhooks.h (struct lang_hooks_for_types): Add a
	get_fixed_point_type_info field.
	* langhooks-def.h (LANG_HOOKS_GET_FIXED_POINT_TYPE_INFO): New
	macro.
	(LANG_HOOKS_FOR_TYPES_INITIALIZER): Initialize the
	get_fixed_point_type_info field.
	* dwarf2out.h (enum fixed_point_scale_factor): New.
	(struct fixed_point_type_info): New.
	* dwarf2out.c (base_type_die): In DWARFv3 or non-strict DWARF
	mode, get fixed-point type information using the debugging hook
	and describe it in DWARF, if any.

From-SVN: r231764

gcc/ChangeLog

 2015-12-17  Pierre-Marie de Rodat  <derodat@adacore.com>
 
 	* langhooks.h (struct lang_hooks_for_types): Add a
+	get_fixed_point_type_info field.
+	* langhooks-def.h (LANG_HOOKS_GET_FIXED_POINT_TYPE_INFO): New
+	macro.
+	(LANG_HOOKS_FOR_TYPES_INITIALIZER): Initialize the
+	get_fixed_point_type_info field.
+	* dwarf2out.h (enum fixed_point_scale_factor): New.
+	(struct fixed_point_type_info): New.
+	* dwarf2out.c (base_type_die): In DWARFv3 or non-strict DWARF
+	mode, get fixed-point type information using the debugging hook
+	and describe it in DWARF, if any.
+
+2015-12-17  Pierre-Marie de Rodat  <derodat@adacore.com>
+
+	* langhooks.h (struct lang_hooks_for_types): Add a
 	get_debug_type field.
 	* langhooks-def.h (LANG_HOOKS_GET_DEBUG_TYPE): New macro.
 	(LANG_HOOKS_FOR_TYPES_INITIALIZER): Initialize the

gcc/ada/ChangeLog

 2015-12-17  Pierre-Marie de Rodat  <derodat@adacore.com>
 
+	* gcc-interface/ada-tree.def (POWER_EXPR): New binary operation.
+	* gcc-interface/ada-tree.h (TYPE_FIXED_POINT_P): New macro.
+	(TYPE_IS_FIXED_POINT_P): New macro.
+	(TYPE_SCALE_FACTOR): New macro.
+	(SET_TYPE_SCALE_FACTOR): New macro.
+	* gcc-interface/decl.c: Include urealp.h
+	(gnat_to_gnu_entity): Attach trees to encode scale factors to
+	fixed-point types.
+	* gcc-interface/misc.c (gnat_print_type): Print scale factors
+	for fixed-point types.
+	(gnat_get_fixed_point_type_info): New.
+	(gnat_init_ts): Initialize data for the POWER_EXPR binary
+	operation.
+	(LANG_HOOKS_GET_FIXED_POINT_INFO): Redefine macro to implement
+	the get_fixed_point_type_info language hook.
+
+2015-12-17  Pierre-Marie de Rodat  <derodat@adacore.com>
+
 	* gcc-interface/ada-tree.h (struct lang_type): Rename the t
 	field as t1 and add a t2 one.
 	(get_lang_specific): New.

gcc/ada/gcc-interface/ada-tree.def

@@ -47,6 +47,11 @@ DEFTREECODE (PLUS_NOMOD_EXPR, "plus_nomod_expr", tcc_binary, 2)
    This is used for loops and never shows up in the tree.  */
 DEFTREECODE (MINUS_NOMOD_EXPR, "minus_nomod_expr", tcc_binary, 2)
 
+/* An expression that computes an exponentiation.  Operand 0 is the base and
+   Operand 1 is the exponent.  This node is never passed to GCC: it is only
+   used internally to describe fixed point types scale factors.  */
+DEFTREECODE (POWER_EXPR, "power_expr", tcc_binary, 2)
+
 /* Same as ADDR_EXPR, except that if the operand represents a bit field,
    return the address of the byte containing the bit.  This is used
    for the Address attribute and never shows up in the tree.  */

gcc/ada/gcc-interface/ada-tree.h

@@ -126,6 +126,13 @@ do {							 \
 #define TYPE_CONTAINS_TEMPLATE_P(NODE) \
   TYPE_LANG_FLAG_3 (RECORD_OR_UNION_CHECK (NODE))
 
+/* For INTEGER_TYPE, nonzero if it implements a fixed-point type.  */
+#define TYPE_FIXED_POINT_P(NODE) \
+  TYPE_LANG_FLAG_3 (INTEGER_TYPE_CHECK (NODE))
+
+#define TYPE_IS_FIXED_POINT_P(NODE) \
+  (TREE_CODE (NODE) == INTEGER_TYPE && TYPE_FIXED_POINT_P (NODE))
+
 /* True if NODE is a thin pointer.  */
 #define TYPE_IS_THIN_POINTER_P(NODE)			\
   (POINTER_TYPE_P (NODE)				\
@@ -358,6 +365,16 @@ do {						   \
 #define SET_TYPE_DEBUG_TYPE(NODE, X) \
   SET_TYPE_LANG_SPECIFIC2(NODE, X)
 
+/* For an INTEGER_TYPE with TYPE_IS_FIXED_POINT_P, this is the value of the
+   scale factor.  Modular types, index types (sizetype subtypes) and
+   fixed-point types are totally distinct types, so there is no problem with
+   sharing type lang specific's first slot.  */
+#define TYPE_SCALE_FACTOR(NODE) \
+  GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE))
+#define SET_TYPE_SCALE_FACTOR(NODE, X) \
+  SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X)
+
+
 /* Flags added to decl nodes.  */
 
 /* Nonzero in a FUNCTION_DECL that represents a stubbed function

gcc/ada/gcc-interface/decl.c

@@ -44,6 +44,7 @@
 #include "repinfo.h"
 #include "snames.h"
 #include "uintp.h"
+#include "urealp.h"
 #include "fe.h"
 #include "sinfo.h"
 #include "einfo.h"
@@ -1619,13 +1620,80 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
       break;
 
     case E_Signed_Integer_Type:
-    case E_Ordinary_Fixed_Point_Type:
-    case E_Decimal_Fixed_Point_Type:
       /* For integer types, just make a signed type the appropriate number
 	 of bits.  */
       gnu_type = make_signed_type (esize);
       goto discrete_type;
 
+    case E_Ordinary_Fixed_Point_Type:
+    case E_Decimal_Fixed_Point_Type:
+      {
+	/* Small_Value is the scale factor.  */
+	const Ureal gnat_small_value = Small_Value (gnat_entity);
+	tree scale_factor = NULL_TREE;
+
+	gnu_type = make_signed_type (esize);
+
+	/* Try to decode the scale factor and to save it for the fixed-point
+	   types debug hook.  */
+
+	/* There are various ways to describe the scale factor, however there
+	   are cases where back-end internals cannot hold it.  In such cases,
+	   we output invalid scale factor for such cases (i.e. the 0/0
+	   rational constant) but we expect GNAT to output GNAT encodings,
+	   then.  Thus, keep this in sync with
+	   Exp_Dbug.Is_Handled_Scale_Factor.  */
+
+	/* When encoded as 1/2**N or 1/10**N, describe the scale factor as a
+	   binary or decimal scale: it is easier to read for humans.  */
+	if (UI_Eq (Numerator (gnat_small_value), Uint_1)
+	    && (Rbase (gnat_small_value) == 2
+		|| Rbase (gnat_small_value) == 10))
+	  {
+	    /* Given RM restrictions on 'Small values, we assume here that
+	       the denominator fits in an int.  */
+	    const tree base = build_int_cst (integer_type_node,
+					     Rbase (gnat_small_value));
+	    const tree exponent
+	      = build_int_cst (integer_type_node,
+			       UI_To_Int (Denominator (gnat_small_value)));
+	    scale_factor
+	      = build2 (RDIV_EXPR, integer_type_node,
+			integer_one_node,
+			build2 (POWER_EXPR, integer_type_node,
+				base, exponent));
+	  }
+
+	/* Default to arbitrary scale factors descriptions.  */
+	else
+	  {
+	    const Uint num = Norm_Num (gnat_small_value);
+	    const Uint den = Norm_Den (gnat_small_value);
+
+	    if (UI_Is_In_Int_Range (num) && UI_Is_In_Int_Range (den))
+	      {
+		const tree gnu_num
+		  = build_int_cst (integer_type_node,
+				   UI_To_Int (Norm_Num (gnat_small_value)));
+		const tree gnu_den
+		  = build_int_cst (integer_type_node,
+				   UI_To_Int (Norm_Den (gnat_small_value)));
+		scale_factor = build2 (RDIV_EXPR, integer_type_node,
+				       gnu_num, gnu_den);
+	      }
+	    else
+	      /* If compiler internals cannot represent arbitrary scale
+		 factors, output an invalid scale factor so that debugger
+		 don't try to handle them but so that we still have a type
+		 in the output.  Note that GNAT  */
+	      scale_factor = integer_zero_node;
+	  }
+
+	TYPE_FIXED_POINT_P (gnu_type) = 1;
+	SET_TYPE_SCALE_FACTOR (gnu_type, scale_factor);
+      }
+      goto discrete_type;
+
     case E_Modular_Integer_Type:
       {
 	/* For modular types, make the unsigned type of the proper number

gcc/ada/gcc-interface/misc.c

@@ -480,6 +480,9 @@ gnat_print_type (FILE *file, tree node, int indent)
     case INTEGER_TYPE:
       if (TYPE_MODULAR_P (node))
 	print_node_brief (file, "modulus", TYPE_MODULUS (node), indent + 4);
+      else if (TYPE_FIXED_POINT_P (node))
+	print_node (file, "scale factor", TYPE_SCALE_FACTOR (node),
+		    indent + 4);
       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 	print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 		    indent + 4);
@@ -578,6 +581,81 @@ gnat_get_debug_type (const_tree type)
   return TYPE_DEBUG_TYPE (type);
 }
 
+/* Provide information in INFO for debugging output about the TYPE fixed-point
+   type.  Return whether TYPE is handled.  */
+
+static bool
+gnat_get_fixed_point_type_info (const_tree type,
+				struct fixed_point_type_info *info)
+{
+  tree scale_factor;
+
+  /* GDB cannot handle fixed-point types yet, so rely on GNAT encodings
+     instead for it.  */
+  if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL
+      || !TYPE_IS_FIXED_POINT_P (type))
+    return false;
+
+  scale_factor = TYPE_SCALE_FACTOR (type);
+
+  /* We expect here only a finite set of pattern.  See fixed-point types
+     handling in gnat_to_gnu_entity.  */
+
+  /* Put invalid values when compiler internals cannot represent the scale
+     factor.  */
+  if (scale_factor == integer_zero_node)
+    {
+      info->scale_factor_kind = fixed_point_scale_factor_arbitrary;
+      info->scale_factor.arbitrary.numerator = 0;
+      info->scale_factor.arbitrary.denominator = 0;
+      return true;
+    }
+
+  if (TREE_CODE (scale_factor) == RDIV_EXPR)
+    {
+      const tree num = TREE_OPERAND (scale_factor, 0);
+      const tree den = TREE_OPERAND (scale_factor, 1);
+
+      /* See if we have a binary or decimal scale.  */
+      if (TREE_CODE (den) == POWER_EXPR)
+	{
+	  const tree base = TREE_OPERAND (den, 0);
+	  const tree exponent = TREE_OPERAND (den, 1);
+
+	  /* We expect the scale factor to be 1 / 2 ** N or 1 / 10 ** N.  */
+	  gcc_assert (num == integer_one_node
+		      && TREE_CODE (base) == INTEGER_CST
+		      && TREE_CODE (exponent) == INTEGER_CST);
+	  switch (tree_to_shwi (base))
+	    {
+	    case 2:
+	      info->scale_factor_kind = fixed_point_scale_factor_binary;
+	      info->scale_factor.binary = -tree_to_shwi (exponent);
+	      return true;
+
+	    case 10:
+	      info->scale_factor_kind = fixed_point_scale_factor_decimal;
+	      info->scale_factor.decimal = -tree_to_shwi (exponent);
+	      return true;
+
+	    default:
+	      gcc_unreachable ();
+	    }
+	}
+
+      /* If we reach this point, we are handling an arbitrary scale factor.  We
+	 expect N / D with constant operands.  */
+      gcc_assert (TREE_CODE (num) == INTEGER_CST
+		  && TREE_CODE (den) == INTEGER_CST);
+      info->scale_factor_kind = fixed_point_scale_factor_arbitrary;
+      info->scale_factor.arbitrary.numerator = tree_to_uhwi (num);
+      info->scale_factor.arbitrary.denominator = tree_to_shwi (den);
+      return true;
+    }
+
+  gcc_unreachable ();
+}
+
 /* Return true if types T1 and T2 are identical for type hashing purposes.
    Called only after doing all language independent checks.  At present,
    this function is only called when both types are FUNCTION_TYPE.  */
@@ -981,6 +1059,7 @@ gnat_init_ts (void)
   MARK_TS_TYPED (NULL_EXPR);
   MARK_TS_TYPED (PLUS_NOMOD_EXPR);
   MARK_TS_TYPED (MINUS_NOMOD_EXPR);
+  MARK_TS_TYPED (POWER_EXPR);
   MARK_TS_TYPED (ATTR_ADDR_EXPR);
   MARK_TS_TYPED (STMT_STMT);
   MARK_TS_TYPED (LOOP_STMT);
@@ -1052,6 +1131,9 @@ get_lang_specific (tree node)
 #define LANG_HOOKS_DESCRIPTIVE_TYPE	gnat_descriptive_type
 #undef  LANG_HOOKS_GET_DEBUG_TYPE
 #define LANG_HOOKS_GET_DEBUG_TYPE	gnat_get_debug_type
+#undef  LANG_HOOKS_GET_FIXED_POINT_TYPE_INFO
+#define LANG_HOOKS_GET_FIXED_POINT_TYPE_INFO \
+					gnat_get_fixed_point_type_info
 #undef  LANG_HOOKS_ATTRIBUTE_TABLE
 #define LANG_HOOKS_ATTRIBUTE_TABLE	gnat_internal_attribute_table
 #undef  LANG_HOOKS_BUILTIN_FUNCTION

gcc/dwarf2out.c

@@ -10807,6 +10807,8 @@ base_type_die (tree type)
 {
   dw_die_ref base_type_result;
   enum dwarf_type encoding;
+  bool fpt_used = false;
+  struct fixed_point_type_info fpt_info;
 
   if (TREE_CODE (type) == ERROR_MARK || TREE_CODE (type) == VOID_TYPE)
     return 0;
@@ -10833,6 +10835,19 @@ base_type_die (tree type)
 	      break;
 	    }
 	}
+      if ((dwarf_version >= 3 || !dwarf_strict)
+	  && lang_hooks.types.get_fixed_point_type_info)
+	{
+	  memset (&fpt_info, 0, sizeof (fpt_info));
+	  if (lang_hooks.types.get_fixed_point_type_info (type, &fpt_info))
+	    {
+	      fpt_used = true;
+	      encoding = ((TYPE_UNSIGNED (type))
+			  ? DW_ATE_unsigned_fixed
+			  : DW_ATE_signed_fixed);
+	      break;
+	    }
+	}
       if (TYPE_STRING_FLAG (type))
 	{
 	  if (TYPE_UNSIGNED (type))
@@ -10891,6 +10906,43 @@ base_type_die (tree type)
   add_AT_unsigned (base_type_result, DW_AT_byte_size,
 		   int_size_in_bytes (type));
   add_AT_unsigned (base_type_result, DW_AT_encoding, encoding);
+
+  if (fpt_used)
+    {
+      switch (fpt_info.scale_factor_kind)
+	{
+	case fixed_point_scale_factor_binary:
+	  add_AT_int (base_type_result, DW_AT_binary_scale,
+		      fpt_info.scale_factor.binary);
+	  break;
+
+	case fixed_point_scale_factor_decimal:
+	  add_AT_int (base_type_result, DW_AT_decimal_scale,
+		      fpt_info.scale_factor.decimal);
+	  break;
+
+	case fixed_point_scale_factor_arbitrary:
+	  /* Arbitrary scale factors cannot be described in standard DWARF,
+	     yet.  */
+	  if (!dwarf_strict)
+	    {
+	      /* Describe the scale factor as a rational constant.  */
+	      const dw_die_ref scale_factor
+		= new_die (DW_TAG_constant, comp_unit_die (), type);
+
+	      add_AT_unsigned (scale_factor, DW_AT_GNU_numerator,
+			       fpt_info.scale_factor.arbitrary.numerator);
+	      add_AT_int (scale_factor, DW_AT_GNU_denominator,
+			  fpt_info.scale_factor.arbitrary.denominator);
+
+	      add_AT_die_ref (base_type_result, DW_AT_small, scale_factor);
+	    }
+	  break;
+
+	default:
+	  gcc_unreachable ();
+	}
+    }
   add_pubtype (type, base_type_result);
 
   return base_type_result;

gcc/dwarf2out.h

@@ -342,6 +342,35 @@ struct array_descr_info
     } dimen[10];
 };
 
+enum fixed_point_scale_factor
+{
+  fixed_point_scale_factor_binary,
+  fixed_point_scale_factor_decimal,
+  fixed_point_scale_factor_arbitrary
+};
+
+struct fixed_point_type_info
+{
+  /* A scale factor is the value one has to multiply with physical data in
+     order to get the fixed point logical data.  The DWARF standard enables one
+     to encode it in three ways.  */
+  enum fixed_point_scale_factor scale_factor_kind;
+  union
+    {
+      /* For binary scale factor, the scale factor is: 2 ** binary.  */
+      int binary;
+      /* For decimal scale factor, the scale factor is: 10 ** binary.  */
+      int decimal;
+      /* For arbitrary scale factor, the scale factor is:
+	 numerator / denominator.  */
+      struct
+	{
+	  unsigned HOST_WIDE_INT numerator;
+	  HOST_WIDE_INT denominator;
+	} arbitrary;
+    } scale_factor;
+};
+
 void dwarf2out_c_finalize (void);
 
 #endif /* GCC_DWARF2OUT_H */

gcc/langhooks-def.h

@@ -177,6 +177,7 @@ extern tree lhd_make_node (enum tree_code);
 #define LANG_HOOKS_RECONSTRUCT_COMPLEX_TYPE reconstruct_complex_type
 #define LANG_HOOKS_ENUM_UNDERLYING_BASE_TYPE lhd_enum_underlying_base_type
 #define LANG_HOOKS_GET_DEBUG_TYPE	NULL
+#define LANG_HOOKS_GET_FIXED_POINT_TYPE_INFO NULL
 
 #define LANG_HOOKS_FOR_TYPES_INITIALIZER { \
   LANG_HOOKS_MAKE_TYPE, \
@@ -197,7 +198,8 @@ extern tree lhd_make_node (enum tree_code);
   LANG_HOOKS_DESCRIPTIVE_TYPE, \
   LANG_HOOKS_RECONSTRUCT_COMPLEX_TYPE, \
   LANG_HOOKS_ENUM_UNDERLYING_BASE_TYPE, \
-  LANG_HOOKS_GET_DEBUG_TYPE \
+  LANG_HOOKS_GET_DEBUG_TYPE, \
+  LANG_HOOKS_GET_FIXED_POINT_TYPE_INFO \
 }
 
 /* Declaration hooks.  */

gcc/langhooks.h

@@ -149,6 +149,11 @@ struct lang_hooks_for_types
      middle-end uses specialized types, for instance constrained discriminated
      types in Ada.  */
   tree (*get_debug_type) (const_tree);
+
+  /* Return TRUE if TYPE implements a fixed point type and fills in information
+     for the debugger about scale factor, etc.  */
+  bool (*get_fixed_point_type_info) (const_tree,
+				     struct fixed_point_type_info *);
 };
 
 /* Language hooks related to decls and the symbol table.  */