Fix constant-folding for Integer shifts

In this patch
    commit 869f69fd4a78371c221e6d9abd69a71440a4679a
    Author: Simon Peyton Jones <simonpj@microsoft.com>
    Date:   Wed Dec 11 18:19:34 2013 +0000

    Guarding against silly shifts

we deal with silly shifts like (Sll 1 9223372036854775807).  But
I only dealt with primops that Int# and Word#.

Alas, the same problem affects shifts of Integer, as Trac #15673
showed.  Fortunately, the problem is easy to fix.

3 files changed, 44 insertions, 9 deletions

diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 80cfa20ba3..e94490007f 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -463,7 +463,10 @@ wordOpC2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) =
 wordOpC2 _ _ _ _ = Nothing  -- Could find LitLit
 
 shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
-                 -- Shifts take an Int; hence third arg of op is Int
+-- Shifts take an Int; hence third arg of op is Int
+-- Used for shift primops
+--    ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word#
+--    SllOp, SrlOp           :: Word# -> Int# -> Word#
 -- See Note [Guarding against silly shifts]
 shiftRule shift_op
   = do { dflags <- getDynFlags
@@ -690,7 +693,7 @@ Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->
                 } } } }
 
 Note the massive shift on line "!!!!".  It can't happen, because we've checked
-that w < 64, but the optimiser didn't spot that. We DO NO want to constant-fold this!
+that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this!
 Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we
 can't constant fold it, but if it gets to the assember we get
      Error: operand type mismatch for `shl'
@@ -698,6 +701,25 @@ can't constant fold it, but if it gets to the assember we get
 So the best thing to do is to rewrite the shift with a call to error,
 when the second arg is stupid.
 
+There are two cases:
+
+- Shifting fixed-width things: the primops ISll, Sll, etc
+  These are handled by shiftRule.
+
+  We are happy to shift by any amount up to wordSize but no more.
+
+- Shifting Integers: the function shiftLInteger, shiftRInteger
+  from the 'integer' library.   These are handled by rule_shift_op,
+  and match_Integer_shift_op.
+
+  Here we could in principle shift by any amount, but we arbitary
+  limit the shift to 4 bits; in particualr we do not want shift by a
+  huge amount, which can happen in code like that above.
+
+The two cases are more different in their code paths that is comfortable,
+but that is only a historical accident.
+
+
 ************************************************************************
 *                                                                      *
 \subsection{Vaguely generic functions}
@@ -1215,8 +1237,8 @@ builtinIntegerRules =
   rule_binop          "orInteger"           orIntegerName           (.|.),
   rule_binop          "xorInteger"          xorIntegerName          xor,
   rule_unop           "complementInteger"   complementIntegerName   complement,
-  rule_Int_binop      "shiftLInteger"       shiftLIntegerName       shiftL,
-  rule_Int_binop      "shiftRInteger"       shiftRIntegerName       shiftR,
+  rule_shift_op       "shiftLInteger"       shiftLIntegerName       shiftL,
+  rule_shift_op       "shiftRInteger"       shiftRIntegerName       shiftR,
   rule_bitInteger     "bitInteger"          bitIntegerName,
   -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs
   rule_divop_one      "quotInteger"         quotIntegerName         quot,
@@ -1266,9 +1288,9 @@ builtinIntegerRules =
           rule_divop_one str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_divop_one op }
-          rule_Int_binop str name op
+          rule_shift_op str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
-                           ru_try = match_Integer_Int_binop op }
+                           ru_try = match_Integer_shift_op op }
           rule_binop_Prim str name op
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_Integer_binop_Prim op }
@@ -1569,12 +1591,18 @@ match_Integer_divop_one divop _ id_unf _ [xl,yl]
   = Just (Lit (mkLitInteger (x `divop` y) i))
 match_Integer_divop_one _ _ _ _ _ = Nothing
 
-match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
-match_Integer_Int_binop binop _ id_unf _ [xl,yl]
+match_Integer_shift_op :: (Integer -> Int -> Integer) -> RuleFun
+-- Used for shiftLInteger, shiftRInteger :: Integer -> Int# -> Integer
+-- See Note [Guarding against silly shifts]
+match_Integer_shift_op binop _ id_unf _ [xl,yl]
   | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
   , Just (LitNumber LitNumInt y _)     <- exprIsLiteral_maybe id_unf yl
+  , y >= 0
+  , y <= 4   -- Restrict constant-folding of shifts on Integers, somewhat
+             -- arbitrary.  We can get huge shifts in inaccessible code
+             -- (Trac #15673)
   = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i))
-match_Integer_Int_binop _ _ _ _ _ = Nothing
+match_Integer_shift_op _ _ _ _ _ = Nothing
 
 match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
 match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
diff --git a/testsuite/tests/simplCore/should_compile/T15673.hs b/testsuite/tests/simplCore/should_compile/T15673.hs
new file mode 100644
index 0000000000..30baa37d3d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T15673.hs
@@ -0,0 +1,6 @@
+module T14573 where

+

+import Data.Bits (shift)

+

+badOne :: [Int] -> Integer     -- replace Integer by Int and all is good!

+badOne is = sum $ zipWith (\n _->shift 1 n) [0..] is

diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index d572d04e15..391994e3df 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -326,3 +326,4 @@ test('T15631',
      normal,
      run_command,
      ['$MAKE -s --no-print-directory T15631'])
+test('T15673', normal, compile, ['-O'])