base: Rework System.CPUTime

This started when I noticed that `getCPUTime` only provides 1
millisecond resolution on Linux. Unfortunately the previous
implementation was quite unmaintainable, so this ended up being a bit
more involved than I expected.

Here we do several things,

 * Split up `System.CPUTime`

 * Add support for `clock_gettime`, allowing for significantly more
   precise timing information when available

 * Fix System.CPUTime resolution for Windows. While it's hard to get
   reliable numbers, the consensus is that Windows only provides 16
   millisecond resolution in GetProcessTimes (see Python PEP 0418 [1])

 * Eliminate terrible hack wherein we would cast between `CTime` and
   `Integer` through `Double`

[1] https://www.python.org/dev/peps/pep-0418/#id59

Test Plan: Validate on various platforms

Reviewers: austin, hvr, erikd

Reviewed By: erikd

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2001

8 files changed, 276 insertions, 121 deletions

diff --git a/libraries/base/System/CPUTime.hsc b/libraries/base/System/CPUTime.hsc
index 8d2671c49f..a6d934f491 100644
--- a/libraries/base/System/CPUTime.hsc
+++ b/libraries/base/System/CPUTime.hsc
@@ -1,5 +1,5 @@
 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP, NondecreasingIndentation, CApiFFI #-}
+{-# LANGUAGE CPP, CApiFFI #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -18,144 +18,50 @@
 #include "HsFFI.h"
 #include "HsBaseConfig.h"
 
-module System.CPUTime
-        (
-         getCPUTime,       -- :: IO Integer
-         cpuTimePrecision  -- :: Integer
-        ) where
-
-import Data.Ratio
-
-import Foreign
-import Foreign.C
-
--- For struct rusage
-#if !defined(mingw32_HOST_OS) && !defined(irix_HOST_OS)
-# if HAVE_SYS_RESOURCE_H
-#  include <sys/resource.h>
-# endif
+-- For various _POSIX_* #defines
+#if defined(HAVE_UNISTD_H)
+#include <unistd.h>
 #endif
 
--- For FILETIME etc. on Windows
-#if HAVE_WINDOWS_H
-#include <windows.h>
-#endif
-
--- for struct tms
-#if HAVE_SYS_TIMES_H
-#include <sys/times.h>
-#endif
+module System.CPUTime
+    ( getCPUTime
+    , cpuTimePrecision
+    ) where
 
-##ifdef mingw32_HOST_OS
-## if defined(i386_HOST_ARCH)
-##  define WINDOWS_CCONV stdcall
-## elif defined(x86_64_HOST_ARCH)
-##  define WINDOWS_CCONV ccall
-## else
-##  error Unknown mingw32 arch
-## endif
-##else
-##endif
+import System.IO.Unsafe (unsafePerformIO)
 
-#if !defined(mingw32_HOST_OS)
-realToInteger :: Real a => a -> Integer
-realToInteger ct = round (realToFrac ct :: Double)
-  -- CTime, CClock, CUShort etc are in Real but not Fractional,
-  -- so we must convert to Double before we can round it
-#endif
+-- Here is where we decide which backend to use
+#if defined(mingw32_HOST_OS)
+import qualified System.CPUTime.Windows as I
 
--- -----------------------------------------------------------------------------
--- |Computation 'getCPUTime' returns the number of picoseconds CPU time
--- used by the current program.  The precision of this result is
--- implementation-dependent.
+#elif _POSIX_TIMERS > 0 && defined(_POSIX_CPUTIME)
+import qualified System.CPUTime.Posix.ClockGetTime as I
 
-getCPUTime :: IO Integer
-getCPUTime = do
+#elif defined(HAVE_GETRUSAGE) && ! irix_HOST_OS && ! solaris2_HOST_OS
+import qualified System.CPUTime.Posix.RUsage as I
 
-#if !defined(mingw32_HOST_OS)
--- getrusage() is right royal pain to deal with when targetting multiple
+-- @getrusage()@ is right royal pain to deal with when targetting multiple
 -- versions of Solaris, since some versions supply it in libc (2.3 and 2.5),
 -- while 2.4 has got it in libucb (I wouldn't be too surprised if it was back
 -- again in libucb in 2.6..)
 --
 -- Avoid the problem by resorting to times() instead.
---
-#if defined(HAVE_GETRUSAGE) && ! irix_HOST_OS && ! solaris2_HOST_OS
-    allocaBytes (#const sizeof(struct rusage)) $ \ p_rusage -> do
-    throwErrnoIfMinus1_ "getrusage" $ getrusage (#const RUSAGE_SELF) p_rusage
-
-    let ru_utime = (#ptr struct rusage, ru_utime) p_rusage
-    let ru_stime = (#ptr struct rusage, ru_stime) p_rusage
-    u_sec  <- (#peek struct timeval,tv_sec)  ru_utime :: IO CTime
-    u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CSUSeconds
-    s_sec  <- (#peek struct timeval,tv_sec)  ru_stime :: IO CTime
-    s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CSUSeconds
-    return ((realToInteger u_sec * 1000000 + realToInteger u_usec +
-             realToInteger s_sec * 1000000 + realToInteger s_usec)
-                * 1000000)
-
-type CRUsage = ()
-foreign import capi unsafe "HsBase.h getrusage" getrusage :: CInt -> Ptr CRUsage -> IO CInt
 #elif defined(HAVE_TIMES)
-    allocaBytes (#const sizeof(struct tms)) $ \ p_tms -> do
-    _ <- times p_tms
-    u_ticks  <- (#peek struct tms,tms_utime) p_tms :: IO CClock
-    s_ticks  <- (#peek struct tms,tms_stime) p_tms :: IO CClock
-    return (( (realToInteger u_ticks + realToInteger s_ticks) * 1000000000000)
-                        `div` fromIntegral clockTicks)
+import qualified System.CPUTime.Posix.Times as I
 
-type CTms = ()
-foreign import ccall unsafe times :: Ptr CTms -> IO CClock
 #else
-    ioException (IOError Nothing UnsupportedOperation
-                         "getCPUTime"
-                         "can't get CPU time"
-                         Nothing)
+import qualified System.CPUTime.Unsupported as I
 #endif
 
-#else /* win32 */
-     -- NOTE: GetProcessTimes() is only supported on NT-based OSes.
-     -- The counts reported by GetProcessTimes() are in 100-ns (10^-7) units.
-    allocaBytes (#const sizeof(FILETIME)) $ \ p_creationTime -> do
-    allocaBytes (#const sizeof(FILETIME)) $ \ p_exitTime -> do
-    allocaBytes (#const sizeof(FILETIME)) $ \ p_kernelTime -> do
-    allocaBytes (#const sizeof(FILETIME)) $ \ p_userTime -> do
-    pid <- getCurrentProcess
-    ok <- getProcessTimes pid p_creationTime p_exitTime p_kernelTime p_userTime
-    if toBool ok then do
-      ut <- ft2psecs p_userTime
-      kt <- ft2psecs p_kernelTime
-      return (ut + kt)
-     else return 0
-  where
-        ft2psecs :: Ptr FILETIME -> IO Integer
-        ft2psecs ft = do
-          high <- (#peek FILETIME,dwHighDateTime) ft :: IO Word32
-          low  <- (#peek FILETIME,dwLowDateTime)  ft :: IO Word32
-            -- Convert 100-ns units to picosecs (10^-12)
-            -- => multiply by 10^5.
-          return (((fromIntegral high) * (2^(32::Int)) + (fromIntegral low)) * 100000)
-
-    -- ToDo: pin down elapsed times to just the OS thread(s) that
-    -- are evaluating/managing Haskell code.
-
-type FILETIME = ()
-type HANDLE = ()
--- need proper Haskell names (initial lower-case character)
-foreign import WINDOWS_CCONV unsafe "GetCurrentProcess" getCurrentProcess :: IO (Ptr HANDLE)
-foreign import WINDOWS_CCONV unsafe "GetProcessTimes" getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt
-
-#endif /* not _WIN32 */
-
-
--- |The 'cpuTimePrecision' constant is the smallest measurable difference
+-- | The 'cpuTimePrecision' constant is the smallest measurable difference
 -- in CPU time that the implementation can record, and is given as an
 -- integral number of picoseconds.
-
 cpuTimePrecision :: Integer
-cpuTimePrecision = round ((1000000000000::Integer) % fromIntegral (clockTicks))
-
-foreign import ccall unsafe clk_tck :: CLong
+cpuTimePrecision = unsafePerformIO I.getCpuTimePrecision
+{-# NOINLINE cpuTimePrecision #-}
 
-clockTicks :: Int
-clockTicks = fromIntegral clk_tck
+-- | Computation 'getCPUTime' returns the number of picoseconds CPU time
+-- used by the current program.  The precision of this result is
+-- implementation-dependent.
+getCPUTime :: IO Integer
+getCPUTime = I.getCPUTime
diff --git a/libraries/base/System/CPUTime/Posix/ClockGetTime.hsc b/libraries/base/System/CPUTime/Posix/ClockGetTime.hsc
new file mode 100644
index 0000000000..f4d224a78d
--- /dev/null
+++ b/libraries/base/System/CPUTime/Posix/ClockGetTime.hsc
@@ -0,0 +1,55 @@
+{-# LANGUAGE CPP, CApiFFI, NumDecimals #-}
+
+#include "HsFFI.h"
+#include "HsBaseConfig.h"
+#if HAVE_TIME_H
+#include <unistd.h>
+#include <time.h>
+#endif
+
+module System.CPUTime.Posix.ClockGetTime
+    ( getCPUTime
+    , getCpuTimePrecision
+    ) where
+
+#if defined(_POSIX_CPUTIME)
+
+import Foreign
+import Foreign.C
+import System.CPUTime.Utils
+
+getCPUTime :: IO Integer
+getCPUTime = fmap snd $ withTimespec $ \ts ->
+    throwErrnoIfMinus1_ "clock_gettime"
+    $ clock_gettime (#const CLOCK_PROCESS_CPUTIME_ID) ts
+
+getCpuTimePrecision :: IO Integer
+getCpuTimePrecision = fmap snd $ withTimespec $ \ts ->
+    throwErrnoIfMinus1_ "clock_getres"
+    $ clock_getres (#const CLOCK_PROCESS_CPUTIME_ID) ts
+
+data Timespec
+
+-- | Perform the given action to fill in a @struct timespec@, returning the
+-- result of the action and the value of the @timespec@ in picoseconds.
+withTimespec :: (Ptr Timespec -> IO a) -> IO (a, Integer)
+withTimespec action =
+    allocaBytes (# const sizeof(struct timespec)) $ \p_ts -> do
+        r <- action p_ts
+        u_sec  <- (#peek struct timespec,tv_sec)  p_ts :: IO CTime
+        u_nsec <- (#peek struct timespec,tv_nsec) p_ts :: IO CLong
+        return (r, cTimeToInteger u_sec * 1e12 + fromIntegral u_nsec * 1e3)
+
+foreign import capi unsafe "time.h clock_getres"  clock_getres  :: CInt -> Ptr Timespec -> IO CInt
+foreign import capi unsafe "time.h clock_gettime" clock_gettime :: CInt -> Ptr Timespec -> IO CInt
+
+#else
+
+-- This should never happen
+getCPUTime :: IO Integer
+getCPUTime = error "System.CPUTime.Posix.ClockGetTime: Unsupported"
+
+getCpuTimePrecision :: IO Integer
+getCpuTimePrecision = error "System.CPUTime.Posix.ClockGetTime: Unsupported"
+
+#endif // _POSIX_CPUTIME
diff --git a/libraries/base/System/CPUTime/Posix/RUsage.hsc b/libraries/base/System/CPUTime/Posix/RUsage.hsc
new file mode 100644
index 0000000000..b59422709a
--- /dev/null
+++ b/libraries/base/System/CPUTime/Posix/RUsage.hsc
@@ -0,0 +1,42 @@
+{-# LANGUAGE CPP, CApiFFI, NumDecimals #-}
+
+#include "HsFFI.h"
+#include "HsBaseConfig.h"
+
+module System.CPUTime.Posix.RUsage
+    ( getCPUTime
+    , getCpuTimePrecision
+    ) where
+
+import Data.Ratio
+import Foreign
+import Foreign.C
+import System.CPUTime.Utils
+
+-- For struct rusage
+#if HAVE_SYS_RESOURCE_H
+#include <sys/resource.h>
+#endif
+
+getCPUTime :: IO Integer
+getCPUTime = allocaBytes (#const sizeof(struct rusage)) $ \ p_rusage -> do
+    throwErrnoIfMinus1_ "getrusage" $ getrusage (#const RUSAGE_SELF) p_rusage
+
+    let ru_utime = (#ptr struct rusage, ru_utime) p_rusage
+    let ru_stime = (#ptr struct rusage, ru_stime) p_rusage
+    u_sec  <- (#peek struct timeval,tv_sec)  ru_utime :: IO CTime
+    u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CSUSeconds
+    s_sec  <- (#peek struct timeval,tv_sec)  ru_stime :: IO CTime
+    s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CSUSeconds
+    let usec = cTimeToInteger u_sec * 1e6 + csuSecondsToInteger u_usec +
+               cTimeToInteger s_sec * 1e6 + csuSecondsToInteger s_usec
+    return (usec * 1e6)
+
+type CRUsage = ()
+foreign import capi unsafe "HsBase.h getrusage" getrusage :: CInt -> Ptr CRUsage -> IO CInt
+
+getCpuTimePrecision :: IO Integer
+getCpuTimePrecision =
+    return $ round ((1e12::Integer) % fromIntegral clk_tck)
+
+foreign import ccall unsafe clk_tck :: CLong
diff --git a/libraries/base/System/CPUTime/Posix/Times.hsc b/libraries/base/System/CPUTime/Posix/Times.hsc
new file mode 100644
index 0000000000..c703863584
--- /dev/null
+++ b/libraries/base/System/CPUTime/Posix/Times.hsc
@@ -0,0 +1,39 @@
+{-# LANGUAGE CPP, CApiFFI, NumDecimals #-}
+
+#include "HsFFI.h"
+#include "HsBaseConfig.h"
+
+module System.CPUTime.Posix.Times
+    ( getCPUTime
+    , getCpuTimePrecision
+    ) where
+
+import Data.Ratio
+import Foreign
+import Foreign.C
+import System.CPUTime.Utils
+
+-- for struct tms
+#if HAVE_SYS_TIMES_H
+#include <sys/times.h>
+#endif
+
+getCPUTime :: IO Integer
+getCPUTime = allocaBytes (#const sizeof(struct tms)) $ \ p_tms -> do
+    _ <- times p_tms
+    u_ticks  <- (#peek struct tms,tms_utime) p_tms :: IO CClock
+    s_ticks  <- (#peek struct tms,tms_stime) p_tms :: IO CClock
+    return (( (cClockToInteger u_ticks + cClockToInteger s_ticks) * 1e12)
+                        `div` fromIntegral clockTicks)
+
+type CTms = ()
+foreign import ccall unsafe times :: Ptr CTms -> IO CClock
+
+getCpuTimePrecision :: IO Integer
+getCpuTimePrecision =
+    return $ round ((1e12::Integer) % clockTicks)
+
+foreign import ccall unsafe clk_tck :: CLong
+
+clockTicks :: Integer
+clockTicks = fromIntegral clk_tck
diff --git a/libraries/base/System/CPUTime/Unsupported.hs b/libraries/base/System/CPUTime/Unsupported.hs
new file mode 100644
index 0000000000..4bb8733732
--- /dev/null
+++ b/libraries/base/System/CPUTime/Unsupported.hs
@@ -0,0 +1,20 @@
+module System.CPUTime.Unsupported
+    ( getCPUTime
+    , getCpuTimePrecision
+    ) where
+
+import GHC.IO.Exception
+
+getCPUTime :: IO Integer
+getCPUTime =
+    ioError (IOError Nothing UnsupportedOperation
+                     "getCPUTime"
+                     "can't get CPU time"
+                     Nothing Nothing)
+
+getCpuTimePrecision :: IO Integer
+getCpuTimePrecision =
+    ioError (IOError Nothing UnsupportedOperation
+                     "cpuTimePrecision"
+                     "can't get CPU time"
+                     Nothing Nothing)
diff --git a/libraries/base/System/CPUTime/Utils.hs b/libraries/base/System/CPUTime/Utils.hs
new file mode 100644
index 0000000000..4556159d59
--- /dev/null
+++ b/libraries/base/System/CPUTime/Utils.hs
@@ -0,0 +1,19 @@
+module System.CPUTime.Utils
+    ( -- * Integer conversions
+      -- | These types have no 'Integral' instances in the Haskell report
+      -- so we must do this ourselves.
+      cClockToInteger
+    , cTimeToInteger
+    , csuSecondsToInteger
+    ) where
+
+import Foreign.C.Types
+
+cClockToInteger :: CClock -> Integer
+cClockToInteger (CClock n) = fromIntegral n
+
+cTimeToInteger :: CTime -> Integer
+cTimeToInteger (CTime n) = fromIntegral n
+
+csuSecondsToInteger :: CSUSeconds -> Integer
+csuSecondsToInteger (CSUSeconds n) = fromIntegral n
diff --git a/libraries/base/System/CPUTime/Windows.hsc b/libraries/base/System/CPUTime/Windows.hsc
new file mode 100644
index 0000000000..d1ca856e87
--- /dev/null
+++ b/libraries/base/System/CPUTime/Windows.hsc
@@ -0,0 +1,66 @@
+{-# LANGUAGE CPP, CApiFFI, NumDecimals #-}
+
+#include "HsFFI.h"
+#include "HsBaseConfig.h"
+
+module System.CPUTime.Windows
+    ( getCPUTime
+    , getCpuTimePrecision
+    ) where
+
+import Data.Ratio
+import Foreign
+import Foreign.C
+
+-- For FILETIME etc. on Windows
+#if HAVE_WINDOWS_H
+#include <windows.h>
+#endif
+
+#ifdef mingw32_HOST_OS
+# if defined(i386_HOST_ARCH)
+#  define WINDOWS_CCONV stdcall
+# elif defined(x86_64_HOST_ARCH)
+#  define WINDOWS_CCONV ccall
+# else
+#  error Unknown mingw32 arch
+# endif
+#endif
+
+getCPUTime :: IO Integer
+getCPUTime = do
+     -- NOTE: GetProcessTimes() is only supported on NT-based OSes.
+     -- The counts reported by GetProcessTimes() are in 100-ns (10^-7) units.
+    allocaBytes (#const sizeof(FILETIME)) $ \ p_creationTime -> do
+    allocaBytes (#const sizeof(FILETIME)) $ \ p_exitTime -> do
+    allocaBytes (#const sizeof(FILETIME)) $ \ p_kernelTime -> do
+    allocaBytes (#const sizeof(FILETIME)) $ \ p_userTime -> do
+    pid <- getCurrentProcess
+    ok <- getProcessTimes pid p_creationTime p_exitTime p_kernelTime p_userTime
+    if toBool ok then do
+      ut <- ft2psecs p_userTime
+      kt <- ft2psecs p_kernelTime
+      return (ut + kt)
+     else return 0
+  where
+        ft2psecs :: Ptr FILETIME -> IO Integer
+        ft2psecs ft = do
+          high <- (#peek FILETIME,dwHighDateTime) ft :: IO Word32
+          low  <- (#peek FILETIME,dwLowDateTime)  ft :: IO Word32
+            -- Convert 100-ns units to picosecs (10^-12)
+            -- => multiply by 10^5.
+          return (((fromIntegral high) * (2^(32::Int)) + (fromIntegral low)) * 100000)
+
+    -- ToDo: pin down elapsed times to just the OS thread(s) that
+    -- are evaluating/managing Haskell code.
+
+-- While it's hard to get reliable numbers, the consensus is that Windows only provides
+-- 16 millisecond resolution in GetProcessTimes (see Python PEP 0418)
+getCpuTimePrecision :: IO Integer
+getCpuTimePrecision = return 16e9
+
+type FILETIME = ()
+type HANDLE = ()
+-- need proper Haskell names (initial lower-case character)
+foreign import WINDOWS_CCONV unsafe "GetCurrentProcess" getCurrentProcess :: IO (Ptr HANDLE)
+foreign import WINDOWS_CCONV unsafe "GetProcessTimes" getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 7d9367a6be..fd3c6081fb 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -310,6 +310,7 @@ Library
         Data.OldList
         Foreign.ForeignPtr.Imp
         System.Environment.ExecutablePath
+        System.CPUTime.Utils
 
     c-sources:
         cbits/DarwinUtils.c
@@ -341,6 +342,8 @@ Library
             GHC.IO.Encoding.CodePage.Table
             GHC.Conc.Windows
             GHC.Windows
+        other-modules:
+            System.CPUTime.Windows
     else
         exposed-modules:
             GHC.Event
@@ -360,6 +363,11 @@ Library
             GHC.Event.TimerManager
             GHC.Event.Unique
 
+            System.CPUTime.Posix.ClockGetTime
+            System.CPUTime.Posix.Times
+            System.CPUTime.Posix.RUsage
+            System.CPUTime.Unsupported
+
     -- We need to set the unit id to base (without a version number)
     -- as it's magic.
     ghc-options: -this-unit-id base