[commit: ghc] master: Fix over-eager constant folding in bitInteger (efc844f)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/efc844f5b955385d69d8e20b80d38311083a6665/ghc

>---------------------------------------------------------------

commit efc844f5b955385d69d8e20b80d38311083a6665
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Mar 22 09:51:24 2018 +0000

    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.


>---------------------------------------------------------------

efc844f5b955385d69d8e20b80d38311083a6665
 compiler/prelude/PrelRules.hs                      | 52 +++++++++++++++-------
 testsuite/tests/simplCore/should_compile/T14959.hs |  5 +++
 testsuite/tests/simplCore/should_compile/all.T     |  1 +
 3 files changed, 42 insertions(+), 16 deletions(-)

diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 14e3f0f..9fa0db6 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -1152,7 +1152,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 }
@@ -1307,22 +1307,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
@@ -1337,6 +1323,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 0000000..692dfdd
--- /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 362541e..13511ee 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -296,3 +296,4 @@ test('T14152a', [extra_files(['T14152.hs']), pre_cmd('cp T14152.hs T14152a.hs'),
                 compile, ['-fno-exitification -ddump-simpl'])
 test('T13990', normal, compile, ['-dcore-lint -O'])
 test('T14650', normal, compile, ['-O2'])
+test('T14959', normal, compile, ['-O'])