Update base for latest Safe Haskell.
[packages/base.git] / System / CPUTime.hsc
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE CPP, NondecreasingIndentation, ForeignFunctionInterface #-}
3
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module      :  System.CPUTime
7 -- Copyright   :  (c) The University of Glasgow 2001
8 -- License     :  BSD-style (see the file libraries/base/LICENSE)
9 -- 
10 -- Maintainer  :  libraries@haskell.org
11 -- Stability   :  provisional
12 -- Portability :  portable
13 --
14 -- The standard CPUTime library.
15 --
16 -----------------------------------------------------------------------------
17
18 #include "HsFFI.h"
19 #include "HsBaseConfig.h"
20
21 module System.CPUTime 
22         (
23          getCPUTime,       -- :: IO Integer
24          cpuTimePrecision  -- :: Integer
25         ) where
26
27 import Prelude
28
29 import Data.Ratio
30
31 #ifdef __HUGS__
32 import Hugs.Time ( getCPUTime, clockTicks )
33 #endif
34
35 #ifdef __NHC__
36 import CPUTime ( getCPUTime, cpuTimePrecision )
37 #endif
38
39 #ifdef __GLASGOW_HASKELL__
40 import Foreign.Safe
41 import Foreign.C
42 #if !defined(CLK_TCK)
43 import System.IO.Unsafe (unsafePerformIO)
44 #endif
45
46 -- For _SC_CLK_TCK
47 #if HAVE_UNISTD_H
48 #include <unistd.h>
49 #endif
50
51 -- For struct rusage
52 #if !defined(mingw32_HOST_OS) && !defined(irix_HOST_OS)
53 # if HAVE_SYS_RESOURCE_H
54 #  include <sys/resource.h>
55 # endif
56 #endif
57
58 -- For FILETIME etc. on Windows
59 #if HAVE_WINDOWS_H
60 #include <windows.h>
61 #endif
62
63 -- for CLK_TCK
64 #if HAVE_TIME_H
65 #include <time.h>
66 #endif
67
68 -- for struct tms
69 #if HAVE_SYS_TIMES_H
70 #include <sys/times.h>
71 #endif
72
73 #endif
74
75 #if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS)
76 realToInteger :: Real a => a -> Integer
77 realToInteger ct = round (realToFrac ct :: Double)
78   -- CTime, CClock, CUShort etc are in Real but not Fractional, 
79   -- so we must convert to Double before we can round it
80 #endif
81
82 #ifdef __GLASGOW_HASKELL__
83 -- -----------------------------------------------------------------------------
84 -- |Computation 'getCPUTime' returns the number of picoseconds CPU time
85 -- used by the current program.  The precision of this result is
86 -- implementation-dependent.
87
88 getCPUTime :: IO Integer
89 getCPUTime = do
90
91 #if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS)
92 -- getrusage() is right royal pain to deal with when targetting multiple
93 -- versions of Solaris, since some versions supply it in libc (2.3 and 2.5),
94 -- while 2.4 has got it in libucb (I wouldn't be too surprised if it was back
95 -- again in libucb in 2.6..)
96 --
97 -- Avoid the problem by resorting to times() instead.
98 --
99 #if defined(HAVE_GETRUSAGE) && ! irix_HOST_OS && ! solaris2_HOST_OS
100     allocaBytes (#const sizeof(struct rusage)) $ \ p_rusage -> do
101     throwErrnoIfMinus1_ "getrusage" $ getrusage (#const RUSAGE_SELF) p_rusage
102
103     let ru_utime = (#ptr struct rusage, ru_utime) p_rusage
104     let ru_stime = (#ptr struct rusage, ru_stime) p_rusage
105     u_sec  <- (#peek struct timeval,tv_sec)  ru_utime :: IO CTime
106     u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CSUSeconds
107     s_sec  <- (#peek struct timeval,tv_sec)  ru_stime :: IO CTime
108     s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CSUSeconds
109     return ((realToInteger u_sec * 1000000 + realToInteger u_usec + 
110              realToInteger s_sec * 1000000 + realToInteger s_usec) 
111                 * 1000000)
112
113 type CRUsage = ()
114 foreign import ccall unsafe getrusage :: CInt -> Ptr CRUsage -> IO CInt
115 #else
116 # if defined(HAVE_TIMES)
117     allocaBytes (#const sizeof(struct tms)) $ \ p_tms -> do
118     _ <- times p_tms
119     u_ticks  <- (#peek struct tms,tms_utime) p_tms :: IO CClock
120     s_ticks  <- (#peek struct tms,tms_stime) p_tms :: IO CClock
121     return (( (realToInteger u_ticks + realToInteger s_ticks) * 1000000000000) 
122                         `div` fromIntegral clockTicks)
123
124 type CTms = ()
125 foreign import ccall unsafe times :: Ptr CTms -> IO CClock
126 # else
127     ioException (IOError Nothing UnsupportedOperation 
128                          "getCPUTime"
129                          "can't get CPU time"
130                          Nothing)
131 # endif
132 #endif
133
134 #else /* win32 */
135      -- NOTE: GetProcessTimes() is only supported on NT-based OSes.
136      -- The counts reported by GetProcessTimes() are in 100-ns (10^-7) units.
137     allocaBytes (#const sizeof(FILETIME)) $ \ p_creationTime -> do
138     allocaBytes (#const sizeof(FILETIME)) $ \ p_exitTime -> do
139     allocaBytes (#const sizeof(FILETIME)) $ \ p_kernelTime -> do
140     allocaBytes (#const sizeof(FILETIME)) $ \ p_userTime -> do
141     pid <- getCurrentProcess
142     ok <- getProcessTimes pid p_creationTime p_exitTime p_kernelTime p_userTime
143     if toBool ok then do
144       ut <- ft2psecs p_userTime
145       kt <- ft2psecs p_kernelTime
146       return (ut + kt)
147      else return 0
148   where 
149         ft2psecs :: Ptr FILETIME -> IO Integer
150         ft2psecs ft = do
151           high <- (#peek FILETIME,dwHighDateTime) ft :: IO Word32
152           low  <- (#peek FILETIME,dwLowDateTime)  ft :: IO Word32
153             -- Convert 100-ns units to picosecs (10^-12) 
154             -- => multiply by 10^5.
155           return (((fromIntegral high) * (2^(32::Int)) + (fromIntegral low)) * 100000)
156
157     -- ToDo: pin down elapsed times to just the OS thread(s) that
158     -- are evaluating/managing Haskell code.
159
160 type FILETIME = ()
161 type HANDLE = ()
162 -- need proper Haskell names (initial lower-case character)
163 foreign import stdcall unsafe "GetCurrentProcess" getCurrentProcess :: IO (Ptr HANDLE)
164 foreign import stdcall unsafe "GetProcessTimes" getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt
165
166 #endif /* not _WIN32 */
167 #endif /* __GLASGOW_HASKELL__ */
168
169 -- |The 'cpuTimePrecision' constant is the smallest measurable difference
170 -- in CPU time that the implementation can record, and is given as an
171 -- integral number of picoseconds.
172
173 #ifndef __NHC__
174 cpuTimePrecision :: Integer
175 cpuTimePrecision = round ((1000000000000::Integer) % fromIntegral (clockTicks))
176 #endif
177
178 #ifdef __GLASGOW_HASKELL__
179 clockTicks :: Int
180 clockTicks =
181 #if defined(CLK_TCK)
182     (#const CLK_TCK)
183 #else
184     unsafePerformIO (sysconf (#const _SC_CLK_TCK) >>= return . fromIntegral)
185 foreign import ccall unsafe sysconf :: CInt -> IO CLong
186 #endif
187 #endif /* __GLASGOW_HASKELL__ */
188