Commit 831a35dd authored by Ian Lynagh's avatar Ian Lynagh

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.
parent 7936b988
...@@ -134,8 +134,8 @@ newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u ...@@ -134,8 +134,8 @@ newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u
mkUnique c i mkUnique c i
= MkUnique (tag `bitOrFastInt` bits) = MkUnique (tag `bitOrFastInt` bits)
where where
tag = fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24) !tag = fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24)
bits = iUnbox i `bitAndFastInt` _ILIT(16777215){-``0x00ffffff''-} !bits = iUnbox i `bitAndFastInt` _ILIT(16777215){-``0x00ffffff''-}
unpkUnique (MkUnique u) unpkUnique (MkUnique u)
= let = let
...@@ -266,7 +266,7 @@ iToBase62 n_ ...@@ -266,7 +266,7 @@ iToBase62 n_
#if defined(__GLASGOW_HASKELL__) #if defined(__GLASGOW_HASKELL__)
--then FastInt == Int# --then FastInt == Int#
chooseChar62 n = C# (indexCharOffAddr# chars62 n) chooseChar62 n = C# (indexCharOffAddr# chars62 n)
chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# !chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#
#else #else
--Haskell98 arrays are portable --Haskell98 arrays are portable
chooseChar62 n = (!) chars62 n chooseChar62 n = (!) chars62 n
......
...@@ -11,7 +11,7 @@ ...@@ -11,7 +11,7 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
{ {
{-# OPTIONS -w #-} {-# OPTIONS -Wwarn #-}
-- The above warning supression flag is a temporary kludge. -- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix -- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See -- any warnings in the module. See
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
{ {
{-# OPTIONS -w #-} {-# OPTIONS -Wwarn #-}
-- The above warning supression flag is a temporary kludge. -- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix -- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See -- any warnings in the module. See
......
...@@ -154,10 +154,10 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) ...@@ -154,10 +154,10 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
insns_arr insns_arr
| n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO" | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
| otherwise = mkInstrArray n_insns asm_insns | 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_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 let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs
......
...@@ -120,13 +120,13 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS) ...@@ -120,13 +120,13 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS)
ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs
let 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 literals_arr = listArray (0, n_literals-1) linked_literals
:: UArray Int Word :: 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 newBCO insns_barr literals_barr ptrs_parr arity# bitmap
......
{ {
{-# 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. -- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix -- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See -- any warnings in the module. See
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- --
{ {
{-# OPTIONS -w #-} {-# OPTIONS -Wwarn #-}
-- The above warning supression flag is a temporary kludge. -- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix -- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See -- any warnings in the module. See
......
{ {
{-# OPTIONS -w #-} {-# OPTIONS -Wwarn #-}
-- The above warning supression flag is a temporary kludge. -- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix -- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See -- any warnings in the module. See
......
...@@ -32,7 +32,7 @@ ...@@ -32,7 +32,7 @@
-- qualified varids. -- qualified varids.
{ {
{-# OPTIONS -w #-} {-# OPTIONS -Wwarn #-}
-- The above warning supression flag is a temporary kludge. -- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix -- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See -- any warnings in the module. See
......
...@@ -8,7 +8,7 @@ ...@@ -8,7 +8,7 @@
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
{ {
{-# OPTIONS -w #-} {-# OPTIONS -Wwarn #-}
-- The above warning supression flag is a temporary kludge. -- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix -- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See -- any warnings in the module. See
......
{ {
{-# OPTIONS -w #-} {-# OPTIONS -Wwarn #-}
-- The above warning supression flag is a temporary kludge. -- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix -- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See -- any warnings in the module. See
......
...@@ -300,8 +300,8 @@ cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1}) ...@@ -300,8 +300,8 @@ cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1})
cmpCostCentre other_1 other_2 cmpCostCentre other_1 other_2
= let = let
tag1 = tag_CC other_1 !tag1 = tag_CC other_1
tag2 = tag_CC other_2 !tag2 = tag_CC other_2
in in
if tag1 <# tag2 then LT else GT if tag1 <# tag2 then LT else GT
where where
......
...@@ -475,6 +475,11 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos ...@@ -475,6 +475,11 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos
(strictBindErr "Recursive" unlifted mbind) (strictBindErr "Recursive" unlifted mbind)
; checkTc (isSingletonBag mbind) ; checkTc (isSingletonBag mbind)
(strictBindErr "Multiple" unlifted 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 ; mapM_ check_sig infos
; return True } ; return True }
| otherwise | otherwise
...@@ -486,6 +491,11 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos ...@@ -486,6 +491,11 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos
(badStrictSig unlifted sig) (badStrictSig unlifted sig)
check_sig _ = return () 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 :: String -> Bool -> LHsBindsLR Var Var -> SDoc
strictBindErr flavour unlifted mbind strictBindErr flavour unlifted mbind
= hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
......
...@@ -50,21 +50,21 @@ import GHC.Base ...@@ -50,21 +50,21 @@ import GHC.Base
{-# INLINE utf8DecodeChar# #-} {-# INLINE utf8DecodeChar# #-}
utf8DecodeChar# :: Addr# -> (# Char#, Addr# #) utf8DecodeChar# :: Addr# -> (# Char#, Addr# #)
utf8DecodeChar# a# = utf8DecodeChar# a# =
let ch0 = word2Int# (indexWord8OffAddr# a# 0#) in let !ch0 = word2Int# (indexWord8OffAddr# a# 0#) in
case () of case () of
_ | ch0 <=# 0x7F# -> (# chr# ch0, a# `plusAddr#` 1# #) _ | ch0 <=# 0x7F# -> (# chr# ch0, a# `plusAddr#` 1# #)
| ch0 >=# 0xC0# && ch0 <=# 0xDF# -> | 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 if ch1 <# 0x80# || ch1 >=# 0xC0# then fail 1# else
(# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +# (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +#
(ch1 -# 0x80#)), (ch1 -# 0x80#)),
a# `plusAddr#` 2# #) a# `plusAddr#` 2# #)
| ch0 >=# 0xE0# && ch0 <=# 0xEF# -> | 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 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 if ch2 <# 0x80# || ch2 >=# 0xC0# then fail 2# else
(# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +# (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +#
((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +# ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +#
...@@ -72,11 +72,11 @@ utf8DecodeChar# a# = ...@@ -72,11 +72,11 @@ utf8DecodeChar# a# =
a# `plusAddr#` 3# #) a# `plusAddr#` 3# #)
| ch0 >=# 0xF0# && ch0 <=# 0xF8# -> | 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 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 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 if ch3 <# 0x80# || ch3 >=# 0xC0# then fail 3# else
(# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +# (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +#
((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +# ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +#
...@@ -116,7 +116,7 @@ STRICT2(utf8DecodeString) ...@@ -116,7 +116,7 @@ STRICT2(utf8DecodeString)
utf8DecodeString (Ptr a#) (I# len#) utf8DecodeString (Ptr a#) (I# len#)
= unpack a# = unpack a#
where where
end# = addr2Int# (a# `plusAddr#` len#) !end# = addr2Int# (a# `plusAddr#` len#)
unpack p# unpack p#
| addr2Int# p# >=# end# = return [] | addr2Int# p# >=# end# = return []
......
...@@ -50,7 +50,7 @@ data FastMutInt = FastMutInt (MutableByteArray# RealWorld) ...@@ -50,7 +50,7 @@ data FastMutInt = FastMutInt (MutableByteArray# RealWorld)
newFastMutInt = IO $ \s -> newFastMutInt = IO $ \s ->
case newByteArray# size s of { (# s, arr #) -> case newByteArray# size s of { (# s, arr #) ->
(# s, FastMutInt arr #) } (# s, FastMutInt arr #) }
where I# size = SIZEOF_HSINT where !(I# size) = SIZEOF_HSINT
readFastMutInt (FastMutInt arr) = IO $ \s -> readFastMutInt (FastMutInt arr) = IO $ \s ->
case readIntArray# arr 0# s of { (# s, i #) -> case readIntArray# arr 0# s of { (# s, i #) ->
...@@ -65,7 +65,7 @@ data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld) ...@@ -65,7 +65,7 @@ data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld)
newFastMutPtr = IO $ \s -> newFastMutPtr = IO $ \s ->
case newByteArray# size s of { (# s, arr #) -> case newByteArray# size s of { (# s, arr #) ->
(# s, FastMutPtr arr #) } (# s, FastMutPtr arr #) }
where I# size = SIZEOF_VOID_P where !(I# size) = SIZEOF_VOID_P
readFastMutPtr (FastMutPtr arr) = IO $ \s -> readFastMutPtr (FastMutPtr arr) = IO $ \s ->
case readAddrArray# arr 0# s of { (# s, i #) -> case readAddrArray# arr 0# s of { (# s, i #) ->
......
...@@ -380,9 +380,9 @@ hashStr (Ptr a#) (I# len#) = loop 0# 0# ...@@ -380,9 +380,9 @@ hashStr (Ptr a#) (I# len#) = loop 0# 0#
where where
loop h n | n GHC.Exts.==# len# = I# h loop h n | n GHC.Exts.==# len# = I# h
| otherwise = loop h2 (n GHC.Exts.+# 1#) | otherwise = loop h2 (n GHC.Exts.+# 1#)
where c = ord# (indexCharOffAddr# a# n) where !c = ord# (indexCharOffAddr# a# n)
h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#`
hASH_TBL_SIZE# hASH_TBL_SIZE#
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Operations -- Operations
......
...@@ -615,7 +615,7 @@ aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k -# k1) q) ...@@ -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 (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
where where
k1 = k -# sl !k1 = k -# sl
rest = case p of rest = case p of
Empty -> nilAboveNest g k1 q Empty -> nilAboveNest g k1 q
_ -> aboveNest p 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 ...@@ -775,8 +775,8 @@ fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys
`mkUnion` `mkUnion`
nilAboveNest False k (fill g (y:ys)) nilAboveNest False k (fill g (y:ys))
where where
k1 | g = k -# _ILIT(1) !k1 | g = k -# _ILIT(1)
| otherwise = k | otherwise = k
fillNB g p k ys = fill1 g p k ys fillNB g p k ys = fill1 g p k ys
\end{code} \end{code}
...@@ -797,7 +797,7 @@ best :: Int -- Line length ...@@ -797,7 +797,7 @@ best :: Int -- Line length
best w_ r_ p best w_ r_ p
= get (iUnbox w_) p = get (iUnbox w_) p
where where
r = iUnbox r_ !r = iUnbox r_
get :: FastInt -- (Remaining) width of line get :: FastInt -- (Remaining) width of line
-> Doc -> Doc -> Doc -> Doc
get _ Empty = Empty get _ Empty = Empty
......
...@@ -224,7 +224,7 @@ parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int ...@@ -224,7 +224,7 @@ parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int
--LOL, in implementations where the indexing needs slow unsafePerformIO, --LOL, in implementations where the indexing needs slow unsafePerformIO,
--this is less (not more) efficient than using the IO monad explicitly --this is less (not more) efficient than using the IO monad explicitly
--here. --here.
ptr' = pUnbox ptr !ptr' = pUnbox ptr
byteOff i = cBox (indexWord8OffFastPtrAsFastChar ptr' (iUnbox (cur + i))) byteOff i = cBox (indexWord8OffFastPtrAsFastChar ptr' (iUnbox (cur + i)))
go i x | i == len = x go i x | i == len = x
| otherwise = case byteOff i of | otherwise = case byteOff i of
......
...@@ -803,8 +803,8 @@ getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2) ...@@ -803,8 +803,8 @@ getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2)
| p <# p2 = getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2 | p <# p2 = getCommonNodeUFMData_ p2 (j `quotFastInt` (p2 `quotFastInt` p)) j2
| otherwise = getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2)) | otherwise = getCommonNodeUFMData_ p j (j2 `quotFastInt` (p `quotFastInt` p2))
where where
j = i `quotFastInt` (shiftL1 p) !j = i `quotFastInt` (shiftL1 p)
j2 = i2 `quotFastInt` (shiftL1 p2) !j2 = i2 `quotFastInt` (shiftL1 p2)
getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData getCommonNodeUFMData_ :: FastInt -> FastInt -> FastInt -> NodeUFMData
......
{ {
{-# OPTIONS -w #-} {-# OPTIONS -Wwarn #-}
-- The above warning supression flag is a temporary kludge. -- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix -- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See -- any warnings in the module. See
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment