diff --git a/Data/Typeable/Internal.hs b/Data/Typeable/Internal.hs --- a/Data/Typeable/Internal.hs +++ b/Data/Typeable/Internal.hs @@ -32,6 +32,11 @@ ----------------------------------------------------------------------------- module Data.Typeable.Internal ( + -- * Typeable and kind polymorphism + -- + -- #kind_instantiation + + -- * Miscellaneous Fingerprint(..), -- * Typeable class @@ -221,6 +226,13 @@ SomeTypeRep a `compare` SomeTypeRep b = typeRepFingerprint a `compare` typeRepFingerprint b +-- | The function type constructor. +-- +-- For instance, +-- @ +-- typeRep \@(Int -> Char) === Fun (typeRep \@Int) (typeRep \@Char) +-- @ +-- pattern Fun :: forall k (fun :: k). () => forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (arg :: TYPE r1) (res :: TYPE r2). @@ -265,7 +277,14 @@ fpr_b = typeRepFingerprint b fpr = fingerprintFingerprints [fpr_a, fpr_b] --- | Pattern match on a type application +-- | A type application. +-- +-- For instance, +-- @ +-- typeRep \@(Maybe Int) === App (typeRep \@Maybe) (typeRep \@Int) +-- @ +-- Note that this will never match a function type (e.g. @Int -> Char@). +-- pattern App :: forall k2 (t :: k2). () => forall k1 (a :: k1 -> k2) (b :: k1). (t ~ a b) => TypeRep a -> TypeRep b -> TypeRep t @@ -287,6 +306,18 @@ -- | Pattern match on a type constructor including its instantiated kind -- variables. +-- +-- For instance, +-- @ +-- App (Con' proxyTyCon ks) intRep = typeRep @(Proxy \@Int) +-- @ +-- will bring into scope, +-- @ +-- proxyTyCon :: TyCon +-- ks == [someTypeRep @Type] :: [SomeTypeRep] +-- intRep == typeRep @Int +-- @ +-- pattern Con' :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a pattern Con' con ks <- TrTyCon _ con ks @@ -659,3 +690,51 @@ mkTrFun arg res = TrFun fpr arg res where fpr = fingerprintFingerprints [ typeRepFingerprint arg , typeRepFingerprint res] + +{- $kind_instantiation + +Consider a type like 'Data.Proxy.Proxy', + +@ +data Proxy :: forall k. k -> Type +@ + +One might think that one could decompose an instantiation of this type like +@Proxy Int@ into two applications, + +@ +'App' (App a b) c === typeRep @(Proxy Int) +@ + +where, + +@ +a = typeRep @Proxy +b = typeRep @Type +c = typeRep @Int +@ + +However, this isn't the case. Instead we can only decompose into an application +and a constructor, + +@ +'App' ('Con' proxyTyCon) (typeRep @Int) === typeRep @(Proxy Int) +@ + +The reason for this is that 'Typeable' can only represent /kind-monomorphic/ +types. That is, we must saturate enough of @Proxy@\'s arguments to +fully determine its kind. In the particular case of @Proxy@ this means we must +instantiate the kind variable @k@ such that no @forall@-quantified variables +remain. + +While it is not possible to decompose the 'Con' above into an application, it is +possible to observe the kind variable instantiations of the constructor with the +'Con\'' pattern, + +@ +'App' (Con' proxyTyCon kinds) _ === typeRep @(Proxy Int) +@ + +Here @kinds@ will be @[typeRep \@Type]@. + +-} diff --git a/Foreign/Marshal/Alloc.hs b/Foreign/Marshal/Alloc.hs --- a/Foreign/Marshal/Alloc.hs +++ b/Foreign/Marshal/Alloc.hs @@ -123,6 +123,19 @@ doAlloca :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b' doAlloca dummy = allocaBytesAligned (sizeOf dummy) (alignment dummy) +-- Note [NOINLINE for touch#] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Both allocaBytes and allocaBytesAligned use the touch#, which is notoriously +-- fragile in the presence of simplification (see #14346). In particular, the +-- simplifier may drop the continuation containing the touch# if it can prove +-- that the action passed to allocaBytes will not return. The hack introduced to +-- fix this for 8.2.2 is to mark allocaBytes as NOINLINE, ensuring that the +-- simplifier can't see the divergence. +-- +-- These can be removed once #14375 is fixed, which suggests that we instead do +-- away with touch# in favor of a primitive that will capture the scoping left +-- implicit in the case of touch#. + -- |@'allocaBytes' n f@ executes the computation @f@, passing as argument -- a pointer to a temporarily allocated block of memory of @n@ bytes. -- The block of memory is sufficiently aligned for any of the basic @@ -141,6 +154,8 @@ case touch# barr# s3 of { s4 -> (# s4, r #) }}}}} +-- See Note [NOINLINE for touch#] +{-# NOINLINE allocaBytes #-} allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 -> @@ -152,6 +167,8 @@ case touch# barr# s3 of { s4 -> (# s4, r #) }}}}} +-- See Note [NOINLINE for touch#] +{-# NOINLINE allocaBytesAligned #-} -- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes' -- to the size needed to store values of type @b@. The returned pointer diff --git a/GHC/IO/Handle/Lock.hsc b/GHC/IO/Handle/Lock.hsc --- a/GHC/IO/Handle/Lock.hsc +++ b/GHC/IO/Handle/Lock.hsc @@ -99,16 +99,86 @@ ---------------------------------------- -#if HAVE_FLOCK +#if HAVE_OFD_LOCKING +-- Linux open file descriptor locking. +-- +-- We prefer this over BSD locking (e.g. flock) since the latter appears to +-- break in some NFS configurations. Note that we intentionally do not try to +-- use ordinary POSIX file locking due to its peculiar semantics under +-- multi-threaded environments. +foreign import ccall interruptible "fcntl" + c_fcntl :: CInt -> CInt -> Ptr () -> IO CInt + +data FLock = FLock { l_type :: CShort + , l_whence :: CShort + , l_start :: COff + , l_len :: COff + , l_pid :: CPid + } + +instance Storable FLock where + sizeOf _ = #{size flock} + alignment _ = #{alignment flock} + poke ptr x = do + fillBytes ptr 0 (sizeOf x) + #{poke flock, l_type} ptr (l_type x) + #{poke flock, l_whence} ptr (l_whence x) + #{poke flock, l_start} ptr (l_start x) + #{poke flock, l_len} ptr (l_len x) + #{poke flock, l_pid} ptr (l_pid x) + peek ptr = do + FLock <$> #{peek flock, l_type} ptr + <*> #{peek flock, l_whence} ptr + <*> #{peek flock, l_start} ptr + <*> #{peek flock, l_len} ptr + <*> #{peek flock, l_pid} ptr + lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool lockImpl h ctx mode block = do FD{fdFD = fd} <- handleToFd h + with flock $ \flock_ptr -> fix $ \retry -> do + ret <- with flock $ fcntl fd mode flock_ptr + case ret of + 0 -> return True + _ -> getErrno >>= \errno -> if + | not block && errno == eWOULDBLOCK -> return False + | errno == eINTR -> retry + | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing + where + flock = FLock { l_type = case mode of + SharedLock -> #{const F_RDLCK} + ExclusiveLock -> #{const F_WRLCK} + , l_whence = #{const SEEK_SET} + , l_start = 0 + , l_len = 0 + } + mode + | block = #{const F_SETLKW} + | otherwise = #{const F_SETLK} + +unlockImpl :: Handle -> IO () +unlockImpl h = do + FD{fdFD = fd} <- handleToFd h + let flock = FLock { l_type = #{const F_UNLCK} + , l_whence = #{const SEEK_SET} + , l_start = 0 + , l_len = 0 + } + throwErrnoIfMinus1_ "hUnlock" + $ with flock $ c_fcntl fd #{const F_SETLK} + +#elif HAVE_FLOCK + +lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool +lockImpl h ctx mode block = do + FD{fdFD = fd} <- handleToFd h let flags = cmode .|. (if block then 0 else #{const LOCK_NB}) fix $ \retry -> c_flock fd flags >>= \case 0 -> return True _ -> getErrno >>= \errno -> if - | not block && errno == eWOULDBLOCK -> return False + | not block + , errno == eAGAIN || errno == eACCES -> return False | errno == eINTR -> retry | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing where diff --git a/GHC/Natural.hs b/GHC/Natural.hs --- a/GHC/Natural.hs +++ b/GHC/Natural.hs @@ -346,6 +346,11 @@ -- TODO: setBit, clearBit, complementBit (needs more primitives) + -- NB: We cannot use the default impl of 'clearBit' due to + -- 'complement' not being well-defined for 'Natural' (c.f. #13203) + clearBit x i | testBit x i = complementBit x i + | otherwise = x + shiftL n 0 = n shiftL (NatS# 0##) _ = NatS# 0## shiftL (NatS# 1##) i = bit i diff --git a/base.cabal b/base.cabal --- a/base.cabal +++ b/base.cabal @@ -1,18 +1,18 @@ +cabal-version: 2.0 name: base -version: 4.10.0.0 --- NOTE: Don't forget to update ./changelog.md +version: 4.10.1.0 + license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org bug-reports: http://ghc.haskell.org/trac/ghc/newticket?component=libraries/base synopsis: Basic libraries category: Prelude +build-type: Configure description: - This package contains the "Prelude" and its support libraries, + This package contains the Standard Haskell "Prelude" and its support libraries, and a large collection of useful libraries ranging from data structures to parsing combinators and debugging utilities. -cabal-version: >=1.10 -build-type: Configure extra-tmp-files: autom4te.cache @@ -93,17 +93,17 @@ UnliftedFFITypes Unsafe - build-depends: rts == 1.0.*, ghc-prim == 0.5.* + build-depends: rts == 1.0, ghc-prim ^>= 0.5.1.0 -- sanity-check to ensure exactly one flag is set if !((flag(integer-gmp) && !flag(integer-simple)) || (!flag(integer-gmp) && flag(integer-simple))) build-depends: invalid-cabal-flag-settings<0 if flag(integer-simple) - build-depends: integer-simple >= 0.1.1 && < 0.2 + build-depends: integer-simple ^>= 0.1.1 if flag(integer-gmp) - build-depends: integer-gmp >= 1.0 && < 1.1 + build-depends: integer-gmp ^>= 1.0.1 cpp-options: -DOPTIMISE_INTEGER_GCD_LCM exposed-modules: diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,13 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) +## 4.10.1.0 *November 2017* + * Bundled with GHC 8.2.2 + + * The file locking primitives provided by `GHC.IO.Handle` now use + Linux open file descriptor locking if available. + + * Fixed bottoming definition of `clearBit` for `Natural` + ## 4.10.0.0 *July 2017* * Bundled with GHC 8.2.1 diff --git a/configure b/configure --- a/configure +++ b/configure @@ -2017,6 +2017,52 @@ as_fn_set_status $ac_retval } # ac_fn_c_compute_int + +# ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES +# --------------------------------------------- +# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR +# accordingly. +ac_fn_c_check_decl () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + as_decl_name=`echo $2|sed 's/ *(.*//'` + as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5 +$as_echo_n "checking whether $as_decl_name is declared... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +#ifndef $as_decl_name +#ifdef __cplusplus + (void) $as_decl_use; +#else + (void) $as_decl_name; +#endif +#endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_decl cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. @@ -4339,7 +4385,18 @@ fi -#flock +# Linux open file description locks +ac_fn_c_check_decl "$LINENO" "F_OFD_SETLK" "ac_cv_have_decl_F_OFD_SETLK" "$ac_includes_default" +if test "x$ac_cv_have_decl_F_OFD_SETLK" = xyes; then : + + +$as_echo "#define HAVE_OFD_LOCKING 1" >>confdefs.h + + +fi + + +# flock for ac_func in flock do : ac_fn_c_check_func "$LINENO" "flock" "ac_cv_func_flock" diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -69,7 +69,12 @@ AC_DEFINE([HAVE_POLL], [1], [Define if you have poll support.]) fi -#flock +# Linux open file description locks +AC_CHECK_DECL([F_OFD_SETLK], [ + AC_DEFINE([HAVE_OFD_LOCKING], [1], [Define if you have open file descriptor lock support.]) +]) + +# flock AC_CHECK_FUNCS([flock]) if test "$ac_cv_header_sys_file_h" = yes && test "$ac_cv_func_flock" = yes; then AC_DEFINE([HAVE_FLOCK], [1], [Define if you have flock support.]) diff --git a/include/HsBaseConfig.h.in b/include/HsBaseConfig.h.in --- a/include/HsBaseConfig.h.in +++ b/include/HsBaseConfig.h.in @@ -375,6 +375,9 @@ /* Define to 1 if you have the header file. */ #undef HAVE_MEMORY_H +/* Define if you have open file descriptor lock support. */ +#undef HAVE_OFD_LOCKING + /* Define if you have poll support. */ #undef HAVE_POLL