[commit: ghc] master: Fix constant-folding for Integer shifts (d25fa45)
git at git.haskell.org
git at git.haskell.org
Wed Sep 26 03:42:23 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/d25fa45e377253cfbe26e410075dda9d58bb869c/ghc
>---------------------------------------------------------------
commit d25fa45e377253cfbe26e410075dda9d58bb869c
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Wed Sep 26 04:29:19 2018 +0100
Fix constant-folding for Integer shifts
In this patch
commit 869f69fd4a78371c221e6d9abd69a71440a4679a
Author: Simon Peyton Jones <simonpj at 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.
>---------------------------------------------------------------
d25fa45e377253cfbe26e410075dda9d58bb869c
compiler/prelude/PrelRules.hs | 46 +++++++++++++++++-----
testsuite/tests/simplCore/should_compile/T15673.hs | 6 +++
testsuite/tests/simplCore/should_compile/all.T | 1 +
3 files changed, 44 insertions(+), 9 deletions(-)
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 80cfa20..e944900 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 0000000..30baa37
--- /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 d572d04..391994e 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'])
More information about the ghc-commits
mailing list