diff options
| author | Ben Gamari <bgamari.foss@gmail.com> | 2017-09-26 08:01:44 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-09-26 11:59:53 -0400 |
| commit | 57372a7cc958ebfa4ac64fc800e00baacfc3cf5c (patch) | |
| tree | 55a199e3d994dc38f959ca98ac881e3a4ed6a74d | |
| parent | 1d1b991ee15e0428be16d1bfad7087051e000bdc (diff) | |
| download | haskell-57372a7cc958ebfa4ac64fc800e00baacfc3cf5c.tar.gz | |
PrelRules: Handle Int left shifts of more than word-size bits
This should result in zero. Failing to realize this caused us to try
to constant-fold via the normal path, resulting in #14272.
Test Plan: Validate with coming tests
Reviewers: austin, simonpj
Subscribers: simonpj, rwbarton, thomie, hvr
GHC Trac Issues: #14272
Differential Revision: https://phabricator.haskell.org/D4025
| -rw-r--r-- | compiler/prelude/PrelRules.hs | 22 |
1 files changed, 14 insertions, 8 deletions
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index babfe4bedf..810fd2ba60 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -122,11 +122,11 @@ primOpRules nm NotIOp = mkPrimOpRule nm 1 [ unaryLit complementOp , inversePrimOp NotIOp ] primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp , inversePrimOp IntNegOp ] -primOpRules nm ISllOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL) +primOpRules nm ISllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) , rightIdentityDynFlags zeroi ] -primOpRules nm ISraOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR) +primOpRules nm ISraOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR) , rightIdentityDynFlags zeroi ] -primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ binaryLit (intOp2' shiftRightLogical) +primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical , rightIdentityDynFlags zeroi ] -- Word operations @@ -157,8 +157,8 @@ primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) , equalArgs >> retLit zerow ] primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp , inversePrimOp NotOp ] -primOpRules nm SllOp = mkPrimOpRule nm 2 [ wordShiftRule (const Bits.shiftL) ] -primOpRules nm SrlOp = mkPrimOpRule nm 2 [ wordShiftRule shiftRightLogical ] +primOpRules nm SllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ] +primOpRules nm SrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ] -- coercions primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit @@ -419,10 +419,10 @@ wordOp2 op dflags (MachWord w1) (MachWord w2) = wordResult dflags (fromInteger w1 `op` fromInteger w2) wordOp2 _ _ _ _ = Nothing -- Could find LitLit -wordShiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr +shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr -- Shifts take an Int; hence third arg of op is Int -- See Note [Guarding against silly shifts] -wordShiftRule shift_op +shiftRule shift_op = do { dflags <- getDynFlags ; [e1, Lit (MachInt shift_len)] <- getArgs ; case e1 of @@ -431,10 +431,16 @@ wordShiftRule shift_op | shift_len < 0 || wordSizeInBits dflags < shift_len -> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy ("Bad shift length" ++ show shift_len)) + + -- Do the shift at type Integer, but shift length is Int + Lit (MachInt x) + -> let op = shift_op dflags + in liftMaybe $ intResult dflags (x `op` fromInteger shift_len) + Lit (MachWord x) -> let op = shift_op dflags in liftMaybe $ wordResult dflags (x `op` fromInteger shift_len) - -- Do the shift at type Integer, but shift length is Int + _ -> mzero } wordSizeInBits :: DynFlags -> Integer |