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
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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
{
{-# 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
......
......@@ -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
......
{
{-# 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
......
......@@ -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
......
......@@ -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
......
{
{-# 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
......
......@@ -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
......
......@@ -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:"))
......
......@@ -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 []
......
......@@ -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 #) ->
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
{
{-# 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
......
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