Improve tgamma accuracy (bugs 2546, 2560, 5159, 15426).

3 files changed, 253 insertions, 11 deletions

diff --git a/sysdeps/ieee754/ldbl-96/e_gammal_r.c b/sysdeps/ieee754/ldbl-96/e_gammal_r.c
index 0974351a10..7cb3e8563a 100644
--- a/sysdeps/ieee754/ldbl-96/e_gammal_r.c
+++ b/sysdeps/ieee754/ldbl-96/e_gammal_r.c
@@ -19,14 +19,102 @@
 
 #include <math.h>
 #include <math_private.h>
+#include <float.h>
 
+/* Coefficients B_2k / 2k(2k-1) of x^-(2k-1) inside exp in Stirling's
+   approximation to gamma function.  */
+
+static const long double gamma_coeff[] =
+  {
+    0x1.5555555555555556p-4L,
+    -0xb.60b60b60b60b60bp-12L,
+    0x3.4034034034034034p-12L,
+    -0x2.7027027027027028p-12L,
+    0x3.72a3c5631fe46aep-12L,
+    -0x7.daac36664f1f208p-12L,
+    0x1.a41a41a41a41a41ap-8L,
+    -0x7.90a1b2c3d4e5f708p-8L,
+  };
+
+#define NCOEFF (sizeof (gamma_coeff) / sizeof (gamma_coeff[0]))
+
+/* Return gamma (X), for positive X less than 1766, in the form R *
+   2^(*EXP2_ADJ), where R is the return value and *EXP2_ADJ is set to
+   avoid overflow or underflow in intermediate calculations.  */
+
+static long double
+gammal_positive (long double x, int *exp2_adj)
+{
+  int local_signgam;
+  if (x < 0.5L)
+    {
+      *exp2_adj = 0;
+      return __ieee754_expl (__ieee754_lgammal_r (x + 1, &local_signgam)) / x;
+    }
+  else if (x <= 1.5L)
+    {
+      *exp2_adj = 0;
+      return __ieee754_expl (__ieee754_lgammal_r (x, &local_signgam));
+    }
+  else if (x < 7.5L)
+    {
+      /* Adjust into the range for using exp (lgamma).  */
+      *exp2_adj = 0;
+      long double n = __ceill (x - 1.5L);
+      long double x_adj = x - n;
+      long double eps;
+      long double prod = __gamma_productl (x_adj, 0, n, &eps);
+      return (__ieee754_expl (__ieee754_lgammal_r (x_adj, &local_signgam))
+	      * prod * (1.0L + eps));
+    }
+  else
+    {
+      long double eps = 0;
+      long double x_eps = 0;
+      long double x_adj = x;
+      long double prod = 1;
+      if (x < 13.0L)
+	{
+	  /* Adjust into the range for applying Stirling's
+	     approximation.  */
+	  long double n = __ceill (13.0L - x);
+	  x_adj = x + n;
+	  x_eps = (x - (x_adj - n));
+	  prod = __gamma_productl (x_adj - n, x_eps, n, &eps);
+	}
+      /* The result is now gamma (X_ADJ + X_EPS) / (PROD * (1 + EPS)).
+	 Compute gamma (X_ADJ + X_EPS) using Stirling's approximation,
+	 starting by computing pow (X_ADJ, X_ADJ) with a power of 2
+	 factored out.  */
+      long double exp_adj = -eps;
+      long double x_adj_int = __roundl (x_adj);
+      long double x_adj_frac = x_adj - x_adj_int;
+      int x_adj_log2;
+      long double x_adj_mant = __frexpl (x_adj, &x_adj_log2);
+      if (x_adj_mant < M_SQRT1_2l)
+	{
+	  x_adj_log2--;
+	  x_adj_mant *= 2.0L;
+	}
+      *exp2_adj = x_adj_log2 * (int) x_adj_int;
+      long double ret = (__ieee754_powl (x_adj_mant, x_adj)
+			 * __ieee754_exp2l (x_adj_log2 * x_adj_frac)
+			 * __ieee754_expl (-x_adj)
+			 * __ieee754_sqrtl (2 * M_PIl / x_adj)
+			 / prod);
+      exp_adj += x_eps * __ieee754_logl (x);
+      long double bsum = gamma_coeff[NCOEFF - 1];
+      long double x_adj2 = x_adj * x_adj;
+      for (size_t i = 1; i <= NCOEFF - 1; i++)
+	bsum = bsum / x_adj2 + gamma_coeff[NCOEFF - 1 - i];
+      exp_adj += bsum / x_adj;
+      return ret + ret * __expm1l (exp_adj);
+    }
+}
 
 long double
 __ieee754_gammal_r (long double x, int *signgamp)
 {
-  /* We don't have a real gamma implementation now.  We'll use lgamma
-     and the exp function.  But due to the required boundary
-     conditions we must check some values separately.  */
   u_int32_t es, hx, lx;
 
   GET_LDOUBLE_WORDS (es, hx, lx, x);
@@ -43,22 +131,55 @@ __ieee754_gammal_r (long double x, int *signgamp)
       *signgamp = 0;
       return x - x;
     }
