arit64.c: New file implementing __gnat_mulv64 signed integer multiplication with overflow...

2008-07-31  Geert Bosch  <bosch@adacore.com>

	* arit64.c:
	New file implementing __gnat_mulv64 signed integer multiplication with
	overflow checking

	* fe.h (Backend_Overflow_Checks_On_Target): Define for use by Gigi

	* gcc-interface/gigi.h:
	(standard_types): Add ADT_mulv64_decl
	(mulv64_decl): Define subprogram declaration for __gnat_mulv64

	* gcc-interface/utils.c:
	(init_gigi_decls): Add initialization of mulv64_decl

	* gcc-interface/trans.c:
	(build_unary_op_trapv): New function
	(build_binary_op_trapv): New function
	(gnat_to_gnu): Use the above functions instead of
	build_{unary,binary}_op

	* gcc-interface/Makefile.in
	(LIBGNAT_SRCS): Add arit64.c
	(LIBGNAT_OBJS): Add arit64.o

From-SVN: r138384

gcc/ada/arit64.c

+/****************************************************************************
+ *                                                                          *
+ *                         GNAT COMPILER COMPONENTS                         *
+ *                                                                          *
+ *                             A R I T 6 4 . C                              *
+ *                                                                          *
+ *                          C Implementation File                           *
+ *                                                                          *
+ *         Copyright (C) 2008, Free Software Foundation, Inc.               *
+ *                                                                          *
+ * GNAT is free software;  you can  redistribute it  and/or modify it under *
+ * terms of the  GNU General Public License as published  by the Free Soft- *
+ * ware  Foundation;  either version 2,  or (at your option) any later ver- *
+ * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
+ * for  more details.  You should have  received  a copy of the GNU General *
+ * Public License  distributed with GNAT;  see file COPYING.  If not, write *
+ * to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, *
+ * Boston, MA 02110-1301, USA.                                              *
+ *                                                                          *
+ * As a  special  exception,  if you  link  this file  with other  files to *
+ * produce an executable,  this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not  however invalidate  any other reasons  why the  executable *
+ * file might be covered by the  GNU Public License.                        *
+ *                                                                          *
+ * GNAT was originally developed  by the GNAT team at  New York University. *
+ * Extensive contributions were provided by Ada Core Technologies Inc.      *
+ *                                                                          *
+ ****************************************************************************/
+
+extern void __gnat_rcheck_10(char *file, int line)
+  __attribute__ ((__noreturn__));
+
+long long int __gnat_mulv64 (long long int x, long long int y)
+{
+  unsigned neg = (x >= 0) ^ (y >= 0);
+  long long unsigned xa = x >= 0 ? (long long unsigned) x
+                                 : -(long long unsigned) x;
+  long long unsigned ya = y >= 0 ? (long long unsigned) y
+                                 : -(long long unsigned) y;
+  unsigned xhi = (unsigned) (xa >> 32);
+  unsigned yhi = (unsigned) (ya >> 32);
+  unsigned xlo = (unsigned) xa;
+  unsigned ylo = (unsigned) ya;
+  long long unsigned mid
+    = xhi ? (long long unsigned) xhi * (long long unsigned) ylo
+	 : (long long unsigned) yhi * (long long unsigned) xlo;
+  long long unsigned low = (long long unsigned) xlo * (long long unsigned) ylo;
+
+  if ((xhi && yhi) ||  mid + (low  >> 32) > 0x7fffffff + neg)
+    __gnat_rcheck_10 (__FILE__, __LINE__);
+
+  low += ((long long unsigned) (unsigned) mid) << 32;
+
+  return (long long int) (neg ? -low : low);
+}

gcc/ada/fe.h

@@ -219,8 +219,10 @@ extern void Set_Has_No_Elaboration_Code	(Node_Id, Boolean);
 
 /* targparm: */
 
+#define Backend_Overflow_Checks_On_Target targparm__backend_overflow_checks_on_target
 #define Stack_Check_Probes_On_Target targparm__stack_check_probes_on_target
 #define Stack_Check_Limits_On_Target targparm__stack_check_limits_on_target
 
