diff --git a/GHC/CString.hs b/GHC/CString.hs --- a/GHC/CString.hs +++ b/GHC/CString.hs @@ -125,24 +125,28 @@ unpackCStringUtf8# addr = unpack 0# where + -- We take care to strictly evaluate the character decoding as + -- indexCharOffAddr# is marked with the can_fail flag and + -- consequently GHC won't evaluate the expression unless it is absolutely + -- needed. unpack nh | isTrue# (ch `eqChar#` '\0'# ) = [] | isTrue# (ch `leChar#` '\x7F'#) = C# ch : unpack (nh +# 1#) | isTrue# (ch `leChar#` '\xDF'#) = - C# (chr# (((ord# ch -# 0xC0#) `uncheckedIShiftL#` 6#) +# - (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) : - unpack (nh +# 2#) + let !c = C# (chr# (((ord# ch -# 0xC0#) `uncheckedIShiftL#` 6#) +# + (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) + in c : unpack (nh +# 2#) | isTrue# (ch `leChar#` '\xEF'#) = - C# (chr# (((ord# ch -# 0xE0#) `uncheckedIShiftL#` 12#) +# - ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) : - unpack (nh +# 3#) + let !c = C# (chr# (((ord# ch -# 0xE0#) `uncheckedIShiftL#` 12#) +# + ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 6#) +# + (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) + in c : unpack (nh +# 3#) | True = - C# (chr# (((ord# ch -# 0xF0#) `uncheckedIShiftL#` 18#) +# - ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12#) +# - ((ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) : - unpack (nh +# 4#) + let !c = C# (chr# (((ord# ch -# 0xF0#) `uncheckedIShiftL#` 18#) +# + ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12#) +# + ((ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#` 6#) +# + (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) + in c : unpack (nh +# 4#) where !ch = indexCharOffAddr# addr nh diff --git a/GHC/Prim.hs b/GHC/Prim.hs --- a/GHC/Prim.hs +++ b/GHC/Prim.hs @@ -158,6 +158,16 @@ popCnt32#, popCnt64#, popCnt#, + pdep8#, + pdep16#, + pdep32#, + pdep64#, + pdep#, + pext8#, + pext16#, + pext32#, + pext64#, + pext#, clz8#, clz16#, clz32#, @@ -391,6 +401,7 @@ writeWord16Array#, writeWord32Array#, writeWord64Array#, + compareByteArrays#, copyByteArray#, copyMutableByteArray#, copyByteArrayToAddr#, @@ -1489,7 +1500,7 @@ -- |Return non-zero if there is any possibility that the upper word of a -- signed integer multiply might contain useful information. Return -- zero only if you are completely sure that no overflow can occur. --- On a 32-bit platform, the recommmended implementation is to do a +-- On a 32-bit platform, the recommended implementation is to do a -- 32 x 32 -> 64 signed multiply, and subtract result[63:32] from -- (result[31] >>signed 31). If this is zero, meaning that the -- upper word is merely a sign extension of the lower one, no @@ -1728,6 +1739,56 @@ popCnt# :: Word# -> Word# popCnt# = popCnt# +-- |Deposit bits to lower 8 bits of a word at locations specified by a mask. + +pdep8# :: Word# -> Word# -> Word# +pdep8# = pdep8# + +-- |Deposit bits to lower 16 bits of a word at locations specified by a mask. + +pdep16# :: Word# -> Word# -> Word# +pdep16# = pdep16# + +-- |Deposit bits to lower 32 bits of a word at locations specified by a mask. + +pdep32# :: Word# -> Word# -> Word# +pdep32# = pdep32# + +-- |Deposit bits to a word at locations specified by a mask. + +pdep64# :: Word# -> Word# -> Word# +pdep64# = pdep64# + +-- |Deposit bits to a word at locations specified by a mask. + +pdep# :: Word# -> Word# -> Word# +pdep# = pdep# + +-- |Extract bits from lower 8 bits of a word at locations specified by a mask. + +pext8# :: Word# -> Word# -> Word# +pext8# = pext8# + +-- |Extract bits from lower 16 bits of a word at locations specified by a mask. + +pext16# :: Word# -> Word# -> Word# +pext16# = pext16# + +-- |Extract bits from lower 32 bits of a word at locations specified by a mask. + +pext32# :: Word# -> Word# -> Word# +pext32# = pext32# + +-- |Extract bits from a word at locations specified by a mask. + +pext64# :: Word# -> Word# -> Word# +pext64# = pext64# + +-- |Extract bits from a word at locations specified by a mask. + +pext# :: Word# -> Word# -> Word# +pext# = pext# + -- |Count leading zeros in the lower 8 bits of a word. clz8# :: Word# -> Word# @@ -2085,9 +2146,10 @@ -- |Given a source array, an offset into the source array, a -- destination array, an offset into the destination array, and a -- number of elements to copy, copy the elements from the source array --- to the destination array. The source and destination arrays can --- refer to the same array. Both arrays must fully contain the --- specified ranges, but this is not checked. +-- to the destination array. Both arrays must fully contain the +-- specified ranges, but this is not checked. In the case where +-- the source and destination are the same array the source and +-- destination regions may overlap. copyMutableArray# :: MutableArray# s a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s copyMutableArray# = copyMutableArray# @@ -2196,6 +2258,8 @@ -- to the destination array. The source and destination arrays can -- refer to the same array. Both arrays must fully contain the -- specified ranges, but this is not checked. +-- The regions are allowed to overlap, although this is only possible when the same +-- array is provided as both the source and the destination. copySmallMutableArray# :: SmallMutableArray# s a -> Int# -> SmallMutableArray# s a -> Int# -> Int# -> State# s -> State# s copySmallMutableArray# = copySmallMutableArray# @@ -2398,7 +2462,7 @@ readWideCharArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Char# #) readWideCharArray# = readWideCharArray# --- |Read intger; offset in words. +-- |Read integer; offset in words. readIntArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s,Int# #) readIntArray# = readIntArray# @@ -2496,15 +2560,34 @@ writeWord64Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s writeWord64Array# = writeWord64Array# --- |Copy a range of the ByteArray# to the specified region in the MutableByteArray#. --- Both arrays must fully contain the specified ranges, but this is not checked. --- The two arrays must not be the same array in different states, but this is not checked either. +-- |@compareByteArrays# src1 src1_ofs src2 src2_ofs n@ compares +-- @n@ bytes starting at offset @src1_ofs@ in the first +-- @ByteArray#@ @src1@ to the range of @n@ bytes +-- (i.e. same length) starting at offset @src2_ofs@ of the second +-- @ByteArray#@ @src2@. Both arrays must fully contain the +-- specified ranges, but this is not checked. Returns an @Int#@ +-- less than, equal to, or greater than zero if the range is found, +-- respectively, to be byte-wise lexicographically less than, to +-- match, or be greater than the second range. +compareByteArrays# :: ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int# +compareByteArrays# = compareByteArrays# + +-- |@copyByteArray# src src_ofs dst dst_ofs n@ copies the range +-- starting at offset @src_ofs@ of length @n@ from the +-- @ByteArray#@ @src@ to the @MutableByteArray#@ @dst@ +-- starting at offset @dst_ofs@. Both arrays must fully contain +-- the specified ranges, but this is not checked. The two arrays must +-- not be the same array in different states, but this is not checked +-- either. + copyByteArray# :: ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s copyByteArray# = copyByteArray# -- |Copy a range of the first MutableByteArray# to the specified region in the second MutableByteArray#. --- Both arrays must fully contain the specified ranges, but this is not checked. +-- Both arrays must fully contain the specified ranges, but this is not checked. The regions are +-- allowed to overlap, although this is only possible when the same array is provided +-- as both the source and the destination. copyMutableByteArray# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s copyMutableByteArray# = copyMutableByteArray# @@ -2674,6 +2757,9 @@ -- |Copy a range of the first MutableArrayArray# to the specified region in the second -- MutableArrayArray#. -- Both arrays must fully contain the specified ranges, but this is not checked. +-- The regions are allowed to overlap, although this is only possible when the same +-- array is provided as both the source and the destination. +-- copyMutableArrayArray# :: MutableArrayArray# s -> Int# -> MutableArrayArray# s -> Int# -> Int# -> State# s -> State# s copyMutableArrayArray# = copyMutableArrayArray# @@ -3238,7 +3324,7 @@ compactSize# :: Compact# -> State# (RealWorld) -> (# State# (RealWorld),Word# #) compactSize# = compactSize# --- | Returns 1# if the given pointers are equal and 0# otherwise. +-- | Returns {\texttt 1\#} if the given pointers are equal and {\texttt 0\#} otherwise. reallyUnsafePtrEquality# :: a -> a -> Int# reallyUnsafePtrEquality# = reallyUnsafePtrEquality# @@ -3299,7 +3385,7 @@ addrToAny# :: Addr# -> (# a #) addrToAny# = addrToAny# --- | Retrive the address of any Haskell value. This is +-- | Retrieve the address of any Haskell value. This is -- essentially an {\texttt unsafeCoerce\#}, but if implemented as such -- the core lint pass complains and fails to compile. -- As a primop, it is opaque to core\/stg, and only appears @@ -3344,7 +3430,7 @@ -- | Returns the current @CostCentreStack@ (value is @NULL@ if -- not profiling). Takes a dummy argument which can be used to --- avoid the call to @getCCCS\#@ being floated out by the +-- avoid the call to @getCurrentCCS\#@ being floated out by the -- simplifier, which would result in an uninformative stack -- (\"CAF\"). @@ -3373,8 +3459,9 @@ proxy# = proxy# -- | The value of @seq a b@ is bottom if @a@ is bottom, and --- otherwise equal to @b@. @seq@ is usually introduced to --- improve performance by avoiding unneeded laziness. +-- otherwise equal to @b@. In other words, it evaluates the first +-- argument @a@ to weak head normal form (WHNF). @seq@ is usually +-- introduced to improve performance by avoiding unneeded laziness. -- -- A note on evaluation order: the expression @seq a b@ does -- /not/ guarantee that @a@ will be evaluated before @b@. @@ -3400,8 +3487,9 @@ -- -- * Casting @Any@ back to the real type -- --- * Casting an unboxed type to another unboxed type of the same size --- (but not coercions between floating-point and integral types) +-- * Casting an unboxed type to another unboxed type of the same size. +-- (Casting between floating-point and integral types does not work. +-- See the @GHC.Float@ module for functions to do work.) -- -- * Casting between two types that have the same runtime representation. One case is when -- the two types differ only in \"phantom\" type parameters, for example @@ -3413,7 +3501,7 @@ -- @unsafeCoerce\#@ to cast a T to an algebraic data type D, unless T is also -- an algebraic data type. For example, do not cast @Int->Int@ to @Bool@, even if -- you later cast that @Bool@ back to @Int->Int@ before applying it. The reasons --- have to do with GHC\'s internal representation details (for the congnoscenti, data values +-- have to do with GHC\'s internal representation details (for the cognoscenti, data values -- can be entered but function closures cannot). If you want a safe type to cast things -- to, use @Any@, which is not an algebraic data type. -- diff --git a/GHC/PrimopWrappers.hs b/GHC/PrimopWrappers.hs --- a/GHC/PrimopWrappers.hs +++ b/GHC/PrimopWrappers.hs @@ -195,6 +195,36 @@ {-# NOINLINE popCnt# #-} popCnt# :: Word# -> Word# popCnt# a1 = (GHC.Prim.popCnt#) a1 +{-# NOINLINE pdep8# #-} +pdep8# :: Word# -> Word# -> Word# +pdep8# a1 a2 = (GHC.Prim.pdep8#) a1 a2 +{-# NOINLINE pdep16# #-} +pdep16# :: Word# -> Word# -> Word# +pdep16# a1 a2 = (GHC.Prim.pdep16#) a1 a2 +{-# NOINLINE pdep32# #-} +pdep32# :: Word# -> Word# -> Word# +pdep32# a1 a2 = (GHC.Prim.pdep32#) a1 a2 +{-# NOINLINE pdep64# #-} +pdep64# :: Word# -> Word# -> Word# +pdep64# a1 a2 = (GHC.Prim.pdep64#) a1 a2 +{-# NOINLINE pdep# #-} +pdep# :: Word# -> Word# -> Word# +pdep# a1 a2 = (GHC.Prim.pdep#) a1 a2 +{-# NOINLINE pext8# #-} +pext8# :: Word# -> Word# -> Word# +pext8# a1 a2 = (GHC.Prim.pext8#) a1 a2 +{-# NOINLINE pext16# #-} +pext16# :: Word# -> Word# -> Word# +pext16# a1 a2 = (GHC.Prim.pext16#) a1 a2 +{-# NOINLINE pext32# #-} +pext32# :: Word# -> Word# -> Word# +pext32# a1 a2 = (GHC.Prim.pext32#) a1 a2 +{-# NOINLINE pext64# #-} +pext64# :: Word# -> Word# -> Word# +pext64# a1 a2 = (GHC.Prim.pext64#) a1 a2 +{-# NOINLINE pext# #-} +pext# :: Word# -> Word# -> Word# +pext# a1 a2 = (GHC.Prim.pext#) a1 a2 {-# NOINLINE clz8# #-} clz8# :: Word# -> Word# clz8# a1 = (GHC.Prim.clz8#) a1 @@ -705,6 +735,9 @@ {-# NOINLINE writeWord64Array# #-} writeWord64Array# :: MutableByteArray# s -> Int# -> Word# -> State# s -> State# s writeWord64Array# a1 a2 a3 a4 = (GHC.Prim.writeWord64Array#) a1 a2 a3 a4 +{-# NOINLINE compareByteArrays# #-} +compareByteArrays# :: ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int# +compareByteArrays# a1 a2 a3 a4 a5 = (GHC.Prim.compareByteArrays#) a1 a2 a3 a4 a5 {-# NOINLINE copyByteArray# #-} copyByteArray# :: ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s copyByteArray# a1 a2 a3 a4 a5 a6 = (GHC.Prim.copyByteArray#) a1 a2 a3 a4 a5 a6 diff --git a/GHC/Types.hs b/GHC/Types.hs --- a/GHC/Types.hs +++ b/GHC/Types.hs @@ -122,7 +122,7 @@ ********************************************************************* -} {- | The character type 'Char' is an enumeration whose values represent -Unicode (or equivalently ISO\/IEC 10646) characters (see +Unicode (or equivalently ISO\/IEC 10646) code points (i.e. characters, see for details). This set extends the ISO 8859-1 (Latin-1) character set (the first 256 characters), which is itself an extension of the ASCII character set (the first 128 characters). A character literal in @@ -450,7 +450,7 @@ #endif -- | The representation produced by GHC for conjuring up the kind of a --- 'TypeRep'. +-- 'TypeRep'. See Note [Representing TyCon kinds: KindRep] in TcTypeable. data KindRep = KindRepTyConApp TyCon [KindRep] | KindRepVar !KindBndr | KindRepApp KindRep KindRep diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,88 @@ + +-- We need to do some ugly hacks here because of GHC magic + +module Main (main) where + +import Control.Monad +import Data.List +import Data.Maybe +import Distribution.PackageDescription import Distribution.Simple -main = defaultMain +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Text +import System.Cmd +import System.FilePath +import System.Exit +import System.Directory + +main :: IO () +main = do let hooks = simpleUserHooks { + regHook = addPrimModule + $ regHook simpleUserHooks, + buildHook = build_primitive_sources + $ buildHook simpleUserHooks, + haddockHook = addPrimModuleForHaddock + $ build_primitive_sources + $ haddockHook simpleUserHooks } + defaultMainWithHooks hooks + +type Hook a = PackageDescription -> LocalBuildInfo -> UserHooks -> a -> IO () + +addPrimModule :: Hook a -> Hook a +addPrimModule f pd lbi uhs x = + do let -- I'm not sure which one of these we actually need to change. + -- It seems bad that there are two. + pd' = addPrimModuleToPD pd + lpd = addPrimModuleToPD (localPkgDescr lbi) + lbi' = lbi { localPkgDescr = lpd } + f pd' lbi' uhs x + +addPrimModuleForHaddock :: Hook a -> Hook a +addPrimModuleForHaddock f pd lbi uhs x = + do let pc = withPrograms lbi + pc' = userSpecifyArgs "haddock" ["GHC/Prim.hs"] pc + lbi' = lbi { withPrograms = pc' } + f pd lbi' uhs x + +addPrimModuleToPD :: PackageDescription -> PackageDescription +addPrimModuleToPD pd = + case library pd of + Just lib -> + let ems = fromJust (simpleParse "GHC.Prim") : exposedModules lib + lib' = lib { exposedModules = ems } + in pd { library = Just lib' } + Nothing -> + error "Expected a library, but none found" + +build_primitive_sources :: Hook a -> Hook a +build_primitive_sources f pd lbi uhs x + = do when (compilerFlavor (compiler lbi) == GHC) $ do + let genprimopcode = joinPath ["..", "..", "utils", + "genprimopcode", "genprimopcode"] + primops = joinPath ["..", "..", "compiler", "prelude", + "primops.txt"] + primhs = joinPath ["GHC", "Prim.hs"] + primopwrappers = joinPath ["GHC", "PrimopWrappers.hs"] + primhs_tmp = addExtension primhs "tmp" + primopwrappers_tmp = addExtension primopwrappers "tmp" + maybeExit $ system (genprimopcode ++ " --make-haskell-source < " + ++ primops ++ " > " ++ primhs_tmp) + maybeUpdateFile primhs_tmp primhs + maybeExit $ system (genprimopcode ++ " --make-haskell-wrappers < " + ++ primops ++ " > " ++ primopwrappers_tmp) + maybeUpdateFile primopwrappers_tmp primopwrappers + f pd lbi uhs x + +-- Replace a file only if the new version is different from the old. +-- This prevents make from doing unnecessary work after we run 'setup makefile' +maybeUpdateFile :: FilePath -> FilePath -> IO () +maybeUpdateFile source target = do + r <- rawSystem "cmp" ["-s" {-quiet-}, source, target] + case r of + ExitSuccess -> removeFile source + ExitFailure _ -> do exists <- doesFileExist target + when exists $ removeFile target + renameFile source target + diff --git a/cbits/atomic.c b/cbits/atomic.c --- a/cbits/atomic.c +++ b/cbits/atomic.c @@ -260,61 +260,103 @@ #endif // AtomicReadByteArrayOp_Int +// Implies a full memory barrier (see compiler/prelude/primops.txt.pp) +// __ATOMIC_SEQ_CST: Full barrier in both directions (hoisting and sinking +// of code) and synchronizes with acquire loads and release stores in +// all threads. +// +// When we lack C11 atomics support we emulate these using the old GCC __sync +// primitives which the GCC documentation claims "usually" implies a full +// barrier. extern StgWord hs_atomicread8(StgWord x); StgWord hs_atomicread8(StgWord x) { - return *(volatile StgWord8 *) x; +#if HAVE_C11_ATOMICS + return __atomic_load_n((StgWord8 *) x, __ATOMIC_SEQ_CST); +#else + return __sync_add_and_fetch((StgWord8 *) x, 0); +#endif } extern StgWord hs_atomicread16(StgWord x); StgWord hs_atomicread16(StgWord x) { - return *(volatile StgWord16 *) x; +#if HAVE_C11_ATOMICS + return __atomic_load_n((StgWord16 *) x, __ATOMIC_SEQ_CST); +#else + return __sync_add_and_fetch((StgWord16 *) x, 0); +#endif } extern StgWord hs_atomicread32(StgWord x); StgWord hs_atomicread32(StgWord x) { - return *(volatile StgWord32 *) x; +#if HAVE_C11_ATOMICS + return __atomic_load_n((StgWord32 *) x, __ATOMIC_SEQ_CST); +#else + return __sync_add_and_fetch((StgWord32 *) x, 0); +#endif } extern StgWord64 hs_atomicread64(StgWord x); StgWord64 hs_atomicread64(StgWord x) { - return *(volatile StgWord64 *) x; +#if HAVE_C11_ATOMICS + return __atomic_load_n((StgWord64 *) x, __ATOMIC_SEQ_CST); +#else + return __sync_add_and_fetch((StgWord64 *) x, 0); +#endif } // AtomicWriteByteArrayOp_Int +// Implies a full memory barrier (see compiler/prelude/primops.txt.pp) +// __ATOMIC_SEQ_CST: Full barrier (see hs_atomicread8 above). extern void hs_atomicwrite8(StgWord x, StgWord val); void hs_atomicwrite8(StgWord x, StgWord val) { - *(volatile StgWord8 *) x = (StgWord8) val; +#if HAVE_C11_ATOMICS + __atomic_store_n((StgWord8 *) x, (StgWord8) val, __ATOMIC_SEQ_CST); +#else + while (!__sync_bool_compare_and_swap((StgWord8 *) x, *(StgWord8 *) x, (StgWord8) val)); +#endif } extern void hs_atomicwrite16(StgWord x, StgWord val); void hs_atomicwrite16(StgWord x, StgWord val) { - *(volatile StgWord16 *) x = (StgWord16) val; +#if HAVE_C11_ATOMICS + __atomic_store_n((StgWord16 *) x, (StgWord16) val, __ATOMIC_SEQ_CST); +#else + while (!__sync_bool_compare_and_swap((StgWord16 *) x, *(StgWord16 *) x, (StgWord16) val)); +#endif } extern void hs_atomicwrite32(StgWord x, StgWord val); void hs_atomicwrite32(StgWord x, StgWord val) { - *(volatile StgWord32 *) x = (StgWord32) val; +#if HAVE_C11_ATOMICS + __atomic_store_n((StgWord32 *) x, (StgWord32) val, __ATOMIC_SEQ_CST); +#else + while (!__sync_bool_compare_and_swap((StgWord32 *) x, *(StgWord32 *) x, (StgWord32) val)); +#endif } extern void hs_atomicwrite64(StgWord x, StgWord64 val); void hs_atomicwrite64(StgWord x, StgWord64 val) { - *(volatile StgWord64 *) x = (StgWord64) val; +#if HAVE_C11_ATOMICS + __atomic_store_n((StgWord64 *) x, (StgWord64) val, __ATOMIC_SEQ_CST); +#else + while (!__sync_bool_compare_and_swap((StgWord64 *) x, *(StgWord64 *) x, (StgWord64) val)); +#endif } diff --git a/cbits/pdep.c b/cbits/pdep.c new file mode 100644 --- /dev/null +++ b/cbits/pdep.c @@ -0,0 +1,48 @@ +#include "Rts.h" +#include "MachDeps.h" + +extern StgWord64 hs_pdep64(StgWord64 src, StgWord64 mask); + +StgWord64 +hs_pdep64(StgWord64 src, StgWord64 mask) +{ + uint64_t result = 0; + + while (1) { + // Mask out all but the lowest bit + const uint64_t lowest = (-mask & mask); + + if (lowest == 0) { + break; + } + + const uint64_t lsb = (uint64_t)((int64_t)(src << 63) >> 63); + + result |= lsb & lowest; + mask &= ~lowest; + src >>= 1; + } + + return result; +} + +extern StgWord hs_pdep32(StgWord src, StgWord mask); +StgWord +hs_pdep32(StgWord src, StgWord mask) +{ + return hs_pdep64(src, mask); +} + +extern StgWord hs_pdep16(StgWord src, StgWord mask); +StgWord +hs_pdep16(StgWord src, StgWord mask) +{ + return hs_pdep64(src, mask); +} + +extern StgWord hs_pdep8(StgWord src, StgWord mask); +StgWord +hs_pdep8(StgWord src, StgWord mask) +{ + return hs_pdep64(src, mask); +} diff --git a/cbits/pext.c b/cbits/pext.c new file mode 100644 --- /dev/null +++ b/cbits/pext.c @@ -0,0 +1,44 @@ +#include "Rts.h" +#include "MachDeps.h" + +extern StgWord64 hs_pext64(StgWord64 src, StgWord64 mask); + +StgWord64 +hs_pext64(StgWord64 src, StgWord64 mask) +{ + uint64_t result = 0; + int offset = 0; + + for (int bit = 0; bit != sizeof(uint64_t) * 8; ++bit) { + const uint64_t src_bit = (src >> bit) & 1; + const uint64_t mask_bit = (mask >> bit) & 1; + + if (mask_bit) { + result |= (uint64_t)(src_bit) << offset; + ++offset; + } + } + + return result; +} + +extern StgWord hs_pext32(StgWord src, StgWord mask); +StgWord +hs_pext32(StgWord src, StgWord mask) +{ + return hs_pext64(src, mask); +} + +extern StgWord hs_pext16(StgWord src, StgWord mask); +StgWord +hs_pext16(StgWord src, StgWord mask) +{ + return hs_pext64(src, mask); +} + +extern StgWord hs_pext8(StgWord src, StgWord mask); +StgWord +hs_pext8(StgWord src, StgWord mask) +{ + return hs_pext64(src, mask); +} diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,13 @@ +## 0.5.2.0 + +- Shipped with GHC 8.4.1 + +- Added to `GHC.Prim`: + + compareByteArrays# :: ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int# + +- Don't allocate a thunk for each unpacked UTF-8 character in `unpackCStringUtf8#` + ## 0.5.1.1 *November 2017* - Shipped with GHC 8.2.2 diff --git a/ghc-prim.cabal b/ghc-prim.cabal --- a/ghc-prim.cabal +++ b/ghc-prim.cabal @@ -1,13 +1,13 @@ +cabal-version: 2.2 name: ghc-prim -version: 0.5.1.1 --- NOTE: Don't forget to update ./changelog.md -license: BSD3 +version: 0.5.2.0 + +license: BSD-3-Clause license-file: LICENSE category: GHC maintainer: libraries@haskell.org bug-reports: http://ghc.haskell.org/trac/ghc/newticket?component=libraries%20%28other%29&keywords=ghc-prim synopsis: GHC primitives -cabal-version: >=1.10 build-type: Simple description: This package contains the primitive types and operations supplied by GHC. @@ -19,10 +19,6 @@ location: http://git.haskell.org/ghc.git subdir: libraries/ghc-prim -flag include-ghc-prim - Description: Include GHC.Prim in exposed-modules - default: False - Library default-language: Haskell2010 other-extensions: @@ -49,7 +45,11 @@ GHC.PrimopWrappers GHC.Tuple GHC.Types + GHC.Prim + virtual-modules: + GHC.Prim + -- OS Specific if os(windows) -- Windows requires some extra libraries for linking because the RTS @@ -64,9 +64,6 @@ -- on Windows. Required because of mingw32. extra-libraries: user32, mingw32, mingwex - if flag(include-ghc-prim) - exposed-modules: GHC.Prim - c-sources: cbits/atomic.c cbits/bswap.c @@ -74,6 +71,8 @@ cbits/ctz.c cbits/debug.c cbits/longlong.c + cbits/pdep.c + cbits/pext.c cbits/popcnt.c cbits/word2float.c