diff --git a/libraries/base/GHC/Float.hs b/libraries/base/GHC/Float.hs index 012de47689e8..5d0c5622e316 100644 --- a/libraries/base/GHC/Float.hs +++ b/libraries/base/GHC/Float.hs @@ -1640,3 +1640,22 @@ foreign import prim "stg_doubleToWord64zh" "Word# -> Natural -> Double#" forall x. naturalToDouble# (NS x) = word2Double# x #-} + +-- We don't have word64ToFloat/word64ToDouble primops (#23908), only +-- word2Float/word2Double, so we can only perform these transformations when +-- word-size is 64-bit. +#if WORD_SIZE_IN_BITS == 64 +{-# RULES + +"Int64# -> Integer -> Float#" + forall x. integerToFloat# (integerFromInt64# x) = int2Float# (int64ToInt# x) + +"Int64# -> Integer -> Double#" + forall x. integerToDouble# (integerFromInt64# x) = int2Double# (int64ToInt# x) + +"Word64# -> Integer -> Float#" + forall x. integerToFloat# (integerFromWord64# x) = word2Float# (word64ToWord# x) + +"Word64# -> Integer -> Double#" + forall x. integerToDouble# (integerFromWord64# x) = word2Double# (word64ToWord# x) #-} +#endif diff --git a/testsuite/tests/numeric/should_compile/T23907.hs b/testsuite/tests/numeric/should_compile/T23907.hs new file mode 100644 index 000000000000..909516157a40 --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T23907.hs @@ -0,0 +1,67 @@ +module T23907 (loop) where + +import Data.Word +import Data.Bits + +{-# NOINLINE loop #-} +loop :: Int -> Double -> SMGen -> (Double, SMGen) +loop 0 !a !s = (a, s) +loop n !a !s = loop (n - 1) (a + b) t where (b, t) = nextDouble s + +mix64 :: Word64 -> Word64 +mix64 z0 = + -- MurmurHash3Mixer + let z1 = shiftXorMultiply 33 0xff51afd7ed558ccd z0 + z2 = shiftXorMultiply 33 0xc4ceb9fe1a85ec53 z1 + z3 = shiftXor 33 z2 + in z3 + +shiftXor :: Int -> Word64 -> Word64 +shiftXor n w = w `xor` (w `shiftR` n) + +shiftXorMultiply :: Int -> Word64 -> Word64 -> Word64 +shiftXorMultiply n k w = shiftXor n w * k + +nextWord64 :: SMGen -> (Word64, SMGen) +nextWord64 (SMGen seed gamma) = (mix64 seed', SMGen seed' gamma) + where + seed' = seed + gamma + +nextDouble :: SMGen -> (Double, SMGen) +nextDouble g = case nextWord64 g of + (w64, g') -> (fromIntegral (w64 `shiftR` 11) * doubleUlp, g') + +data SMGen = SMGen !Word64 !Word64 -- seed and gamma; gamma is odd + +mkSMGen :: Word64 -> SMGen +mkSMGen s = SMGen (mix64 s) (mixGamma (s + goldenGamma)) + +goldenGamma :: Word64 +goldenGamma = 0x9e3779b97f4a7c15 + +floatUlp :: Float +floatUlp = 1.0 / fromIntegral (1 `shiftL` 24 :: Word32) + +doubleUlp :: Double +doubleUlp = 1.0 / fromIntegral (1 `shiftL` 53 :: Word64) + +mix64variant13 :: Word64 -> Word64 +mix64variant13 z0 = + -- Better Bit Mixing - Improving on MurmurHash3's 64-bit Finalizer + -- http://zimbry.blogspot.fi/2011/09/better-bit-mixing-improving-on.html + -- + -- Stafford's Mix13 + let z1 = shiftXorMultiply 30 0xbf58476d1ce4e5b9 z0 -- MurmurHash3 mix constants + z2 = shiftXorMultiply 27 0x94d049bb133111eb z1 + z3 = shiftXor 31 z2 + in z3 + +mixGamma :: Word64 -> Word64 +mixGamma z0 = + let z1 = mix64variant13 z0 .|. 1 -- force to be odd + n = popCount (z1 `xor` (z1 `shiftR` 1)) + -- see: http://www.pcg-random.org/posts/bugs-in-splitmix.html + -- let's trust the text of the paper, not the code. + in if n >= 24 + then z1 + else z1 `xor` 0xaaaaaaaaaaaaaaaa diff --git a/testsuite/tests/numeric/should_compile/T23907.stderr b/testsuite/tests/numeric/should_compile/T23907.stderr new file mode 100644 index 000000000000..946c4bb6d89b --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T23907.stderr @@ -0,0 +1,57 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 90, types: 62, coercions: 0, joins: 0/3} + +$WSMGen + = \ conrep conrep1 -> + case conrep of { W64# unbx -> + case conrep1 of { W64# unbx1 -> SMGen unbx unbx1 } + } + +Rec { +$wloop + = \ ww ww1 ww2 ww3 -> + case ww of ds { + __DEFAULT -> + let { seed' = plusWord64# ww2 ww3 } in + let { + x# + = timesWord64# + (xor64# seed' (uncheckedShiftRL64# seed' 33#)) + 18397679294719823053#Word64 } in + let { + x#1 + = timesWord64# + (xor64# x# (uncheckedShiftRL64# x# 33#)) + 14181476777654086739#Word64 } in + $wloop + (-# ds 1#) + (+## + ww1 + (*## + (word2Double# + (word64ToWord# + (uncheckedShiftRL64# + (xor64# x#1 (uncheckedShiftRL64# x#1 33#)) 11#))) + 1.1102230246251565e-16##)) + seed' + ww3; + 0# -> (# ww1, ww2, ww3 #) + } +end Rec } + +loop + = \ ds a s -> + case ds of { I# ww -> + case a of { D# ww1 -> + case s of { SMGen ww2 ww3 -> + case $wloop ww ww1 ww2 ww3 of { (# ww4, ww5, ww6 #) -> + (D# ww4, SMGen ww5 ww6) + } + } + } + } + + + diff --git a/testsuite/tests/numeric/should_compile/all.T b/testsuite/tests/numeric/should_compile/all.T index 6f55e3b2fd27..8410dcddcdc7 100644 --- a/testsuite/tests/numeric/should_compile/all.T +++ b/testsuite/tests/numeric/should_compile/all.T @@ -20,3 +20,4 @@ test('T20448', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-b test('T19641', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds -dsuppress-uniques']) test('T15547', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds -dsuppress-uniques']) test('T23019', normal, compile, ['-O']) +test('T23907', [ when(wordsize(32), expect_broken(23908))], compile, ['-ddump-simpl -O2 -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])