--------------
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise
--------------
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise
decideGeneralisationPlan
:: DynFlags -> TopLevelFlag -> [Name] -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn
decideGeneralisationPlan
:: DynFlags -> TopLevelFlag -> [Name] -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn
| mono_pat_binds = NoGen
| Just sig <- one_funbind_with_sig binds = if null (sig_tvs sig) && null (sig_theta sig)
then NoGen -- Optimise common case
| mono_pat_binds = NoGen
| Just sig <- one_funbind_with_sig binds = if null (sig_tvs sig) && null (sig_theta sig)
then NoGen -- Optimise common case
- mono_pat_binds = xopt Opt_MonoPatBinds dflags
+ bang_pat_binds = any (isBangHsBind . unLoc) binds
+ -- Bang patterns must not be polymorphic,
+ -- because we are going to force them
+ -- See Trac #4498
+
+ mono_pat_binds = xopt Opt_MonoPatBinds dflags
; checkTc (isNonRec rec_group)
(strictBindErr "Recursive" unlifted binds)
; checkTc (isSingleton binds)
; checkTc (isNonRec rec_group)
(strictBindErr "Recursive" unlifted binds)
; checkTc (isSingleton binds)
-- 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:
; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings
-- 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:
; 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 #) = ...
- 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
is_unlifted id = case tcSplitForAllTys (idType id) of
(_, rho) -> isUnLiftedType rho
unliftedMustBeBang :: [LHsBind Name] -> SDoc
unliftedMustBeBang binds