Introduce log1p and expm1 primops

Previously log and exp were primitives yet log1p and expm1 were FFI
calls. Fix this non-uniformity.

12 files changed, 108 insertions, 13 deletions

diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index 7cd5c1bc20..053b425ea1 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -556,7 +556,9 @@ data CallishMachOp
   | MO_F64_Acosh
   | MO_F64_Atanh
   | MO_F64_Log
+  | MO_F64_Log1P
   | MO_F64_Exp
+  | MO_F64_ExpM1
   | MO_F64_Fabs
   | MO_F64_Sqrt
   | MO_F32_Pwr
@@ -573,7 +575,9 @@ data CallishMachOp
   | MO_F32_Acosh
   | MO_F32_Atanh
   | MO_F32_Log
+  | MO_F32_Log1P
   | MO_F32_Exp
+  | MO_F32_ExpM1
   | MO_F32_Fabs
   | MO_F32_Sqrt
 
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 822de431a4..bacdc9face 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -788,7 +788,9 @@ pprCallishMachOp_for_C mop
         MO_F64_Acosh    -> text "acosh"
         MO_F64_Atan     -> text "atan"
         MO_F64_Log      -> text "log"
+        MO_F64_Log1P    -> text "log1p"
         MO_F64_Exp      -> text "exp"
+        MO_F64_ExpM1    -> text "expm1"
         MO_F64_Sqrt     -> text "sqrt"
         MO_F64_Fabs     -> text "fabs"
         MO_F32_Pwr      -> text "powf"
@@ -805,7 +807,9 @@ pprCallishMachOp_for_C mop
         MO_F32_Acosh    -> text "acoshf"
         MO_F32_Atanh    -> text "atanhf"
         MO_F32_Log      -> text "logf"
+        MO_F32_Log1P    -> text "log1pf"
         MO_F32_Exp      -> text "expf"
+        MO_F32_ExpM1    -> text "expm1f"
         MO_F32_Sqrt     -> text "sqrtf"
         MO_F32_Fabs     -> text "fabsf"
         MO_WriteBarrier -> text "write_barrier"
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 5e3d03579a..f5b8e0f3d6 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -1513,7 +1513,9 @@ callishOp DoubleAsinhOp  = Just MO_F64_Asinh
 callishOp DoubleAcoshOp  = Just MO_F64_Acosh
 callishOp DoubleAtanhOp  = Just MO_F64_Atanh
 callishOp DoubleLogOp    = Just MO_F64_Log
+callishOp DoubleLog1POp  = Just MO_F64_Log1P
 callishOp DoubleExpOp    = Just MO_F64_Exp
+callishOp DoubleExpM1Op  = Just MO_F64_ExpM1
 callishOp DoubleSqrtOp   = Just MO_F64_Sqrt
 
 callishOp FloatPowerOp  = Just MO_F32_Pwr
@@ -1530,7 +1532,9 @@ callishOp FloatAsinhOp  = Just MO_F32_Asinh
 callishOp FloatAcoshOp  = Just MO_F32_Acosh
 callishOp FloatAtanhOp  = Just MO_F32_Atanh
 callishOp FloatLogOp    = Just MO_F32_Log
+callishOp FloatLog1POp  = Just MO_F32_Log1P
 callishOp FloatExpOp    = Just MO_F32_Exp
+callishOp FloatExpM1Op  = Just MO_F32_ExpM1
 callishOp FloatSqrtOp   = Just MO_F32_Sqrt
 
 callishOp _ = Nothing
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 236b26dbdf..28f38d09ec 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -745,7 +745,9 @@ cmmPrimOpFunctions mop = do
 
   return $ case mop of
     MO_F32_Exp    -> fsLit "expf"
+    MO_F32_ExpM1  -> fsLit "expm1f"
     MO_F32_Log    -> fsLit "logf"
+    MO_F32_Log1P  -> fsLit "log1pf"
     MO_F32_Sqrt   -> fsLit "llvm.sqrt.f32"
     MO_F32_Fabs   -> fsLit "llvm.fabs.f32"
     MO_F32_Pwr    -> fsLit "llvm.pow.f32"
