X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FCPUTime.hsc;h=f050a681ae27fef390cdcb43e613ddcd4e68f099;hb=6c5da11b55ef71607cf0b8cf408c10cd5f99530c;hp=e8687570d1666672fd675dbafd5f44f066b810fd;hpb=3d39b8130899c46c9c96b941fddb4e4784e860dc;p=ghc-base.git diff --git a/System/CPUTime.hsc b/System/CPUTime.hsc index e868757..f050a68 100644 --- a/System/CPUTime.hsc +++ b/System/CPUTime.hsc @@ -1,47 +1,90 @@ ----------------------------------------------------------------------------- --- +-- | -- Module : System.CPUTime -- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/core/LICENSE) +-- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- --- $Id: CPUTime.hsc,v 1.4 2001/08/17 12:50:34 simonmar Exp $ --- -- The standard CPUTime library. -- ----------------------------------------------------------------------------- module System.CPUTime - ( + ( getCPUTime, -- :: IO Integer - cpuTimePrecision -- :: Integer + cpuTimePrecision -- :: Integer ) where import Prelude -import Foreign +import Data.Ratio + +#ifdef __HUGS__ +import Hugs.Time ( getCPUTime, clockTicks ) +#endif + +#ifdef __NHC__ +import CPUTime ( getCPUTime, cpuTimePrecision ) +#endif + +#ifdef __GLASGOW_HASKELL__ +import Foreign hiding (unsafePerformIO) import Foreign.C +#if !defined(CLK_TCK) +import System.IO.Unsafe (unsafePerformIO) +#endif -import Data.Ratio +#include "HsBaseConfig.h" + +-- For _SC_CLK_TCK +#if HAVE_UNISTD_H +#include +#endif + +-- For struct rusage +#if !defined(mingw32_HOST_OS) && !defined(irix_HOST_OS) +# if HAVE_SYS_RESOURCE_H +# include +# endif +#endif + +-- For FILETIME etc. on Windows +#if HAVE_WINDOWS_H +#include +#endif + +-- for CLK_TCK +#if HAVE_TIME_H +#include +#endif + +-- for struct tms +#if HAVE_SYS_TIMES_H +#include +#endif + +#endif -#include "HsCore.h" +#if !defined(mingw32_HOST_OS) && !defined(cygwin32_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 +#ifdef __GLASGOW_HASKELL__ -- ----------------------------------------------------------------------------- --- Computation `getCPUTime' returns the number of picoseconds CPU time +-- |Computation 'getCPUTime' returns the number of picoseconds CPU time -- used by the current program. The precision of this result is -- implementation-dependent. --- 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. - getCPUTime :: IO Integer getCPUTime = do -#if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS) +#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) -- 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 @@ -49,43 +92,44 @@ getCPUTime = do -- -- Avoid the problem by resorting to times() instead. -- -#if defined(HAVE_GETRUSAGE) && ! irix_TARGET_OS && ! solaris2_TARGET_OS +#if defined(HAVE_GETRUSAGE) && ! irix_HOST_OS && ! solaris2_HOST_OS allocaBytes (#const sizeof(struct rusage)) $ \ p_rusage -> do - getrusage (#const RUSAGE_SELF) p_rusage + 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 CLong - u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CLong - s_sec <- (#peek struct timeval,tv_sec) ru_stime :: IO CLong - s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CLong - - return ((fromIntegral u_sec * 1000000 + fromIntegral u_usec + - fromIntegral s_sec * 1000000 + fromIntegral s_usec) - * 1000000) + u_sec <- (#peek struct timeval,tv_sec) ru_utime :: IO CTime + u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CTime + s_sec <- (#peek struct timeval,tv_sec) ru_stime :: IO CTime + s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CTime + return ((realToInteger u_sec * 1000000 + realToInteger u_usec + + realToInteger s_sec * 1000000 + realToInteger s_usec) + * 1000000) type CRUsage = () -foreign import unsafe getrusage :: CInt -> Ptr CRUsage -> IO CInt +foreign import ccall unsafe getrusage :: CInt -> Ptr CRUsage -> IO CInt #else # if defined(HAVE_TIMES) allocaBytes (#const sizeof(struct tms)) $ \ p_tms -> do - times p_tms + _ <- 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 (( (fromIntegral u_ticks + fromIntegral s_ticks) * 1000000000000) - `div` fromIntegral clockTicks) + return (( (realToInteger u_ticks + realToInteger s_ticks) * 1000000000000) + `div` fromIntegral clockTicks) type CTms = () -foreign import unsafe times :: Ptr CTms -> IO CClock +foreign import ccall unsafe times :: Ptr CTms -> IO CClock # else ioException (IOError Nothing UnsupportedOperation - "getCPUTime" - "can't get CPU time" - Nothing) + "getCPUTime" + "can't get CPU time" + Nothing) # endif #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 @@ -95,12 +139,16 @@ foreign import unsafe times :: Ptr CTms -> IO CClock if toBool ok then do ut <- ft2psecs p_userTime kt <- ft2psecs p_kernelTime - return (fromIntegral (ut + kt)) + return (ut + kt) else return 0 - where ft2psecs ft = do - high <- (#peek FILETIME,dwHighDateTime) ft :: IO CLong - low <- (#peek FILETIME,dwLowDateTime) ft :: IO CLong - return (((fromIntegral high) * (2^32) + (fromIntegral low)) * 100000) + 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. @@ -108,19 +156,28 @@ foreign import unsafe times :: Ptr CTms -> IO CClock type FILETIME = () type HANDLE = () -- need proper Haskell names (initial lower-case character) -foreign import "GetCurrentProcess" unsafe getCurrentProcess :: IO (Ptr HANDLE) -foreign import "GetProcessTimes" unsafe getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt +foreign import stdcall unsafe "GetCurrentProcess" getCurrentProcess :: IO (Ptr HANDLE) +foreign import stdcall unsafe "GetProcessTimes" getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt #endif /* not _WIN32 */ +#endif /* __GLASGOW_HASKELL__ */ +-- |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. + +#ifndef __NHC__ cpuTimePrecision :: Integer cpuTimePrecision = round ((1000000000000::Integer) % fromIntegral (clockTicks)) +#endif +#ifdef __GLASGOW_HASKELL__ clockTicks :: Int clockTicks = #if defined(CLK_TCK) (#const CLK_TCK) #else unsafePerformIO (sysconf (#const _SC_CLK_TCK) >>= return . fromIntegral) -foreign import unsafe sysconf :: CInt -> IO CLong +foreign import ccall unsafe sysconf :: CInt -> IO CLong #endif +#endif /* __GLASGOW_HASKELL__ */