-  if (__builtin_expect ((es & 0x7fff) == 0x7fff, 0)
-      && ((hx & 0x7fffffff) | lx) != 0)
+  if (__builtin_expect ((es & 0x7fff) == 0x7fff, 0))
     {
-      /* NaN, return it.  */
+      /* Positive infinity (return positive infinity) or NaN (return
+	 NaN).  */
       *signgamp = 0;
-      return x;
+      return x + x;
     }
-  if (__builtin_expect ((es & 0x8000) != 0, 0)
-      && x < 0xffffffff && __rintl (x) == x)
+  if (__builtin_expect ((es & 0x8000) != 0, 0) && __rintl (x) == x)
     {
       /* Return value for integer x < 0 is NaN with invalid exception.  */
       *signgamp = 0;
       return (x - x) / (x - x);
     }
 
-  /* XXX FIXME.  */
-  return __ieee754_expl (__ieee754_lgammal_r (x, signgamp));
+  if (x >= 1756.0L)
+    {
+      /* Overflow.  */
+      *signgamp = 0;
+      return LDBL_MAX * LDBL_MAX;
+    }
+  else if (x > 0.0L)
+    {
+      *signgamp = 0;
+      int exp2_adj;
+      long double ret = gammal_positive (x, &exp2_adj);
+      return __scalbnl (ret, exp2_adj);
+    }
+  else if (x >= -LDBL_EPSILON / 4.0L)
+    {
+      *signgamp = 0;
+      return 1.0f / x;
+    }
+  else
+    {
+      long double tx = __truncl (x);
+      *signgamp = (tx == 2.0L * __truncl (tx / 2.0L)) ? -1 : 1;
+      if (x <= -1766.0L)
+	/* Underflow.  */
+	return LDBL_MIN * LDBL_MIN;
+      long double frac = tx - x;
+      if (frac > 0.5L)
+	frac = 1.0L - frac;
+      long double sinpix = (frac <= 0.25L
+			    ? __sinl (M_PIl * frac)
+			    : __cosl (M_PIl * (0.5L - frac)));
+      int exp2_adj;
+      long double ret = M_PIl / (-x * sinpix
+				 * gammal_positive (-x, &exp2_adj));
+      return __scalbnl (ret, -exp2_adj);
+    }
 }
 strong_alias (__ieee754_gammal_r, __gammal_r_finite)
