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

gcc/fortran/ChangeLog

+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

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.  */
 

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,

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);

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 *);

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
 
 

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);

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;

gcc/testsuite/ChangeLog

+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.

gcc/testsuite/gfortran.dg/popcnt_poppar_1.F90

+! { 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

gcc/testsuite/gfortran.dg/popcnt_poppar_2.F90

+! { 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