[commit: ghc] master: shouldInlinePrimOp: Fix Int overflow (6f862df)
git at git.haskell.org
git at git.haskell.org
Tue Aug 12 20:13:40 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/6f862dfae20afdcd671133f3534b1bf5c25bbd9b/ghc
>---------------------------------------------------------------
commit 6f862dfae20afdcd671133f3534b1bf5c25bbd9b
Author: Johan Tibell <johan.tibell at gmail.com>
Date: Thu Aug 7 17:07:00 2014 +0200
shouldInlinePrimOp: Fix Int overflow
There were two overflow issues in shouldInlinePrimOp. The first one is
due to a negative CmmInt literal being created if the array size was
given as larger than 2^63-1 (on a 64-bit platform.) This meant that
large array sizes could compare as being smaller than
maxInlineAllocSize.
The second issue is that we casted the Integer to an Int in the
comparison, which again meant that large array sizes could compare as
being smaller than maxInlineAllocSize.
The attempt to allocate a large array inline then caused a segfault.
Fixes #9416.
>---------------------------------------------------------------
6f862dfae20afdcd671133f3534b1bf5c25bbd9b
compiler/cmm/SMRep.lhs | 7 +++--
compiler/codeGen/StgCmmPrim.hs | 60 ++++++++++++++++++++++++++----------------
2 files changed, 43 insertions(+), 24 deletions(-)
diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs
index b23bcc1..9fab530 100644
--- a/compiler/cmm/SMRep.lhs
+++ b/compiler/cmm/SMRep.lhs
@@ -78,8 +78,11 @@ roundUpToWords :: DynFlags -> ByteOff -> ByteOff
roundUpToWords dflags n =
(n + (wORD_SIZE dflags - 1)) .&. (complement (wORD_SIZE dflags - 1))
-wordsToBytes :: DynFlags -> WordOff -> ByteOff
-wordsToBytes dflags n = wORD_SIZE dflags * n
+wordsToBytes :: Num a => DynFlags -> a -> a
+wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n
+{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-}
+{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-}
+{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-}
bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff
bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 0d67cdb..2fa1b85 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -43,6 +43,7 @@ import FastString
import Outputable
import Util
+import Data.Bits ((.&.), bit)
import Control.Monad (liftM, when)
------------------------------------------------------------------------
@@ -121,6 +122,21 @@ cgOpApp (StgPrimCallOp primcall) args _res_ty
; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
+-- | Interpret the argument as an unsigned value, assuming the value
+-- is given in two-complement form in the given width.
+--
+-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615.
+--
+-- This function is used to work around the fact that many array
+-- primops take Int# arguments, but we interpret them as unsigned
+-- quantities in the code gen. This means that we have to be careful
+-- every time we work on e.g. a CmmInt literal that corresponds to the
+-- array size, as it might contain a negative Integer value if the
+-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#
+-- literal.
+asUnsigned :: Width -> Integer -> Integer
+asUnsigned w n = n .&. (bit (widthInBits w) - 1)
+
-- | Decide whether an out-of-line primop should be replaced by an
-- inline implementation. This might happen e.g. if there's enough
-- static information, such as statically know arguments, to emit a
@@ -135,12 +151,12 @@ shouldInlinePrimOp :: DynFlags
-> [CmmExpr] -- ^ The primop arguments
-> Maybe ([LocalReg] -> FCode ())
-shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n _))]
- | fromInteger n <= maxInlineAllocSize dflags =
+shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n w))]
+ | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) =
Just $ \ [res] -> doNewByteArrayOp res (fromInteger n)
-shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n _)), init]
- | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n w)), init]
+ | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
Just $ \ [res] ->
doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel
[ (mkIntExpr dflags (fromInteger n),
@@ -166,24 +182,24 @@ shouldInlinePrimOp _ CopyMutableArrayArrayOp
[src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)
-shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n _))]
- | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+ | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n)
-shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n _))]
- | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+ | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
-shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n _))]
- | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+ | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_infoLabel res src src_off (fromInteger n)
-shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n _))]
- | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+ | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
-shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n _)), init]
- | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n w)), init]
+ | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
Just $ \ [res] ->
doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel
[ (mkIntExpr dflags (fromInteger n),
@@ -199,20 +215,20 @@ shouldInlinePrimOp _ CopySmallMutableArrayOp
[src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
Just $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)
-shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n _))]
- | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+ | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n)
-shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n _))]
- | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+ | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
-shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n _))]
- | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+ | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_infoLabel res src src_off (fromInteger n)
-shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n _))]
- | wordsToBytes dflags (fromInteger n) <= maxInlineAllocSize dflags =
+shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+ | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
shouldInlinePrimOp dflags primop args
More information about the ghc-commits
mailing list