@@ -767,7 +769,9 @@ cmmPrimOpFunctions mop = do
     MO_F32_Atanh  -> fsLit "atanhf"
 
     MO_F64_Exp    -> fsLit "exp"
+    MO_F64_ExpM1  -> fsLit "expm1"
     MO_F64_Log    -> fsLit "log"
+    MO_F64_Log1P  -> fsLit "log1p"
     MO_F64_Sqrt   -> fsLit "llvm.sqrt.f64"
     MO_F64_Fabs   -> fsLit "llvm.fabs.f64"
     MO_F64_Pwr    -> fsLit "llvm.pow.f64"
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 8540c780e3..03e8e42d9a 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -1955,7 +1955,9 @@ genCCall' dflags gcp target dest_regs args
             where
                 (functionName, reduce) = case mop of
                     MO_F32_Exp   -> (fsLit "exp", True)
+                    MO_F32_ExpM1 -> (fsLit "expm1", True)
                     MO_F32_Log   -> (fsLit "log", True)
+                    MO_F32_Log1P -> (fsLit "log1p", True)
                     MO_F32_Sqrt  -> (fsLit "sqrt", True)
                     MO_F32_Fabs  -> unsupported
 
@@ -1977,7 +1979,9 @@ genCCall' dflags gcp target dest_regs args
                     MO_F32_Atanh -> (fsLit "atanh", True)
 
                     MO_F64_Exp   -> (fsLit "exp", False)
+                    MO_F64_ExpM1 -> (fsLit "expm1", False)
                     MO_F64_Log   -> (fsLit "log", False)
+                    MO_F64_Log1P -> (fsLit "log1p", False)
                     MO_F64_Sqrt  -> (fsLit "sqrt", False)
                     MO_F64_Fabs  -> unsupported
 
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 851a6f2f0a..ea81219c69 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -616,7 +616,9 @@ outOfLineMachOp_table
 outOfLineMachOp_table mop
  = case mop of
         MO_F32_Exp    -> fsLit "expf"
+        MO_F32_ExpM1  -> fsLit "expm1f"
         MO_F32_Log    -> fsLit "logf"
+        MO_F32_Log1P  -> fsLit "log1pf"
         MO_F32_Sqrt   -> fsLit "sqrtf"
         MO_F32_Fabs   -> unsupported
         MO_F32_Pwr    -> fsLit "powf"
@@ -638,7 +640,9 @@ outOfLineMachOp_table mop
         MO_F32_Atanh  -> fsLit "atanhf"
 
         MO_F64_Exp    -> fsLit "exp"
+        MO_F64_ExpM1  -> fsLit "expm1"
         MO_F64_Log    -> fsLit "log"
+        MO_F64_Log1P  -> fsLit "log1p"
         MO_F64_Sqrt   -> fsLit "sqrt"
         MO_F64_Fabs   -> unsupported
         MO_F64_Pwr    -> fsLit "pow"
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index b46ef6a935..21e18ee6fd 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -2875,7 +2875,9 @@ outOfLineCmmOp bid mop res args
               MO_F32_Cos   -> fsLit "cosf"
               MO_F32_Tan   -> fsLit "tanf"
               MO_F32_Exp   -> fsLit "expf"
+              MO_F32_ExpM1 -> fsLit "expm1f"
               MO_F32_Log   -> fsLit "logf"
+              MO_F32_Log1P -> fsLit "log1pf"
 
               MO_F32_Asin  -> fsLit "asinf"
               MO_F32_Acos  -> fsLit "acosf"
@@ -2896,7 +2898,9 @@ outOfLineCmmOp bid mop res args
               MO_F64_Cos   -> fsLit "cos"
               MO_F64_Tan   -> fsLit "tan"
               MO_F64_Exp   -> fsLit "exp"
+              MO_F64_ExpM1 -> fsLit "expm1"
               MO_F64_Log   -> fsLit "log"
+              MO_F64_Log1P -> fsLit "log1p"
 
               MO_F64_Asin  -> fsLit "asin"
               MO_F64_Acos  -> fsLit "acos"
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 39e7c4799c..5b5dd9dc8d 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -763,12 +763,23 @@ primop   DoubleExpOp   "expDouble#"      Monadic
    with
    code_size = { primOpCodeSizeForeignCall }
 
