From 831a35dd00faff195cf938659c2dd736192b865f Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Fri, 24 Apr 2009 12:47:54 +0000 Subject: [PATCH] Require a bang pattern when unlifted types are where/let bound; #3182 For now we only get a warning, rather than an error, because the alex and happy templates don't follow the new rules yet. --- compiler/basicTypes/Unique.lhs | 6 +++--- compiler/cmm/CmmLex.x | 2 +- compiler/cmm/CmmParse.y | 2 +- compiler/ghci/ByteCodeAsm.lhs | 4 ++-- compiler/ghci/ByteCodeLink.lhs | 6 +++--- compiler/main/ParsePkgConf.y | 2 +- compiler/parser/HaddockLex.x | 2 +- compiler/parser/HaddockParse.y | 2 +- compiler/parser/Lexer.x | 2 +- compiler/parser/Parser.y.pp | 2 +- compiler/parser/ParserCore.y | 2 +- compiler/profiling/CostCentre.lhs | 4 ++-- compiler/typecheck/TcBinds.lhs | 10 ++++++++++ compiler/utils/Encoding.hs | 16 ++++++++-------- compiler/utils/FastMutInt.lhs | 4 ++-- compiler/utils/FastString.lhs | 6 +++--- compiler/utils/Pretty.lhs | 8 ++++---- compiler/utils/StringBuffer.lhs | 2 +- compiler/utils/UniqFM.lhs | 4 ++-- utils/hpc/HpcParser.y | 2 +- 20 files changed, 49 insertions(+), 39 deletions(-) diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs index 202ae9e..aecd372 100644 --- a/compiler/basicTypes/Unique.lhs +++ b/compiler/basicTypes/Unique.lhs @@ -134,8 +134,8 @@ newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u mkUnique c i = MkUnique (tag `bitOrFastInt` bits) where - tag = fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24) - bits = iUnbox i `bitAndFastInt` _ILIT(16777215){-``0x00ffffff''-} + !tag = fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24) + !bits = iUnbox i `bitAndFastInt` _ILIT(16777215){-``0x00ffffff''-} unpkUnique (MkUnique u) = let @@ -266,7 +266,7 @@ iToBase62 n_ #if defined(__GLASGOW_HASKELL__) --then FastInt == Int# chooseChar62 n = C# (indexCharOffAddr# chars62 n) - chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# + !chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# #else --Haskell98 arrays are portable chooseChar62 n = (!) chars62 n diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x index da5e4df..7724565 100644 --- a/compiler/cmm/CmmLex.x +++ b/compiler/cmm/CmmLex.x @@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- { -{-# OPTIONS -w #-} +{-# OPTIONS -Wwarn #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 1030895..9df499e 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -7,7 +7,7 @@ ----------------------------------------------------------------------------- { -{-# OPTIONS -w #-} +{-# OPTIONS -Wwarn #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 24fda15..de85a6b 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -154,10 +154,10 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) insns_arr | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO" | otherwise = mkInstrArray n_insns asm_insns - insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr + !insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr bitmap_arr = mkBitmapArray bsize bitmap - bitmap_barr = case bitmap_arr of UArray _lo _hi _n barr -> barr + !bitmap_barr = case bitmap_arr of UArray _lo _hi _n barr -> barr let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index fabd5d1..5e39fde 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -120,13 +120,13 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS) ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs let - ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr + !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr literals_arr = listArray (0, n_literals-1) linked_literals :: UArray Int Word - literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr + !literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr - (I# arity#) = arity + !(I# arity#) = arity newBCO insns_barr literals_barr ptrs_parr arity# bitmap diff --git a/compiler/main/ParsePkgConf.y b/compiler/main/ParsePkgConf.y index 9cf6d04..1e24ab4 100644 --- a/compiler/main/ParsePkgConf.y +++ b/compiler/main/ParsePkgConf.y @@ -1,5 +1,5 @@ { -{-# OPTIONS -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-missing-signatures -fno-warn-incomplete-patterns #-} +{-# OPTIONS -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-missing-signatures -fno-warn-incomplete-patterns -Wwarn #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See diff --git a/compiler/parser/HaddockLex.x b/compiler/parser/HaddockLex.x index 7ed365f..6399bee 100644 --- a/compiler/parser/HaddockLex.x +++ b/compiler/parser/HaddockLex.x @@ -7,7 +7,7 @@ -- { -{-# OPTIONS -w #-} +{-# OPTIONS -Wwarn #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See diff --git a/compiler/parser/HaddockParse.y b/compiler/parser/HaddockParse.y index d46223d..ca2675f 100644 --- a/compiler/parser/HaddockParse.y +++ b/compiler/parser/HaddockParse.y @@ -1,5 +1,5 @@ { -{-# OPTIONS -w #-} +{-# OPTIONS -Wwarn #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index aa2703e..edfbecd 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -32,7 +32,7 @@ -- qualified varids. { -{-# OPTIONS -w #-} +{-# OPTIONS -Wwarn #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 6839286..d5314e4 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -8,7 +8,7 @@ -- --------------------------------------------------------------------------- { -{-# OPTIONS -w #-} +{-# OPTIONS -Wwarn #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 6d302fb..49f70e4 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -1,5 +1,5 @@ { -{-# OPTIONS -w #-} +{-# OPTIONS -Wwarn #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index dc93a1f..aff29d8 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -300,8 +300,8 @@ cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1}) cmpCostCentre other_1 other_2 = let - tag1 = tag_CC other_1 - tag2 = tag_CC other_2 + !tag1 = tag_CC other_1 + !tag2 = tag_CC other_2 in if tag1 <# tag2 then LT else GT where diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 59ae266..59cd315 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -475,6 +475,11 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos (strictBindErr "Recursive" unlifted mbind) ; checkTc (isSingletonBag mbind) (strictBindErr "Multiple" unlifted mbind) + -- This should be a checkTc, not a warnTc, but as of GHC 6.11 + -- the versions of alex and happy available have non-conforming + -- templates, so the GHC build fails if it's an error: + ; warnTc (not bang_pat) + (unliftedMustBeBang mbind) ; mapM_ check_sig infos ; return True } | otherwise @@ -486,6 +491,11 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos (badStrictSig unlifted sig) check_sig _ = return () +unliftedMustBeBang :: LHsBindsLR Var Var -> SDoc +unliftedMustBeBang mbind + = hang (text "Bindings containing unlifted types must use an outermost bang pattern:") + 4 (pprLHsBinds mbind) + strictBindErr :: String -> Bool -> LHsBindsLR Var Var -> SDoc strictBindErr flavour unlifted mbind = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) diff --git a/compiler/utils/Encoding.hs b/compiler/utils/Encoding.hs index 35df004..e14f1e7 100644 --- a/compiler/utils/Encoding.hs +++ b/compiler/utils/Encoding.hs @@ -50,21 +50,21 @@ import GHC.Base {-# INLINE utf8DecodeChar# #-} utf8DecodeChar# :: Addr# -> (# Char#, Addr# #) utf8DecodeChar# a# = - let ch0 = word2Int# (indexWord8OffAddr# a# 0#) in + let !ch0 = word2Int# (indexWord8OffAddr# a# 0#) in case () of _ | ch0 <=# 0x7F# -> (# chr# ch0, a# `plusAddr#` 1# #) | ch0 >=# 0xC0# && ch0 <=# 0xDF# -> - let ch1 = word2Int# (indexWord8OffAddr# a# 1#) in + let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in if ch1 <# 0x80# || ch1 >=# 0xC0# then fail 1# else (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +# (ch1 -# 0x80#)), a# `plusAddr#` 2# #) | ch0 >=# 0xE0# && ch0 <=# 0xEF# -> - let ch1 = word2Int# (indexWord8OffAddr# a# 1#) in + let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in if ch1 <# 0x80# || ch1 >=# 0xC0# then fail 1# else - let ch2 = word2Int# (indexWord8OffAddr# a# 2#) in + let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in if ch2 <# 0x80# || ch2 >=# 0xC0# then fail 2# else (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +# ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +# @@ -72,11 +72,11 @@ utf8DecodeChar# a# = a# `plusAddr#` 3# #) | ch0 >=# 0xF0# && ch0 <=# 0xF8# -> - let ch1 = word2Int# (indexWord8OffAddr# a# 1#) in + let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in if ch1 <# 0x80# || ch1 >=# 0xC0# then fail 1# else - let ch2 = word2Int# (indexWord8OffAddr# a# 2#) in + let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in if ch2 <# 0x80# || ch2 >=# 0xC0# then fail 2# else - let ch3 = word2Int# (indexWord8OffAddr# a# 3#) in + let !ch3 = word2Int# (indexWord8OffAddr# a# 3#) in if ch3 <# 0x80# || ch3 >=# 0xC0# then fail 3# else (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +# ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +# @@ -116,7 +116,7 @@ STRICT2(utf8DecodeString) utf8DecodeString (Ptr a#) (I# len#) = unpack a# where - end# = addr2Int# (a# `plusAddr#` len#) + !end# = addr2Int# (a# `plusAddr#` len#) unpack p# | addr2Int# p# >=# end# = return [] diff --git a/compiler/utils/FastMutInt.lhs b/compiler/utils/FastMutInt.lhs index e8ea58c..c29b568 100644 --- a/compiler/utils/FastMutInt.lhs +++ b/compiler/utils/FastMutInt.lhs @@ -50,7 +50,7 @@ data FastMutInt = FastMutInt (MutableByteArray# RealWorld) newFastMutInt = IO $ \s -> case newByteArray# size s of { (# s, arr #) -> (# s, FastMutInt arr #) } - where I# size = SIZEOF_HSINT + where !(I# size) = SIZEOF_HSINT readFastMutInt (FastMutInt arr) = IO $ \s -> case readIntArray# arr 0# s of { (# s, i #) -> @@ -65,7 +65,7 @@ data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld) newFastMutPtr = IO $ \s -> case newByteArray# size s of { (# s, arr #) -> (# s, FastMutPtr arr #) } - where I# size = SIZEOF_VOID_P + where !(I# size) = SIZEOF_VOID_P readFastMutPtr (FastMutPtr arr) = IO $ \s -> case readAddrArray# arr 0# s of { (# s, i #) -> diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index cf4e37d..62bc5d5 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -380,9 +380,9 @@ hashStr (Ptr a#) (I# len#) = loop 0# 0# where loop h n | n GHC.Exts.==# len# = I# h | otherwise = loop h2 (n GHC.Exts.+# 1#) - where c = ord# (indexCharOffAddr# a# n) - h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` - hASH_TBL_SIZE# + where !c = ord# (indexCharOffAddr# a# n) + !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` + hASH_TBL_SIZE# -- ----------------------------------------------------------------------------- -- Operations diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index 3e08814..47d4b1e 100644 --- a/compiler/utils/Pretty.lhs +++ b/compiler/utils/Pretty.lhs @@ -615,7 +615,7 @@ aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k -# k1) q) aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest where - k1 = k -# sl + !k1 = k -# sl rest = case p of Empty -> nilAboveNest g k1 q _ -> aboveNest p g k1 q @@ -775,8 +775,8 @@ fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys `mkUnion` nilAboveNest False k (fill g (y:ys)) where - k1 | g = k -# _ILIT(1) - | otherwise = k + !k1 | g = k -# _ILIT(1) + | otherwise = k fillNB g p k ys = fill1 g p k ys \end{code} @@ -797,7 +797,7 @@ best :: Int -- Line length best w_ r_ p = get (iUnbox w_) p where - r = iUnbox r_ + !r = iUnbox r_ get :: FastInt -- (Remaining) width of line -> Doc -> Doc get _ Empty = Empty diff --git a/compiler/utils/StringBuffer.lhs b/compiler/utils/StringBuffer.lhs index 1aead2d..2b3b775 100644 --- a/compiler/utils/StringBuffer.lhs +++ b/compiler/utils/StringBuffer.lhs @@ -224,7 +224,7 @@ parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int --LOL, in implementations where the indexing needs slow unsafePerformIO, --this is less (not more) efficient than using the IO monad explicitly --here. - ptr' = pUnbox ptr + !ptr' = pUnbox ptr byteOff i = cBox (indexWord8OffFastPtrAsFastChar ptr' (iUnbox (cur + i))) go i x | i == len = x | otherwise = case byteOff i of diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 97f8fb4..cc2d066 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -803,8 +803,8 @@ getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2) | p <# p2 = getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2 | otherwise = getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2)) where - j = i `quotFastInt` (shiftL1 p) - j2 = i2 `quotFastInt` (shiftL1 p2) + !j = i `quotFastInt` (shiftL1 p) + !j2 = i2 `quotFastInt` (shiftL1 p2) getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData diff --git a/utils/hpc/HpcParser.y b/utils/hpc/HpcParser.y index 74893e4..cf1d156 100644 --- a/utils/hpc/HpcParser.y +++ b/utils/hpc/HpcParser.y @@ -1,5 +1,5 @@ { -{-# OPTIONS -w #-} +{-# OPTIONS -Wwarn #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See -- 1.7.10.4