re PR fortran/38282 (Bit intrinsics: ILEN and IBCHNG)

	PR fortran/38282

	* f95-lang.c (gfc_init_builtin_functions): Define popcount{,l,ll}
	and parity{,l,ll} builtins.
	* trans-intrinsic.c (gfc_conv_intrinsic_popcnt_poppar): New function.
	(gfc_conv_intrinsic_function): Call above new functions.
	* simplify.c (gfc_simplify_popcnt, gfc_simplify_poppar): New
	functions.
	* intrinsic.texi: Document POPCNT and POPPAR.

	* gfortran.dg/popcnt_poppar_1.F90: New test.
	* gfortran.dg/popcnt_poppar_2.F90: New test.

From-SVN: r163691

11 files changed, 432 insertions, 3 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4e64e84..cdceae8 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2010-08-31  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/38282
+	* f95-lang.c (gfc_init_builtin_functions): Define popcount{,l,ll}
+	and parity{,l,ll} builtins.
+	* trans-intrinsic.c (gfc_conv_intrinsic_popcnt_poppar): New function.
+	(gfc_conv_intrinsic_function): Call above new functions.
+	* simplify.c (gfc_simplify_popcnt, gfc_simplify_poppar): New
+	functions.
+	* intrinsic.texi: Document POPCNT and POPPAR.
+
 2010-08-30  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/45456
diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c
index 91dc491..163c0d2 100644
--- a/gcc/fortran/f95-lang.c
+++ b/gcc/fortran/f95-lang.c
@@ -938,13 +938,17 @@ gfc_init_builtin_functions (void)
 		          BUILT_IN_SINCOSF, "sincosf", false);
     }
 
-  /* For LEADZ / TRAILZ.  */
+  /* For LEADZ, TRAILZ, POPCNT and POPAR.  */
   ftype = build_function_type_list (integer_type_node,
                                     unsigned_type_node, NULL_TREE);
   gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ,
 		      "__builtin_clz", true);
   gfc_define_builtin ("__builtin_ctz", ftype, BUILT_IN_CTZ,
 		      "__builtin_ctz", true);
+  gfc_define_builtin ("__builtin_parity", ftype, BUILT_IN_PARITY,
+		      "__builtin_parity", true);
+  gfc_define_builtin ("__builtin_popcount", ftype, BUILT_IN_POPCOUNT,
+		      "__builtin_popcount", true);
 
   ftype = build_function_type_list (integer_type_node,
                                     long_unsigned_type_node, NULL_TREE);
@@ -952,6 +956,10 @@ gfc_init_builtin_functions (void)
 		      "__builtin_clzl", true);
   gfc_define_builtin ("__builtin_ctzl", ftype, BUILT_IN_CTZL,
 		      "__builtin_ctzl", true);
+  gfc_define_builtin ("__builtin_parityl", ftype, BUILT_IN_PARITYL,
+		      "__builtin_parityl", true);
+  gfc_define_builtin ("__builtin_popcountl", ftype, BUILT_IN_POPCOUNTL,
+		      "__builtin_popcountl", true);
 
   ftype = build_function_type_list (integer_type_node,
                                     long_long_unsigned_type_node, NULL_TREE);
@@ -959,6 +967,10 @@ gfc_init_builtin_functions (void)
 		      "__builtin_clzll", true);
   gfc_define_builtin ("__builtin_ctzll", ftype, BUILT_IN_CTZLL,
 		      "__builtin_ctzll", true);
+  gfc_define_builtin ("__builtin_parityll", ftype, BUILT_IN_PARITYLL,
+		      "__builtin_parityll", true);
+  gfc_define_builtin ("__builtin_popcountll", ftype, BUILT_IN_POPCOUNTLL,
+		      "__builtin_popcountll", true);
 
   /* Other builtin functions we use.  */
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 66c378e..1ee9bd5 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -472,6 +472,8 @@ enum gfc_isym_id
   GFC_ISYM_PACK,
   GFC_ISYM_PARITY,
   GFC_ISYM_PERROR,
+  GFC_ISYM_POPCNT,
+  GFC_ISYM_POPPAR,
   GFC_ISYM_PRECISION,
   GFC_ISYM_PRESENT,
   GFC_ISYM_PRODUCT,
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 2ce3482..c14e14d 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -2299,6 +2299,20 @@ add_functions (void)
 
   make_generic ("parity", GFC_ISYM_PARITY, GFC_STD_F2008);
 
+  add_sym_1 ("popcnt", GFC_ISYM_POPCNT, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_i, gfc_simplify_popcnt, NULL,
+	     i, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("popcnt", GFC_ISYM_POPCNT, GFC_STD_F2008);
+
+  add_sym_1 ("poppar", GFC_ISYM_POPPAR, CLASS_ELEMENTAL, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_i, gfc_simplify_poppar, NULL,
+	     i, BT_INTEGER, di, REQUIRED);
+
+  make_generic ("poppar", GFC_ISYM_POPPAR, GFC_STD_F2008);
+
   add_sym_1 ("precision", GFC_ISYM_PRECISION, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
 	     gfc_check_precision, gfc_simplify_precision, NULL,
 	     x, BT_UNKNOWN, 0, REQUIRED);
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 2c101d3..383ada0 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -317,6 +317,8 @@ gfc_expr *gfc_simplify_not (gfc_expr *);
 gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_pack (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_parity (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_popcnt (gfc_expr *);
+gfc_expr *gfc_simplify_poppar (gfc_expr *);
 gfc_expr *gfc_simplify_precision (gfc_expr *);
 gfc_expr *gfc_simplify_product (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_radix (gfc_expr *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index c4767f5..49b9d53 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -211,6 +211,8 @@ Some basic guidelines for editing this document:
 * @code{PACK}:          PACK,      Pack an array into an array of rank one
 * @code{PARITY}:        PARITY,    Reduction with exclusive OR
 * @code{PERROR}:        PERROR,    Print system error message
+* @code{POPCNT}:        POPCNT,    Number of bits set
+* @code{POPPAR}:        POPPAR,    Parity of the number of bits set
 * @code{PRECISION}:     PRECISION, Decimal precision of a real kind
 * @code{PRESENT}:       PRESENT,   Determine whether an optional dummy argument is specified
 * @code{PRODUCT}:       PRODUCT,   Product of array elements
@@ -6719,7 +6721,7 @@ END PROGRAM
 @end smallexample
 
 @item @emph{See also}:
-@ref{BIT_SIZE}, @ref{TRAILZ}
+@ref{BIT_SIZE}, @ref{TRAILZ}, @ref{POPCNT}, @ref{POPPAR}
 @end table
 
 
@@ -8899,6 +8901,95 @@ end program prec_and_range
 
 
 
+@node POPCNT
+@section @code{POPCNT} --- Number of bits set
+@fnindex POPCNT
+@cindex binary representation
+@cindex bits set
+
+@table @asis
+@item @emph{Description}:
+@code{POPCNT(I)} returns the number of bits set ('1' bits) in the binary
+representation of @code{I}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = POPCNT(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the default integer
+kind.
+
+@item @emph{See also}:
+@ref{POPPAR}, @ref{LEADZ}, @ref{TRAILZ}
+
+@item @emph{Example}:
+@smallexample
+program test_population
+  print *, popcnt(127),       poppar(127)
+  print *, popcnt(huge(0_4)), poppar(huge(0_4))
+  print *, popcnt(huge(0_8)), poppar(huge(0_8))
+end program test_population
+@end smallexample
+@end table
+
+
+@node POPPAR
+@section @code{POPPAR} --- Parity of the number of bits set
+@fnindex POPPAR
+@cindex binary representation
+@cindex parity
+
+@table @asis
+@item @emph{Description}:
+@code{POPPAR(I)} returns parity of the integer @code{I}, i.e. the parity
+of the number of bits set ('1' bits) in the binary representation of
+@code{I}. It is equal to 0 if @code{I} has an even number of bits set,
+and 1 for an odd number of '1' bits.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = POPPAR(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of the default integer
+kind.
+
+@item @emph{See also}:
+@ref{POPCNT}, @ref{LEADZ}, @ref{TRAILZ}
+
+@item @emph{Example}:
+@smallexample
+program test_population
+  print *, popcnt(127),       poppar(127)
+  print *, popcnt(huge(0_4)), poppar(huge(0_4))
+  print *, popcnt(huge(0_8)), poppar(huge(0_8))
+end program test_population
+@end smallexample
+@end table
+
+
+
 @node PRESENT
 @section @code{PRESENT} --- Determine whether an optional dummy argument is specified
 @fnindex PRESENT
@@ -11228,7 +11319,7 @@ END PROGRAM
 @end smallexample
 
 @item @emph{See also}:
-@ref{BIT_SIZE}, @ref{LEADZ}
+@ref{BIT_SIZE}, @ref{LEADZ}, @ref{POPPAR}, @ref{POPCNT}
 @end table
 
 
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 2fe7140..8649597 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -4293,6 +4293,47 @@ gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
 
 
 gfc_expr *
+gfc_simplify_popcnt (gfc_expr *e)
+{
+  int res, k;
+  mpz_t x;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+
+  /* Convert argument to unsigned, then count the '1' bits.  */
+  mpz_init_set (x, e->value.integer);
+  convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
+  res = mpz_popcount (x);
+  mpz_clear (x);
+
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
+}
+
+
+gfc_expr *
+gfc_simplify_poppar (gfc_expr *e)
+{
+  gfc_expr *popcnt;
+  const char *s;
+  int i;
+
+  if (e->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  popcnt = gfc_simplify_popcnt (e);
+  gcc_assert (popcnt);
+
+  s = gfc_extract_int (popcnt, &i);
+  gcc_assert (!s);
+
+  return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
+}
+
+
+gfc_expr *
 gfc_simplify_precision (gfc_expr *e)
 {
   int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 256cd8d..c0f39b2 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -3476,6 +3476,88 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
 }
 
+/* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
+   for types larger than "long long", we call the long long built-in for
+   the lower and higher bits and combine the result.  */
+ 
+static void
+gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
+{
+  tree arg;
+  tree arg_type;
+  tree result_type;
+  tree func;
+  int argsize;
+
+  gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  argsize = TYPE_PRECISION (TREE_TYPE (arg));
+  result_type = gfc_get_int_type (gfc_default_integer_kind);
+
+  /* Which variant of the builtin should we call?  */
+  if (argsize <= INT_TYPE_SIZE)
+    {
+      arg_type = unsigned_type_node;
+      func = built_in_decls[parity ? BUILT_IN_PARITY : BUILT_IN_POPCOUNT];
+    }
+  else if (argsize <= LONG_TYPE_SIZE)
+    {
+      arg_type = long_unsigned_type_node;
+      func = built_in_decls[parity ? BUILT_IN_PARITYL : BUILT_IN_POPCOUNTL];
+    }
+  else if (argsize <= LONG_LONG_TYPE_SIZE)
+    {
+      arg_type = long_long_unsigned_type_node;
+      func = built_in_decls[parity ? BUILT_IN_PARITYLL : BUILT_IN_POPCOUNTLL];
+    }
+  else
+    {
+      /* Our argument type is larger than 'long long', which mean none
+	 of the POPCOUNT builtins covers it.  We thus call the 'long long'
+	 variant multiple times, and add the results.  */
+      tree utype, arg2, call1, call2;
+
+      /* For now, we only cover the case where argsize is twice as large
+	 as 'long long'.  */
+      gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
+
+      func = built_in_decls[parity ? BUILT_IN_PARITYLL : BUILT_IN_POPCOUNTLL];
+
+      /* Convert it to an integer, and store into a variable.  */
+      utype = gfc_build_uint_type (argsize);
+      arg = fold_convert (utype, arg);
+      arg = gfc_evaluate_now (arg, &se->pre);
+
+      /* Call the builtin twice.  */
+      call1 = build_call_expr_loc (input_location, func, 1,
+				   fold_convert (long_long_unsigned_type_node,
+						 arg));
+
+      arg2 = fold_build2 (RSHIFT_EXPR, utype, arg,
+			  build_int_cst (utype, LONG_LONG_TYPE_SIZE));
+      call2 = build_call_expr_loc (input_location, func, 1,
+				   fold_convert (long_long_unsigned_type_node,
+						 arg2));
+			  
+      /* Combine the results.  */
+      if (parity)
+	se->expr = fold_build2 (BIT_XOR_EXPR, result_type, call1, call2);
+      else
+	se->expr = fold_build2 (PLUS_EXPR, result_type, call1, call2);
+
+      return;
+    }
+
+  /* Convert the actual argument twice: first, to the unsigned type of the
+     same size; then, to the proper argument type for the built-in
+     function.  */
+  arg = fold_convert (gfc_build_uint_type (argsize), arg);
+  arg = fold_convert (arg_type, arg);
+
+  se->expr = fold_convert (result_type,
+			   build_call_expr_loc (input_location, func, 1, arg));
+}
+
+
 /* Process an intrinsic with unspecified argument-types that has an optional
    argument (which could be of type character), e.g. EOSHIFT.  For those, we
    need to append the string length of the optional argument if it is not
@@ -5418,6 +5500,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_trailz (se, expr);
       break;
 
+    case GFC_ISYM_POPCNT:
+      gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
+      break;
+
+    case GFC_ISYM_POPPAR:
+      gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
+      break;
+
     case GFC_ISYM_LBOUND:
       gfc_conv_intrinsic_bound (se, expr, 0);
       break;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e462642..a42dfe0 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2010-08-31  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/38282
+	* gfortran.dg/popcnt_poppar_1.F90: New test.
+	* gfortran.dg/popcnt_poppar_2.F90: New test.
+
 2010-08-31  Uros Bizjak  <ubizjak@gmail.com>
 
 	* gcc.target/i386/volatile-2.c: Require nonpic target.
diff --git a/gcc/testsuite/gfortran.dg/popcnt_poppar_1.F90 b/gcc/testsuite/gfortran.dg/popcnt_poppar_1.F90
new file mode 100644
index 0000000..3b7322b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/popcnt_poppar_1.F90
@@ -0,0 +1,121 @@
+! { dg-do run }
+! { dg-options "-ffree-line-length-none" }
+
+interface runtime_popcnt
+  procedure runtime_popcnt_i1
+  procedure runtime_popcnt_i2
+  procedure runtime_popcnt_i4
+  procedure runtime_popcnt_i8
+end interface
+
+interface runtime_poppar
+  procedure runtime_poppar_i1
+  procedure runtime_poppar_i2
+  procedure runtime_poppar_i4
+  procedure runtime_poppar_i8
+end interface
+
+#define CHECK(val,res) \
+  if (popcnt(val) /= res) call abort ; \
+  if (runtime_popcnt(val) /= res) call abort
+
+#define CHECK2(val) \
+  if (poppar(val) /= modulo(popcnt(val),2)) call abort ; \
+  if (runtime_poppar(val) /= poppar(val)) call abort
+
+  CHECK(0_1, 0)
+  CHECK(0_2, 0)
+  CHECK(0_4, 0)
+  CHECK(0_8, 0)
+
+  CHECK(1_1, 1)
+  CHECK(1_2, 1)
+  CHECK(1_4, 1)
+  CHECK(1_8, 1)
+
+  CHECK(-1_1,8)
+  CHECK(-1_2,16)
+  CHECK(-1_4,32)
+  CHECK(-1_8,64)
+
+  CHECK(-8_1,8-3)
+  CHECK(-8_2,16-3)
+  CHECK(-8_4,32-3)
+  CHECK(-8_8,64-3)
+
+  CHECK(huge(0_1), 8-1)
+  CHECK(huge(0_2), 16-1)
+  CHECK(huge(0_4), 32-1)
+  CHECK(huge(0_8), 64-1)
+
+  CHECK(-huge(0_1), 2)
+  CHECK(-huge(0_2), 2)
+  CHECK(-huge(0_4), 2)
+  CHECK(-huge(0_8), 2)
+
+  CHECK2(0_1)
+  CHECK2(0_2)
+  CHECK2(0_4)
+  CHECK2(0_8)
+
+  CHECK2(17_1)
+  CHECK2(17_2)
+  CHECK2(17_4)
+  CHECK2(17_8)
+
+  CHECK2(-17_1)
+  CHECK2(-17_2)
+  CHECK2(-17_4)
+  CHECK2(-17_8)
+
+  CHECK2(huge(0_1))
+  CHECK2(huge(0_2))
+  CHECK2(huge(0_4))
+  CHECK2(huge(0_8))
+
+  CHECK2(-huge(0_1))
+  CHECK2(-huge(0_2))
+  CHECK2(-huge(0_4))
+  CHECK2(-huge(0_8))
+
+contains
+  integer function runtime_popcnt_i1 (i) result(res)
+    integer(kind=1), intent(in) :: i
+    res = popcnt(i)
+  end function
+
+  integer function runtime_popcnt_i2 (i) result(res)
+    integer(kind=2), intent(in) :: i
+    res = popcnt(i)
+  end function
+
+  integer function runtime_popcnt_i4 (i) result(res)
+    integer(kind=4), intent(in) :: i
+    res = popcnt(i)
+  end function
+
+  integer function runtime_popcnt_i8 (i) result(res)
+    integer(kind=8), intent(in) :: i
+    res = popcnt(i)
+  end function
+
+  integer function runtime_poppar_i1 (i) result(res)
+    integer(kind=1), intent(in) :: i
+    res = poppar(i)
+  end function
+
+  integer function runtime_poppar_i2 (i) result(res)
+    integer(kind=2), intent(in) :: i
+    res = poppar(i)
+  end function
+
+  integer function runtime_poppar_i4 (i) result(res)
+    integer(kind=4), intent(in) :: i
+    res = poppar(i)
+  end function
+
+  integer function runtime_poppar_i8 (i) result(res)
+    integer(kind=8), intent(in) :: i
+    res = poppar(i)
+  end function
+end
diff --git a/gcc/testsuite/gfortran.dg/popcnt_poppar_2.F90 b/gcc/testsuite/gfortran.dg/popcnt_poppar_2.F90
new file mode 100644
index 0000000..fb984e2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/popcnt_poppar_2.F90
@@ -0,0 +1,39 @@
+! { dg-do run }
+! { dg-options "-ffree-line-length-none" }
+! { dg-require-effective-target fortran_integer_16 }
+
+#define CHECK(val,res) \
+  if (popcnt(val) /= res) call abort ; \
+  if (runtime_popcnt(val) /= res) call abort
+
+#define CHECK2(val) \
+  if (poppar(val) /= modulo(popcnt(val),2)) call abort ; \
+  if (runtime_poppar(val) /= poppar(val)) call abort
+
+  CHECK(0_16, 0)
+  CHECK(1_16, 1)
+
+  CHECK(-1_16,128)
+  CHECK(-8_16,128-3)
+
+  CHECK(huge(0_16), 128-1)
+
+  CHECK(-huge(0_16), 2)
+
+  CHECK2(0_16)
+  CHECK2(17_16)
+  CHECK2(-17_16)
+  CHECK2(huge(0_16))
+  CHECK2(-huge(0_16))
+
+contains
+  integer function runtime_popcnt (i) result(res)
+    integer(kind=16), intent(in) :: i
+    res = popcnt(i)
+  end function
+
+  integer function runtime_poppar (i) result(res)
+    integer(kind=16), intent(in) :: i
+    res = poppar(i)
+  end function
+end