+primop   DoubleExpM1Op "expm1Double#"    Monadic
+   Double# -> Double#
+   with
+   code_size = { primOpCodeSizeForeignCall }
+
 primop   DoubleLogOp   "logDouble#"      Monadic
    Double# -> Double#
    with
    code_size = { primOpCodeSizeForeignCall }
    can_fail = True
 
+primop   DoubleLog1POp   "log1pDouble#"      Monadic
+   Double# -> Double#
+   with
+   code_size = { primOpCodeSizeForeignCall }
+   can_fail = True
+
 primop   DoubleSqrtOp   "sqrtDouble#"      Monadic
    Double# -> Double#
    with
@@ -904,12 +915,23 @@ primop   FloatExpOp   "expFloat#"      Monadic
    with
    code_size = { primOpCodeSizeForeignCall }
 
+primop   FloatExpM1Op   "expm1Float#"      Monadic
+   Float# -> Float#
+   with
+   code_size = { primOpCodeSizeForeignCall }
+
 primop   FloatLogOp   "logFloat#"      Monadic
    Float# -> Float#
    with
    code_size = { primOpCodeSizeForeignCall }
    can_fail = True
 
+primop   FloatLog1POp  "log1pFloat#"     Monadic
+   Float# -> Float#
+   with
+   code_size = { primOpCodeSizeForeignCall }
+   can_fail = True
+
 primop   FloatSqrtOp   "sqrtFloat#"      Monadic
    Float# -> Float#
    with
