From 3c6a0578b5a05ce1e8c0089975fdff55aa8747fd Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones <simonpj@microsoft.com> Date: Thu, 22 Mar 2018 09:51:24 +0000 Subject: [PATCH] Fix over-eager constant folding in bitInteger The RULE for bitInteger was trying to constant-fold bitInteger 9223372036854775807# which meant constructing a gigantic Integer at compile time. Very bad idea! Easily fixed. Fixes Trac #14959, #14962. (cherry picked from commit efc844f5b955385d69d8e20b80d38311083a6665) --- compiler/prelude/PrelRules.hs | 52 +++++++++++++------ .../tests/simplCore/should_compile/T14959.hs | 5 ++ .../tests/simplCore/should_compile/all.T | 1 + 3 files changed, 42 insertions(+), 16 deletions(-) create mode 100644 testsuite/tests/simplCore/should_compile/T14959.hs diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index b47563770cd1..867c12fb6f6d 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -1090,7 +1090,7 @@ builtinIntegerRules = ru_try = match_Integer_unop op } rule_bitInteger str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_IntToInteger_unop (bit . fromIntegral) } + ru_try = match_bitInteger } rule_binop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_binop op } @@ -1245,22 +1245,8 @@ match_Word64ToInteger _ id_unf id [xl] match_Word64ToInteger _ _ _ _ = Nothing ------------------------------------------------- -match_Integer_convert :: Num a - => (DynFlags -> a -> Expr CoreBndr) - -> RuleFun -match_Integer_convert convert dflags id_unf _ [xl] - | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - = Just (convert dflags (fromInteger x)) -match_Integer_convert _ _ _ _ _ = Nothing - -match_Integer_unop :: (Integer -> Integer) -> RuleFun -match_Integer_unop unop _ id_unf _ [xl] - | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl - = Just (Lit (LitInteger (unop x) i)) -match_Integer_unop _ _ _ _ _ = Nothing - {- Note [Rewriting bitInteger] - +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For most types the bitInteger operation can be implemented in terms of shifts. The integer-gmp package, however, can do substantially better than this if allowed to provide its own implementation. However, in so doing it previously lost @@ -1275,6 +1261,40 @@ should expect some funniness given that they will have at very least ignored a warning in this case. -} +match_bitInteger :: RuleFun +-- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer +match_bitInteger dflags id_unf fn [arg] + | Just (MachInt x) <- exprIsLiteral_maybe id_unf arg + , x >= 0 + , x <= (wordSizeInBits dflags - 1) + -- Make sure x is small enough to yield a decently small iteger + -- Attempting to construct the Integer for + -- (bitInteger 9223372036854775807#) + -- would be a bad idea (Trac #14959) + , let x_int = fromIntegral x :: Int + = case splitFunTy_maybe (idType fn) of + Just (_, integerTy) + -> Just (Lit (LitInteger (bit x_int) integerTy)) + _ -> panic "match_IntToInteger_unop: Id has the wrong type" + +match_bitInteger _ _ _ _ = Nothing + + +------------------------------------------------- +match_Integer_convert :: Num a + => (DynFlags -> a -> Expr CoreBndr) + -> RuleFun +match_Integer_convert convert dflags id_unf _ [xl] + | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl + = Just (convert dflags (fromInteger x)) +match_Integer_convert _ _ _ _ _ = Nothing + +match_Integer_unop :: (Integer -> Integer) -> RuleFun +match_Integer_unop unop _ id_unf _ [xl] + | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl + = Just (Lit (LitInteger (unop x) i)) +match_Integer_unop _ _ _ _ _ = Nothing + match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun match_IntToInteger_unop unop _ id_unf fn [xl] | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl diff --git a/testsuite/tests/simplCore/should_compile/T14959.hs b/testsuite/tests/simplCore/should_compile/T14959.hs new file mode 100644 index 000000000000..692dfdd2ea87 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T14959.hs @@ -0,0 +1,5 @@ +module T14959 where + +import Data.Bits (setBit) + +f = foldl setBit 0 [x | (x,_) <- zip [0..] [1]] :: Integer diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index c9af682d8819..e68f49cfb658 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -294,3 +294,4 @@ test('T14152', [ only_ways(['optasm']), check_errmsg(r'dead code') ], compile, [ test('T14152a', [ only_ways(['optasm']), check_errmsg(r'dead code') ], compile, ['-fno-exitification -ddump-simpl']) test('T13990', normal, compile, ['-dcore-lint -O']) test('T14650', normal, compile, ['-O2']) +test('T14959', normal, compile, ['-O']) -- GitLab