+extern Boolean Backend_Overflow_Checks_On_Target;
 extern Boolean Stack_Check_Probes_On_Target;
 extern Boolean Stack_Check_Limits_On_Target;

gcc/ada/gcc-interface/Makefile.in

@@ -1715,13 +1715,13 @@ endif
 # go into the directory.  The pthreads emulation is built in the threads
 # subdirectory and copied.
 LIBGNAT_SRCS = adaint.c adaint.h argv.c cio.c cstreams.c \
-  errno.c exit.c cal.c ctrl_c.c env.c env.h \
+  errno.c exit.c cal.c ctrl_c.c env.c env.h arit64.c \
   raise.h raise.c sysdep.c aux-io.c init.c initialize.c seh_init.c \
   final.c tracebak.c tb-alvms.c tb-alvxw.c tb-gcc.c expect.c mkdir.c \
   socket.c gsocket.h targext.c $(EXTRA_LIBGNAT_SRCS)
 
 LIBGNAT_OBJS = adaint.o argv.o cio.o cstreams.o ctrl_c.o errno.o exit.o env.o \
-  raise.o sysdep.o aux-io.o init.o initialize.o seh_init.o cal.o \
+  raise.o sysdep.o aux-io.o init.o initialize.o seh_init.o cal.o arit64.o \
   final.o tracebak.o expect.o mkdir.o socket.o targext.o $(EXTRA_LIBGNAT_OBJS)
 
 # NOTE ??? - when the -I option for compiling Ada code is made to work,

gcc/ada/gcc-interface/gigi.h

@@ -394,6 +394,9 @@ enum standard_datatypes
   /* Likewise for freeing memory.  */
   ADT_free_decl,
 
+  /* Function decl node for 64-bit multiplication with overflow checking */
+  ADT_mulv64_decl,
+
   /* Types and decls used by our temporary exception mechanism.  See
      init_gigi_decls for details.  */
   ADT_jmpbuf_type,
@@ -425,6 +428,7 @@ extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
 #define malloc_decl gnat_std_decls[(int) ADT_malloc_decl]
 #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 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]

gcc/ada/gcc-interface/trans.c

@@ -205,6 +205,8 @@ static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
 static tree emit_range_check (tree, Node_Id);
 static tree emit_index_check (tree, tree, tree, tree);
 static tree emit_check (tree, tree, int);
+static tree build_unary_op_trapv (enum tree_code, tree, tree);
+static tree build_binary_op_trapv (enum tree_code, tree, tree, tree);
 static tree convert_with_check (Entity_Id, tree, bool, bool, bool);
 static bool smaller_packable_type_p (tree, tree);
 static bool addressable_p (tree, tree);
@@ -3939,7 +3941,22 @@ gnat_to_gnu (Node_Id gnat_node)
 	    gnu_rhs = convert (gnu_type, gnu_rhs);
 	  }
 