diff --git a/libraries/base/GHC/Float.hs b/libraries/base/GHC/Float.hs
index c3c0c753b5..de6c8e3860 100644
--- a/libraries/base/GHC/Float.hs
+++ b/libraries/base/GHC/Float.hs
@@ -1140,13 +1140,16 @@ geFloat     (F# x) (F# y) = isTrue# (geFloat# x y)
 ltFloat     (F# x) (F# y) = isTrue# (ltFloat# x y)
 leFloat     (F# x) (F# y) = isTrue# (leFloat# x y)
 
-expFloat, logFloat, sqrtFloat, fabsFloat :: Float -> Float
+expFloat, expm1Float :: Float -> Float
+logFloat, log1pFloat, sqrtFloat, fabsFloat :: Float -> Float
 sinFloat, cosFloat, tanFloat  :: Float -> Float
 asinFloat, acosFloat, atanFloat  :: Float -> Float
 sinhFloat, coshFloat, tanhFloat  :: Float -> Float
 asinhFloat, acoshFloat, atanhFloat  :: Float -> Float
 expFloat    (F# x) = F# (expFloat# x)
+expm1Float  (F# x) = F# (expm1Float# x)
 logFloat    (F# x) = F# (logFloat# x)
+log1pFloat  (F# x) = F# (log1pFloat# x)
 sqrtFloat   (F# x) = F# (sqrtFloat# x)
 fabsFloat   (F# x) = F# (fabsFloat# x)
 sinFloat    (F# x) = F# (sinFloat# x)
@@ -1189,13 +1192,16 @@ double2Float (D# x) = F# (double2Float# x)
 float2Double :: Float -> Double
 float2Double (F# x) = D# (float2Double# x)
 
-expDouble, logDouble, sqrtDouble, fabsDouble :: Double -> Double
+expDouble, expm1Double :: Double -> Double
+logDouble, log1pDouble, sqrtDouble, fabsDouble :: Double -> Double
 sinDouble, cosDouble, tanDouble  :: Double -> Double
 asinDouble, acosDouble, atanDouble  :: Double -> Double
 sinhDouble, coshDouble, tanhDouble  :: Double -> Double
 asinhDouble, acoshDouble, atanhDouble  :: Double -> Double
 expDouble    (D# x) = D# (expDouble# x)
+expm1Double  (D# x) = D# (expm1Double# x)
 logDouble    (D# x) = D# (logDouble# x)
+log1pDouble  (D# x) = D# (log1pDouble# x)
 sqrtDouble   (D# x) = D# (sqrtDouble# x)
 fabsDouble   (D# x) = D# (fabsDouble# x)
 sinDouble    (D# x) = D# (sinDouble# x)
@@ -1226,16 +1232,6 @@ foreign import ccall unsafe "isDoubleDenormalized" isDoubleDenormalized :: Doubl
 foreign import ccall unsafe "isDoubleNegativeZero" isDoubleNegativeZero :: Double -> Int
 foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int
 
-
-------------------------------------------------------------------------
--- libm imports for extended floating
-------------------------------------------------------------------------
-foreign import capi unsafe "math.h log1p" log1pDouble :: Double -> Double
-foreign import capi unsafe "math.h expm1" expm1Double :: Double -> Double
-foreign import capi unsafe "math.h log1pf" log1pFloat :: Float -> Float
-foreign import capi unsafe "math.h expm1f" expm1Float :: Float -> Float
-
-
 ------------------------------------------------------------------------
 -- Coercion rules
 ------------------------------------------------------------------------
@@ -1324,7 +1320,7 @@ clamp bd k = max (-bd) (min bd k)
 Note [Casting from integral to floating point types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 To implement something like `reinterpret_cast` from C++ to go from a
-floating-point type to an integral type one might niavely think that the
+floating-point type to an integral type one might naively think that the
 following should work:
 
       cast :: Float -> Word32
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index f43ced136c..c4ea3fb86e 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -83,6 +83,7 @@ test('cgrun072', normal, compile_and_run, [''])
 test('cgrun075', normal, compile_and_run, [''])
 test('cgrun076', normal, compile_and_run, [''])
 test('cgrun077', [when(have_cpu_feature('bmi2'), extra_hc_opts('-mbmi2'))], compile_and_run, [''])
+test('cgrun078', normal, compile_and_run, [''])
 
 test('T1852', normal, compile_and_run, [''])
 test('T1861', extra_run_opts('0'), compile_and_run, [''])
diff --git a/testsuite/tests/codeGen/should_run/cgrun078.hs b/testsuite/tests/codeGen/should_run/cgrun078.hs
new file mode 100644
index 0000000000..18f7df42f3
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/cgrun078.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE   CApiFFI
+             , CPP
+             , GHCForeignImportPrim
+             , MagicHash
+  #-}
+
+-- | Check that libm foreign import log1p/expm1
+--   are equivalent to that of the primops
+--   for float/double
+module Main ( main ) where
+
+import GHC.Float (Floating(..))
+
+main :: IO ()
+main = do
+  print $ oldEqualsNewDouble log1pDoubleOld log1pDoubleNew randomDouble
+  print $ oldEqualsNewDouble expm1DoubleOld expm1DoubleNew randomDouble
+  print $ oldEqualsNewFloat log1pFloatOld log1pFloatNew randomFloat
+  print $ oldEqualsNewFloat expm1FloatOld expm1FloatNew randomFloat
+
+foreign import capi unsafe "math.h log1p" log1pDoubleOld :: Double -> Double
+foreign import capi unsafe "math.h expm1" expm1DoubleOld :: Double -> Double
+foreign import capi unsafe "math.h log1pf" log1pFloatOld :: Float -> Float
+foreign import capi unsafe "math.h expm1f" expm1FloatOld :: Float -> Float
+
+oldEqualsNewDouble :: (Double -> Double) -> (Double -> Double) -> Double -> Bool
+oldEqualsNewDouble f g x = f x == g x
+
+oldEqualsNewFloat :: (Float -> Float) -> (Float -> Float) -> Float -> Bool
+oldEqualsNewFloat f g x = f x == g x
+
+log1pDoubleNew, expm1DoubleNew :: Double -> Double
+log1pDoubleNew = log1p
+expm1DoubleNew = expm1
+
+log1pFloatNew, expm1FloatNew :: Float -> Float
+log1pFloatNew = log1p
+expm1FloatNew = expm1
+
+randomFloat :: Float
+randomFloat = 53213
+
+randomDouble :: Double
+randomDouble = 41901526
diff --git a/testsuite/tests/codeGen/should_run/cgrun078.stdout b/testsuite/tests/codeGen/should_run/cgrun078.stdout
new file mode 100644
index 0000000000..a2e704c98f
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/cgrun078.stdout
@@ -0,0 +1,4 @@
+True
+True
+True
+True