diff --git a/sysdeps/ieee754/ldbl-96/gamma_product.c b/sysdeps/ieee754/ldbl-96/gamma_product.c
new file mode 100644
index 0000000000..d464e70842
--- /dev/null
+++ b/sysdeps/ieee754/ldbl-96/gamma_product.c
@@ -0,0 +1,46 @@
+/* Compute a product of X, X+1, ..., with an error estimate.
+   Copyright (C) 2013 Free Software Foundation, Inc.
+   This file is part of the GNU C Library.
+
+   The GNU C Library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Lesser General Public
+   License as published by the Free Software Foundation; either
+   version 2.1 of the License, or (at your option) any later version.
+
+   The GNU C Library is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+   Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public
+   License along with the GNU C Library; if not, see
+   <http://www.gnu.org/licenses/>.  */
+
+#include <math.h>
+#include <math_private.h>
+#include <float.h>
+
+/* Compute the product of X + X_EPS, X + X_EPS + 1, ..., X + X_EPS + N
+   - 1, in the form R * (1 + *EPS) where the return value R is an
+   approximation to the product and *EPS is set to indicate the
+   approximate error in the return value.  X is such that all the
+   values X + 1, ..., X + N - 1 are exactly representable, and X_EPS /
+   X is small enough that factors quadratic in it can be
+   neglected.  */
+
+double
+__gamma_product (double x, double x_eps, int n, double *eps)
+{
+  long double x_full = (long double) x + (long double) x_eps;
+  long double ret = x_full;
+  for (int i = 1; i < n; i++)
+    ret *= x_full + i;
+
+#if FLT_EVAL_METHOD != 0
+  volatile
+#endif
+  double fret = ret;
+  *eps = (ret - fret) / fret;
+
+  return fret;
+}
diff --git a/sysdeps/ieee754/ldbl-96/gamma_productl.c b/sysdeps/ieee754/ldbl-96/gamma_productl.c
new file mode 100644
index 0000000000..157dbab9fb
--- /dev/null
+++ b/sysdeps/ieee754/ldbl-96/gamma_productl.c
@@ -0,0 +1,75 @@
+/* Compute a product of X, X+1, ..., with an error estimate.
+   Copyright (C) 2013 Free Software Foundation, Inc.
+   This file is part of the GNU C Library.
+
+   The GNU C Library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Lesser General Public
+   License as published by the Free Software Foundation; either
+   version 2.1 of the License, or (at your option) any later version.
+
+   The GNU C Library is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+   Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public
+   License along with the GNU C Library; if not, see
+   <http://www.gnu.org/licenses/>.  */
+
+#include <math.h>
+#include <math_private.h>
+#include <float.h>
+
+/* Calculate X * Y exactly and store the result in *HI + *LO.  It is
+   given that the values are small enough that no overflow occurs and
+   large enough (or zero) that no underflow occurs.  */
+
+static inline void
+mul_split (long double *hi, long double *lo, long double x, long double y)
+{
+#ifdef __FP_FAST_FMAL
+  /* Fast built-in fused multiply-add.  */
+  *hi = x * y;
+  *lo = __builtin_fmal (x, y, -*hi);
+#elif defined FP_FAST_FMAL
+  /* Fast library fused multiply-add, compiler before GCC 4.6.  */
+  *hi = x * y;
+  *lo = __fmal (x, y, -*hi);
+#else
+  /* Apply Dekker's algorithm.  */
+  *hi = x * y;
+# define C ((1LL << (LDBL_MANT_DIG + 1) / 2) + 1)
+  long double x1 = x * C;
+  long double y1 = y * C;
+# undef C
+  x1 = (x - x1) + x1;
+  y1 = (y - y1) + y1;
+  long double x2 = x - x1;
+  long double y2 = y - y1;
+  *lo = (((x1 * y1 - *hi) + x1 * y2) + x2 * y1) + x2 * y2;
+#endif
+}
+
+/* Compute the product of X + X_EPS, X + X_EPS + 1, ..., X + X_EPS + N
+   - 1, in the form R * (1 + *EPS) where the return value R is an
+   approximation to the product and *EPS is set to indicate the
+   approximate error in the return value.  X is such that all the
+   values X + 1, ..., X + N - 1 are exactly representable, and X_EPS /
+   X is small enough that factors quadratic in it can be
+   neglected.  */
+
+long double
+__gamma_productl (long double x, long double x_eps, int n, long double *eps)
+{
+  SET_RESTORE_ROUNDL (FE_TONEAREST);
+  long double ret = x;
+  *eps = x_eps / x;
+  for (int i = 1; i < n; i++)
+    {
+      *eps += x_eps / (x + i);
+      long double lo;
+      mul_split (&ret, &lo, ret, x + i);
+      *eps += lo / ret;
+    }
+  return ret;
+}