Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
f9d70457
Commit
f9d70457
authored
Jan 25, 2013
by
Simon Peyton Jones
Browse files
Merge branch 'master' of
http://darcs.haskell.org//packages/base
parents
71221e24
94e6d7db
Changes
8
Hide whitespace changes
Inline
Side-by-side
libraries/base/GHC/Event/Clock.hsc
View file @
f9d70457
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude,
BangPatterns,
ForeignFunctionInterface
, CApiFFI
#-}
{-# LANGUAGE NoImplicitPrelude, ForeignFunctionInterface #-}
module GHC.Event.Clock (getMonotonicTime
, initializeTimer
) where
module GHC.Event.Clock (getMonotonicTime) where
#include "HsBase.h"
import Foreign
import Foreign.C.Types
import GHC.Base
import GHC.Real
#if !darwin_HOST_OS
import Foreign.C.Error (throwErrnoIfMinus1_)
import GHC.Err
import GHC.Num
#endif
-- TODO: Implement this for Windows.
initializeTimer :: IO ()
import Data.Word
-- | Return monotonic time in seconds, since some unspecified starting point
getMonotonicTime :: IO Double
getMonotonicTime = do w <- getMonotonicNSec
return (fromIntegral w / 1000000000)
------------------------------------------------------------------------
-- FFI binding
#if HAVE_CLOCK_GETTIME
initializeTimer = return ()
getMonotonicTime = do
tv <- with (CTimespec 0 0) $ \tvptr -> do
throwErrnoIfMinus1_ "clock_gettime" (clock_gettime (#const CLOCK_ID) tvptr)
peek tvptr
let !t = realToFrac (sec tv) + realToFrac (nsec tv) / 1000000000.0
return t
data CTimespec = CTimespec
{ sec :: {-# UNPACK #-} !CTime
, nsec :: {-# UNPACK #-} !CLong
}
instance Storable CTimespec where
sizeOf _ = #size struct timespec
alignment _ = alignment (undefined :: CLong)
peek ptr = do
sec' <- #{peek struct timespec, tv_sec} ptr
nsec' <- #{peek struct timespec, tv_nsec} ptr
return $ CTimespec sec' nsec'
poke ptr tv = do
#{poke struct timespec, tv_sec} ptr (sec tv)
#{poke struct timespec, tv_nsec} ptr (nsec tv)
foreign import capi unsafe "HsBase.h clock_gettime" clock_gettime
:: Int -> Ptr CTimespec -> IO CInt
#elif darwin_HOST_OS
getMonotonicTime = do
with 0.0 $ \timeptr -> do
absolute_time timeptr
ctime <- peek timeptr
let !time = realToFrac ctime
return time
foreign import capi unsafe "HsBase.h absolute_time" absolute_time ::
Ptr CDouble -> IO ()
foreign import capi unsafe "HsBase.h initialize_timer"
initializeTimer :: IO ()
#else
initializeTimer = return ()
getMonotonicTime = do
tv <- with (CTimeval 0 0) $ \tvptr -> do
throwErrnoIfMinus1_ "gettimeofday" (gettimeofday tvptr nullPtr)
peek tvptr
let !t = realToFrac (sec tv) + realToFrac (usec tv) / 1000000.0
return t
data CTimeval = CTimeval
{ sec :: {-# UNPACK #-} !CTime
, usec :: {-# UNPACK #-} !CSUSeconds
}
instance Storable CTimeval where
sizeOf _ = #size struct timeval
alignment _ = alignment (undefined :: CLong)
peek ptr = do
sec' <- #{peek struct timeval, tv_sec} ptr
usec' <- #{peek struct timeval, tv_usec} ptr
return $ CTimeval sec' usec'
poke ptr tv = do
#{poke struct timeval, tv_sec} ptr (sec tv)
#{poke struct timeval, tv_usec} ptr (usec tv)
foreign import capi unsafe "HsBase.h gettimeofday" gettimeofday
:: Ptr CTimeval -> Ptr () -> IO CInt
foreign import ccall unsafe "getMonotonicNSec"
getMonotonicNSec :: IO Word64
#endif
libraries/base/GHC/Event/Thread.hs
View file @
f9d70457
...
...
@@ -27,7 +27,6 @@ import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
import
GHC.Event.Internal
(
eventIs
,
evtClose
)
import
GHC.Event.Manager
(
Event
,
EventManager
,
evtRead
,
evtWrite
,
loop
,
new
,
registerFd
,
unregisterFd_
,
registerTimeout
)
import
GHC.Event.Clock
(
initializeTimer
)
import
qualified
GHC.Event.Manager
as
M
import
System.IO.Unsafe
(
unsafePerformIO
)
import
System.Posix.Types
(
Fd
)
...
...
@@ -167,7 +166,6 @@ ensureIOManagerIsRunning :: IO ()
ensureIOManagerIsRunning
|
not
threaded
=
return
()
|
otherwise
=
do
initializeTimer
startIOManagerThread
startIOManagerThread
::
IO
()
...
...
libraries/base/GHC/Generics.hs
View file @
f9d70457
...
...
@@ -63,38 +63,38 @@ data V1 p
-- | Unit: used for constructors without arguments
data
U1
p
=
U1
deriving
(
Eq
,
Read
,
Show
)
deriving
(
Eq
,
Read
,
Show
,
Generic
)
-- | Used for marking occurrences of the parameter
newtype
Par1
p
=
Par1
{
unPar1
::
p
}
deriving
(
Eq
,
Read
,
Show
)
deriving
(
Eq
,
Read
,
Show
,
Generic
)
-- | Recursive calls of kind * -> *
newtype
Rec1
f
p
=
Rec1
{
unRec1
::
f
p
}
deriving
(
Eq
,
Read
,
Show
)
deriving
(
Eq
,
Read
,
Show
,
Generic
)
-- | Constants, additional parameters and recursion of kind *
newtype
K1
i
c
p
=
K1
{
unK1
::
c
}
deriving
(
Eq
,
Read
,
Show
)
deriving
(
Eq
,
Read
,
Show
,
Generic
)
-- | Meta-information (constructor names, etc.)
newtype
M1
i
c
f
p
=
M1
{
unM1
::
f
p
}
deriving
(
Eq
,
Read
,
Show
)
deriving
(
Eq
,
Read
,
Show
,
Generic
)
-- | Sums: encode choice between constructors
infixr
5
:+:
data
(
:+:
)
f
g
p
=
L1
(
f
p
)
|
R1
(
g
p
)
deriving
(
Eq
,
Read
,
Show
)
deriving
(
Eq
,
Read
,
Show
,
Generic
)
-- | Products: encode multiple arguments to constructors
infixr
6
:*:
data
(
:*:
)
f
g
p
=
f
p
:*:
g
p
deriving
(
Eq
,
Read
,
Show
)
deriving
(
Eq
,
Read
,
Show
,
Generic
)
-- | Composition of functors
infixr
7
:.:
newtype
(
:.:
)
f
g
p
=
Comp1
{
unComp1
::
f
(
g
p
)
}
deriving
(
Eq
,
Read
,
Show
)
deriving
(
Eq
,
Read
,
Show
,
Generic
)
-- | Tag for K1: recursion (of kind *)
data
R
...
...
@@ -159,12 +159,12 @@ class Constructor c where
-- | Datatype to represent the arity of a tuple.
data
Arity
=
NoArity
|
Arity
Int
deriving
(
Eq
,
Show
,
Ord
,
Read
)
deriving
(
Eq
,
Show
,
Ord
,
Read
,
Generic
)
-- | Datatype to represent the fixity of a constructor. An infix
-- | declaration directly corresponds to an application of 'Infix'.
data
Fixity
=
Prefix
|
Infix
Associativity
Int
deriving
(
Eq
,
Show
,
Ord
,
Read
)
deriving
(
Eq
,
Show
,
Ord
,
Read
,
Generic
)
-- | Get the precedence of a fixity value.
prec
::
Fixity
->
Int
...
...
@@ -175,7 +175,7 @@ prec (Infix _ n) = n
data
Associativity
=
LeftAssociative
|
RightAssociative
|
NotAssociative
deriving
(
Eq
,
Show
,
Ord
,
Read
)
deriving
(
Eq
,
Show
,
Ord
,
Read
,
Generic
)
-- | Representable types of kind *.
-- This class is derivable in GHC with the DeriveGeneric flag on.
...
...
libraries/base/System/CPUTime.hsc
View file @
f9d70457
...
...
@@ -39,14 +39,6 @@ import CPUTime ( getCPUTime, cpuTimePrecision )
#ifdef __GLASGOW_HASKELL__
import Foreign.Safe
import Foreign.C
#if !defined(CLK_TCK)
import System.IO.Unsafe (unsafePerformIO)
#endif
-- For _SC_CLK_TCK
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
-- For struct rusage
#if !defined(mingw32_HOST_OS) && !defined(irix_HOST_OS)
...
...
@@ -60,11 +52,6 @@ import System.IO.Unsafe (unsafePerformIO)
#include <windows.h>
#endif
-- for CLK_TCK
#if HAVE_TIME_H
#include <time.h>
#endif
-- for struct tms
#if HAVE_SYS_TIMES_H
#include <sys/times.h>
...
...
@@ -185,13 +172,8 @@ cpuTimePrecision = round ((1000000000000::Integer) % fromIntegral (clockTicks))
#endif
#ifdef __GLASGOW_HASKELL__
foreign import ccall unsafe clk_tck :: CLong
clockTicks :: Int
clockTicks =
#if defined(CLK_TCK)
(#const CLK_TCK)
#else
unsafePerformIO (sysconf (#const _SC_CLK_TCK) >>= return . fromIntegral)
foreign import ccall unsafe sysconf :: CInt -> IO CLong
#endif
clockTicks = fromIntegral clk_tck
#endif /* __GLASGOW_HASKELL__ */
libraries/base/aclocal.m4
View file @
f9d70457
...
...
@@ -126,49 +126,47 @@ AC_DEFUN([FPTOOLS_CHECK_HTYPE_ELSE],[
AC_CACHE_VAL(AC_CV_NAME,[
AC_CV_NAME_supported=yes
FP_COMPUTE_INT([HTYPE_IS_INTEGRAL],
[(($1)((int)(($1)1.4))) == (($1)1.4)],
[FPTOOLS_HTYPE_INCLUDES],[AC_CV_NAME_supported=no])
if test "$AC_CV_NAME_supported" = "yes"
[($1)1.4],
[FPTOOLS_HTYPE_INCLUDES],[HTYPE_IS_INTEGRAL=0])
if test "$HTYPE_IS_INTEGRAL" -eq 0
then
if test "$HTYPE_IS_INTEGRAL" -eq 0
FP_COMPUTE_INT([HTYPE_IS_FLOAT],[sizeof($1) == sizeof(float)],
[FPTOOLS_HTYPE_INCLUDES],
[AC_CV_NAME_supported=no])
FP_COMPUTE_INT([HTYPE_IS_DOUBLE],[sizeof($1) == sizeof(double)],
[FPTOOLS_HTYPE_INCLUDES],
[AC_CV_NAME_supported=no])
FP_COMPUTE_INT([HTYPE_IS_LDOUBLE],[sizeof($1) == sizeof(long double)],
[FPTOOLS_HTYPE_INCLUDES],
[AC_CV_NAME_supported=no])
if test "$HTYPE_IS_FLOAT" -eq 1
then
AC_CV_NAME=Float
elif test "$HTYPE_IS_DOUBLE" -eq 1
then
FP_COMPUTE_INT([HTYPE_IS_FLOAT],[sizeof($1) == sizeof(float)],
[FPTOOLS_HTYPE_INCLUDES],
[AC_CV_NAME_supported=no])
FP_COMPUTE_INT([HTYPE_IS_DOUBLE],[sizeof($1) == sizeof(double)],
[FPTOOLS_HTYPE_INCLUDES],
[AC_CV_NAME_supported=no])
FP_COMPUTE_INT([HTYPE_IS_LDOUBLE],[sizeof($1) == sizeof(long double)],
[FPTOOLS_HTYPE_INCLUDES],
[AC_CV_NAME_supported=no])
if test "$HTYPE_IS_FLOAT" -eq 1
then
AC_CV_NAME=Float
elif test "$HTYPE_IS_DOUBLE" -eq 1
then
AC_CV_NAME=Double
elif test "$HTYPE_IS_LDOUBLE" -eq 1
then
AC_CV_NAME=LDouble
else
AC_CV_NAME_supported=no
fi
AC_CV_NAME=Double
elif test "$HTYPE_IS_LDOUBLE" -eq 1
then
AC_CV_NAME=LDouble
else
FP_COMPUTE_INT([HTYPE_IS_SIGNED],[(($1)(-1)) < (($1)0)],
[FPTOOLS_HTYPE_INCLUDES],
[AC_CV_NAME_supported=no])
FP_COMPUTE_INT([HTYPE_SIZE],[sizeof($1) * 8],
[FPTOOLS_HTYPE_INCLUDES],
[AC_CV_NAME_supported=no])
if test "$HTYPE_IS_SIGNED" -eq 0
then
AC_CV_NAME="Word$HTYPE_SIZE"
else
AC_CV_NAME="Int$HTYPE_SIZE"
fi
AC_CV_NAME_supported=no
fi
else
FP_COMPUTE_INT([HTYPE_IS_SIGNED],[(($1)(-1)) < (($1)0)],
[FPTOOLS_HTYPE_INCLUDES],
[AC_CV_NAME_supported=no])
FP_COMPUTE_INT([HTYPE_SIZE],[sizeof($1) * 8],
[FPTOOLS_HTYPE_INCLUDES],
[AC_CV_NAME_supported=no])
if test "$HTYPE_IS_SIGNED" -eq 0
then
AC_CV_NAME="Word$HTYPE_SIZE"
else
AC_CV_NAME="Int$HTYPE_SIZE"
fi
fi
])
])
if test "$AC_CV_NAME_supported" = no
then
$2
...
...
libraries/base/base.cabal
View file @
f9d70457
...
...
@@ -225,6 +225,7 @@ Library {
cbits/inputReady.c
cbits/primFloat.c
cbits/md5.c
cbits/sysconf.c
include-dirs: include
includes: HsBase.h
install-includes: HsBase.h HsBaseConfig.h EventConfig.h WCsubst.h consUtils.h Typeable.h
...
...
libraries/base/cbits/sysconf.c
0 → 100644
View file @
f9d70457
#include
"HsBaseConfig.h"
/* For _SC_CLK_TCK */
#if HAVE_UNISTD_H
#include
<unistd.h>
#endif
/* for CLK_TCK */
#if HAVE_TIME_H
#include
<time.h>
#endif
long
clk_tck
(
void
)
{
#if defined(CLK_TCK)
return
(
CLK_TCK
);
#else
return
sysconf
(
_SC_CLK_TCK
);
#endif
}
libraries/base/tests/Numeric/all.T
View file @
f9d70457
...
...
@@ -15,4 +15,7 @@ test('num009', [ skip_if_fast
# We also get another set of results for 1e02 with GHCi, so
# I'm skipping that way altogether.
compile_and_run
,
[''])
test
('
num010
',
normal
,
compile_and_run
,
[''])
test
('
num010
',
if_platform
('
i386-apple-darwin
',
expect_broken_for
(
7043
,
'
ghci
')),
compile_and_run
,
[''])
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment