diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2023-02-21 16:38:23 +0000 |
|---|---|---|
| committer | Matthew Pickering <matthewtpickering@gmail.com> | 2023-02-21 16:40:57 +0000 |
| commit | 3c9b89adb0c953de02d301623b13541a9fe5feda (patch) | |
| tree | 977993c20b31d20e86b6c9f99a2e0addffbb5092 | |
| parent | a203ad854ffee802e6bf0aca26e6c9a99bec3865 (diff) | |
| download | haskell-wip/fix-constant-decodeDouble.tar.gz | |
constant folding: Correct type of decodeDouble_Int64 rulewip/fix-constant-decodeDouble
The first argument is Int64# unconditionally, so we better produce
something of that type. This fixes a core lint error found in the ad
package.
Fixes #23019
| -rw-r--r-- | compiler/GHC/Core/Opt/ConstantFold.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/numeric/should_compile/T23019.hs | 21 | ||||
| -rw-r--r-- | testsuite/tests/numeric/should_compile/all.T | 1 |
3 files changed, 23 insertions, 5 deletions
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 7ace3124e9..2e5c6aabf6 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -1110,14 +1110,10 @@ doubleOp2 _ _ _ _ = Nothing -------------------------- doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e))) - = Just $ mkCoreUnboxedTuple [ Lit (mkLitINT64 (toInteger m)) + = Just $ mkCoreUnboxedTuple [ Lit (mkLitInt64Wrap (toInteger m)) , mkIntVal platform (toInteger e) ] where platform = roPlatform env - mkLitINT64 | platformWordSizeInBits platform < 64 - = mkLitInt64Wrap - | otherwise - = mkLitIntWrap platform doubleDecodeOp _ _ = Nothing diff --git a/testsuite/tests/numeric/should_compile/T23019.hs b/testsuite/tests/numeric/should_compile/T23019.hs new file mode 100644 index 0000000000..6b3e3d92ba --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T23019.hs @@ -0,0 +1,21 @@ +module T23019 + ( + eexponent + ) where + +-- spine lazy, value strict list of doubles +data List + = Nil + | {-# UNPACK #-} !Double :! List + +infixr 5 :! + +newtype TowerDouble = Tower { getTower :: List } + +primal :: TowerDouble -> Double +primal (Tower (x:!_)) = x +primal _ = 0 + +eexponent :: TowerDouble -> Int +eexponent = exponent . primal + diff --git a/testsuite/tests/numeric/should_compile/all.T b/testsuite/tests/numeric/should_compile/all.T index 0c22811cc8..6f55e3b2fd 100644 --- a/testsuite/tests/numeric/should_compile/all.T +++ b/testsuite/tests/numeric/should_compile/all.T @@ -19,3 +19,4 @@ test('T20347', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-b test('T20448', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds -dsuppress-uniques']) 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']) |