-	gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
+	/* Instead of expanding overflow checks for addition, subtraction
+	   and multiplication itself, the front end will leave this to
+	   the back end when Backend_Overflow_Checks_On_Target is set.
+	   As the GCC back end itself does not know yet how to properly
+	   do overflow checking, do it here.  The goal is to push
+	   the expansions further into the back end over time.  */
+	if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target
+            && (Nkind (gnat_node) == N_Op_Add
+		|| Nkind (gnat_node) == N_Op_Subtract
+		|| Nkind (gnat_node) == N_Op_Multiply)
+	    && !TYPE_UNSIGNED (gnu_type)
+	    && !FLOAT_TYPE_P (gnu_type))
+          gnu_result
+	    = build_binary_op_trapv (code, gnu_type, gnu_lhs, gnu_rhs);
+	else
+	  gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
 
 	/* If this is a logical shift with the shift count not verified,
 	   we must return zero if it is too large.  We cannot compensate
@@ -4004,8 +4021,14 @@ gnat_to_gnu (Node_Id gnat_node)
          gnu_result_type = get_unpadded_type (Base_Type
 					      (Full_View (Etype (gnat_node))));
 
-      gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
-				   gnu_result_type, gnu_expr);
+      if (Do_Overflow_Check (gnat_node)
+	  && !TYPE_UNSIGNED (gnu_result_type)
+	  && !FLOAT_TYPE_P (gnu_result_type))
+	gnu_result = build_unary_op_trapv (gnu_codes[Nkind (gnat_node)],
+					   gnu_result_type, gnu_expr);
+      else
+	gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)],
+				     gnu_result_type, gnu_expr);
       break;
 
     case N_Allocator:
@@ -5875,6 +5898,159 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
 	  }
 }
 
+/* Make a unary operation of kind CODE using build_unary_op, but guard
+   the operation by an overflow check. CODE can be one of NEGATE_EXPR
+   or ABS_EXPR.  GNU_TYPE is the type desired for the result.
+   Usually the operation is to be performed in that type.  */
+
+static tree
+build_unary_op_trapv (enum tree_code code,
+		      tree gnu_type,
+		      tree operand)
+{
+  gcc_assert ((code == NEGATE_EXPR) || (code == ABS_EXPR));
+
+  operand = save_expr (operand);
+
+  return emit_check (build_binary_op (EQ_EXPR, integer_type_node,
+				      operand, TYPE_MIN_VALUE (gnu_type)),
+		     build_unary_op (code, gnu_type, operand),
+		     CE_Overflow_Check_Failed);
+}
+
+/* Make a binary operation of kind CODE using build_binary_op, but
+   guard the operation by an overflow check. CODE can be one of
+   PLUS_EXPR, MINUS_EXPR or MULT_EXPR.  GNU_TYPE is the type desired
+   for the result.  Usually the operation is to be performed in that type.  */
+
+static tree
+build_binary_op_trapv (enum tree_code code,
+		       tree gnu_type,
+		       tree left,
+		       tree right)
+{
+  tree lhs = save_expr (left);
+  tree rhs = save_expr (right);
+  tree type_max = TYPE_MAX_VALUE (gnu_type);
+  tree type_min = TYPE_MIN_VALUE (gnu_type);
+  tree gnu_expr;
+  tree tmp1, tmp2;
+  tree zero = convert (gnu_type, integer_zero_node);
+  tree rhs_ge_zero;
+  tree check_pos;
+  tree check_neg;
+
+  int precision = TYPE_PRECISION (gnu_type);
+
+  /* Prefer a constant rhs to simplify checks */
+
+  if (TREE_CONSTANT (lhs) && !TREE_CONSTANT (rhs)
+      && commutative_tree_code (code))
+    {
+      tree tmp = lhs;
+      lhs = rhs;
+      rhs = tmp;
+   }
+
+  /* In the case the right-hand size is still not constant, try to
+     use an exact operation in a wider type. */
+
+  if (!TREE_CONSTANT (rhs))
+    {
+      int needed_precision = code == MULT_EXPR ? 2 * precision : precision + 1;
+
+      if (code == MULT_EXPR && precision == 64)
+	{
+	  return build_call_2_expr (mulv64_decl, lhs, rhs);
+	}
+      else if (needed_precision <= LONG_LONG_TYPE_SIZE)
+	{
+	  tree calc_type = gnat_type_for_size (needed_precision, 0);
+	  tree result;
+	  tree check;
+
+	  result = build_binary_op (code, calc_type,
+				    convert (calc_type, lhs),
+				    convert (calc_type, rhs));
+
+	  check = build_binary_op
+	    (TRUTH_ORIF_EXPR, integer_type_node,
+	     build_binary_op (LT_EXPR, integer_type_node, result,
+			      convert (calc_type, type_min)),
+	     build_binary_op (GT_EXPR, integer_type_node, result,
+			      convert (calc_type, type_max)));
+
+	  result = convert (gnu_type, result);
+
+	  return emit_check (check, result, CE_Overflow_Check_Failed);
+	}
+    }
+
+  gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
+  rhs_ge_zero = build_binary_op (GE_EXPR, integer_type_node, rhs, zero);
+
+  switch (code)
+    {
+    case PLUS_EXPR:
+      /* When rhs >= 0, overflow when lhs > type_max - rhs */
+      check_pos = build_binary_op (GT_EXPR, integer_type_node, lhs,
+				   build_binary_op (MINUS_EXPR, gnu_type,
+						    type_max, rhs)),
+
+      /* When rhs < 0, overflow when lhs < type_min - rhs */
+      check_neg = build_binary_op (LT_EXPR, integer_type_node, lhs,
+				   build_binary_op (MINUS_EXPR, gnu_type,
+						    type_min, rhs));
+      break;
+
+    case MINUS_EXPR:
+      /* When rhs >= 0, overflow when lhs < type_min + rhs */
+      check_pos = build_binary_op (LT_EXPR, integer_type_node, lhs,
+				   build_binary_op (PLUS_EXPR, gnu_type,
+						    type_min, rhs)),
+
+      /* When rhs < 0, overflow when lhs > type_max + rhs */
+      check_neg = build_binary_op (GT_EXPR, integer_type_node, lhs,
+				   build_binary_op (PLUS_EXPR, gnu_type,
+						    type_max, rhs));
+      break;
+
+    case MULT_EXPR:
+      /* The check here is designed to be efficient if the rhs is constant,
+         Four different check expressions determine wether X * C overflows,
+	 depending on C.
+	   C ==  0  =>  false
+	   C  >  0  =>  X > type_max / C || X < type_min / C
+	   C == -1  =>  X == type_min
+	   C  < -1  =>  X > type_min / C || X < type_max / C */
+
+      tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
+      tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
+
+      check_pos = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
+		    build_binary_op (NE_EXPR, integer_type_node, zero, rhs),
+		    build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
+		      build_binary_op (GT_EXPR, integer_type_node, lhs, tmp1),
+		      build_binary_op (LT_EXPR, integer_type_node, lhs, tmp2)));
+
+      check_neg = fold_build3 (COND_EXPR, integer_type_node,
+		    build_binary_op (EQ_EXPR, integer_type_node, rhs,
+				     build_int_cst (gnu_type, -1)),
+		    build_binary_op (EQ_EXPR, integer_type_node, lhs, type_min),
+		    build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
+		      build_binary_op (GT_EXPR, integer_type_node, lhs, tmp2),
+		      build_binary_op (LT_EXPR, integer_type_node, lhs, tmp1)));
+      break;
+
+    default:
+      gcc_unreachable();
+    }
+
+  return emit_check (fold_build3 (COND_EXPR, integer_type_node, rhs_ge_zero,
+				  check_pos, check_neg),
+		     gnu_expr, CE_Overflow_Check_Failed);
+}
+
 /* Emit code for a range check. GNU_EXPR is the expression to be checked,
    GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
    which we have to check. */

gcc/ada/gcc-interface/utils.c

@@ -542,6 +542,7 @@ void
 init_gigi_decls (tree long_long_float_type, tree exception_type)
 {
   tree endlink, decl;
+  tree int64_type = gnat_type_for_size (64, 0);
   unsigned int i;
 
   /* Set the types that GCC and Gigi use from the front end.  We would like
@@ -630,6 +631,13 @@ init_gigi_decls (tree long_long_float_type, tree exception_type)
 							   endlink)),
 			   NULL_TREE, false, true, true, NULL, Empty);
 
+  /* This is used for 64-bit multiplication with overflow checking.  */
+  mulv64_decl
+    = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
+			   build_function_type_list (int64_type, int64_type,
+						     int64_type, NULL_TREE),
+			   NULL_TREE, false, true, true, NULL, Empty);
+
   /* Make the types and functions used for exception processing.    */
   jmpbuf_type
     = build_array_type (gnat_type_for_mode (Pmode, 0),