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

@@ -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

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

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

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 
 

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
 

compiler/main/ParsePkgConf.y

 {
-{-# 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

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

compiler/parser/HaddockParse.y

 {
-{-# 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

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

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

compiler/parser/ParserCore.y

 {
-{-# 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

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

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:")) 

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 []

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 #) ->

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

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

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

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
 

utils/hpc/HpcParser.y

 { 
-{-# 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