← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to libraries/base/System/CPUTime.hsc

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

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