Commit 67157c5c authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Warn a bit less often about unlifted bindings.

Warn when
   (a) a pattern bindings binds unlifted values
   (b) it has no top-level bang
   (c) the RHS has a *lifted* type

Clause (c) is new, argued for by Simon M

Eg     x# = 4# + 4#      -- No warning
       (# a,b #) = blah  -- No warning
       I# x = blah       -- Warning
parent b9c34f47
......@@ -22,7 +22,8 @@ module HsPat (
mkPrefixConPat, mkCharLitPat, mkNilPat,
isBangHsBind, isBangLPat, hsPatNeedsParens,
isBangHsBind, isLiftedPatBind,
isBangLPat, hsPatNeedsParens,
isIrrefutableHsPat,
pprParendLPat
......@@ -374,10 +375,29 @@ isBangLPat (L _ (ParPat p)) = isBangLPat p
isBangLPat _ = False
isBangHsBind :: HsBind id -> Bool
-- In this module because HsPat is above HsBinds in the import graph
-- A pattern binding with an outermost bang
-- Defined in this module because HsPat is above HsBinds in the import graph
isBangHsBind (PatBind { pat_lhs = p }) = isBangLPat p
isBangHsBind _ = False
isLiftedPatBind :: HsBind id -> Bool
-- A pattern binding with a compound pattern, not just a variable
-- (I# x) yes
-- (# a, b #) no, even if a::Int#
-- x no, even if x::Int#
-- We want to warn about a missing bang-pattern on the yes's
isLiftedPatBind (PatBind { pat_lhs = p }) = isLiftedLPat p
isLiftedPatBind _ = False
isLiftedLPat :: LPat id -> Bool
isLiftedLPat (L _ (ParPat p)) = isLiftedLPat p
isLiftedLPat (L _ (BangPat p)) = isLiftedLPat p
isLiftedLPat (L _ (AsPat _ p)) = isLiftedLPat p
isLiftedLPat (L _ (TuplePat _ Unboxed _)) = False
isLiftedLPat (L _ (VarPat {})) = False
isLiftedLPat (L _ (WildPat {})) = False
isLiftedLPat _ = True
isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
-- (isIrrefutableHsPat p) is true if matching against p cannot fail,
-- in the sense of falling through to the next pattern.
......
......@@ -1134,19 +1134,25 @@ checkStrictBinds top_lvl rec_group binds poly_ids
-- the versions of alex and happy available have non-conforming
-- templates, so the GHC build fails if it's an error:
; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings
; warnTc (warnUnlifted && not bang_pat)
; warnTc (warnUnlifted && not bang_pat && lifted_pat)
-- No outer bang, but it's a compound pattern
-- E.g (I# x#) = blah
-- Warn about this, but not about
-- x# = 4# +# 1#
-- (# a, b #) = ...
(unliftedMustBeBang binds) }
| otherwise
= return ()
where
unlifted = any is_unlifted poly_ids
bang_pat = any (isBangHsBind . unLoc) binds
unlifted = any is_unlifted poly_ids
bang_pat = any (isBangHsBind . unLoc) binds
lifted_pat = any (isLiftedPatBind . unLoc) binds
is_unlifted id = case tcSplitForAllTys (idType id) of
(_, rho) -> isUnLiftedType rho
unliftedMustBeBang :: [LHsBind Name] -> SDoc
unliftedMustBeBang binds
= hang (text "Bindings containing unlifted types should use an outermost bang pattern:")
= hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
2 (pprBindList binds)
strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
......
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