Commit 46368868 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Improve the desugaring of -XStrict

Trac #14035 showed that -XStrict was generating some TERRIBLE
desugarings, espcially for bindings with INLINE pragmas. Reason: with
-XStrict, all AbsBinds (even for non-recursive functions) went via the
general-case deguaring for AbsBinds, namely "generate a tuple and
select from it", even though in this case there was only one variable
in the tuple.  And that in turn interacts terribly badly with INLINE
pragmas.

This patch cleans things up:

* I killed off AbsBindsSig completely, in favour of a boolean flag
  abs_sig in AbsBinds.  See Note [The abs_sig field of AbsBinds]

  This allowed me to delete lots of code; and instance-method
  declarations can enjoy the benefits too.  (They could have
  before, but no one had changed them to use AbsBindsSig.)

* I refactored all the AbsBinds handling in DsBinds into a new
  function DsBinds.dsAbsBinds.  This allowed me to handle the
  strict case uniformly
parent 2535a671
......@@ -281,31 +281,6 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
| ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
, isInlinePragma (idInlinePragma pid) ] }
addTickLHsBind (L pos bind@(AbsBindsSig { abs_sig_bind = val_bind
, abs_sig_export = poly_id }))
| L _ FunBind { fun_id = L _ mono_id } <- val_bind
= do withEnv (add_export mono_id) $ do
withEnv (add_inlines mono_id) $ do
val_bind' <- addTickLHsBind val_bind
return $ L pos $ bind { abs_sig_bind = val_bind' }
| otherwise
= pprPanic "addTickLHsBind" (ppr bind)
where
-- see AbsBinds comments
add_export mono_id env
| idName poly_id `elemNameSet` exports env
= env { exports = exports env `extendNameSet` idName mono_id }
| otherwise
= env
-- See Note [inline sccs]
add_inlines mono_id env
| isInlinePragma (idInlinePragma poly_id)
= env { inlines = inlines env `extendVarSet` mono_id }
| otherwise
= env
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
let name = getOccString id
decl_path <- getPathEntry
......
......@@ -52,6 +52,7 @@ import Name
import VarSet
import Rules
import VarEnv
import Var( EvVar )
import Outputable
import Module
import SrcLoc
......@@ -105,8 +106,7 @@ dsTopLHsBinds binds
-- later be forced in the binding group body, see Note [Desugar Strict binds]
dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
dsLHsBinds binds
= do { MASSERT( allBag (not . isUnliftedHsBind . unLoc) binds )
; ds_bs <- mapBagM dsLHsBind binds
= do { ds_bs <- mapBagM dsLHsBind binds
; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))
id ([], []) ds_bs) }
......@@ -124,10 +124,9 @@ dsHsBind :: DynFlags
-- binding group see Note [Desugar Strict binds] and all
-- bindings and their desugared right hand sides.
dsHsBind dflags
(VarBind { var_id = var
, var_rhs = expr
, var_inline = inline_regardless })
dsHsBind dflags (VarBind { var_id = var
, var_rhs = expr
, var_inline = inline_regardless })
= do { core_expr <- dsLExpr expr
-- Dictionary bindings are always VarBinds,
-- so we only need do this here
......@@ -139,9 +138,8 @@ dsHsBind dflags
else []
; return (force_var, [core_bind]) }
dsHsBind dflags
b@(FunBind { fun_id = L _ fun, fun_matches = matches
, fun_co_fn = co_fn, fun_tick = tick })
dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches
, fun_co_fn = co_fn, fun_tick = tick })
= do { (args, body) <- matchWrapper
(mkPrefixFunRhs (noLoc $ idName fun))
Nothing matches
......@@ -158,12 +156,14 @@ dsHsBind dflags
= [id]
| otherwise
= []
; --pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun) $$ ppr (mg_alts matches) $$ ppr args $$ ppr core_binds) $
return (force_var, [core_binds]) }
dsHsBind dflags
(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
, pat_ticks = (rhs_tick, var_ticks) })
; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)
-- , ppr (mg_alts matches)
-- , ppr args, ppr core_binds]) $
return (force_var, [core_binds]) }
dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
, pat_rhs_ty = ty
, pat_ticks = (rhs_tick, var_ticks) })
= do { body_expr <- dsGuarded grhss ty
; let body' = mkOptTickBox rhs_tick body_expr
pat' = decideBangHood dflags pat
......@@ -175,47 +175,73 @@ dsHsBind dflags
else []
; return (force_var', sel_binds) }
-- A common case: one exported variable, only non-strict binds
-- Non-recursive bindings come through this way
-- So do self-recursive bindings
-- Bindings with complete signatures are AbsBindsSigs, below
dsHsBind dflags
(AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = [export]
, abs_ev_binds = ev_binds, abs_binds = binds })
| ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = prags } <- export
, not (xopt LangExt.Strict dflags) -- Handle strict binds
, not (anyBag (isBangedBind . unLoc) binds) -- in the next case
= -- See Note [AbsBinds wrappers] in HsBinds
addDictsDs (toTcTypeBag (listToBag dicts)) $
-- addDictsDs: push type constraints deeper for pattern match check
do { (force_vars, bind_prs) <- dsLHsBinds binds
; ds_binds <- dsTcEvBinds_s ev_binds
; core_wrap <- dsHsWrapper wrap -- Usually the identity
dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = exports
, abs_ev_binds = ev_binds
, abs_binds = binds, abs_sig = has_sig })
= do { ds_binds <- addDictsDs (toTcTypeBag (listToBag dicts)) $
dsLHsBinds binds
-- addDictsDs: push type constraints deeper
-- for inner pattern match check
; ds_ev_binds <- dsTcEvBinds_s ev_binds
-- dsAbsBinds does the hard work
; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
-----------------------
dsAbsBinds :: DynFlags
-> [TyVar] -> [EvVar] -> [ABExport GhcTc]
-> [CoreBind] -- Desugared evidence bidings
-> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings
-> Bool -- Single binding with signature
-> DsM ([Id], [(Id,CoreExpr)])
dsAbsBinds dflags tyvars dicts exports
ds_ev_binds (force_vars, bind_prs) has_sig
-- A very important common case: one exported variable
-- Non-recursive bindings come through this way
-- So do self-recursive bindings
| [export] <- exports
, ABE { abe_poly = global_id, abe_mono = local_id
, abe_wrap = wrap, abe_prags = prags } <- export
, Just force_vars' <- case force_vars of
[] -> Just []
[v] | v == local_id -> Just [global_id]
_ -> Nothing
-- If there is a variable to force, it's just the
-- single variable we are binding here
= do { core_wrap <- dsHsWrapper wrap -- Usually the identity
; let rhs = core_wrap $
mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
mkLetRec bind_prs $
Var local
mkCoreLets ds_ev_binds $
body
body | has_sig
, [(_, lrhs)] <- bind_prs
= lrhs
| otherwise
= mkLetRec bind_prs (Var local_id)
; (spec_binds, rules) <- dsSpecs rhs prags
; let global' = addIdSpecialisations global rules
main_bind = makeCorePair dflags global' (isDefaultMethod prags)
(dictArity dicts) rhs
; let global_id' = addIdSpecialisations global_id rules
main_bind = makeCorePair dflags global_id'
(isDefaultMethod prags)
(dictArity dicts) rhs
; ASSERT(null force_vars)
return ([], main_bind : fromOL spec_binds) }
; return (force_vars', main_bind : fromOL spec_binds) }
-- Another common case: no tyvars, no dicts
-- In this case we can have a much simpler desugaring
dsHsBind dflags
(AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_exports = exports
, abs_ev_binds = ev_binds, abs_binds = binds })
= do { (force_vars, bind_prs) <- dsLHsBinds binds
; let mk_bind (ABE { abe_wrap = wrap
-- Another common case: no tyvars, no dicts
-- In this case we can have a much simpler desugaring
| null tyvars, null dicts
= do { let mk_bind (ABE { abe_wrap = wrap
, abe_poly = global
, abe_mono = local
, abe_prags = prags })
......@@ -225,42 +251,35 @@ dsHsBind dflags
0 (core_wrap (Var local))) }
; main_binds <- mapM mk_bind exports
; ds_binds <- dsTcEvBinds_s ev_binds
; return (force_vars, flattenBinds ds_binds ++ bind_prs ++ main_binds) }
dsHsBind dflags
(AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = exports, abs_ev_binds = ev_binds
, abs_binds = binds })
-- See Note [Desugaring AbsBinds]
= addDictsDs (toTcTypeBag (listToBag dicts)) $
-- addDictsDs: push type constraints deeper for pattern match check
do { (local_force_vars, bind_prs) <- dsLHsBinds binds
; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
-- The general case
-- See Note [Desugaring AbsBinds]
| otherwise
= do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
| (lcl_id, rhs) <- bind_prs ]
-- Monomorphic recursion possible, hence Rec
new_force_vars = get_new_force_vars local_force_vars
locals = map abe_mono exports
all_locals = locals ++ new_force_vars
tup_expr = mkBigCoreVarTup all_locals
tup_ty = exprType tup_expr
; ds_binds <- dsTcEvBinds_s ev_binds
; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
mkLet core_bind $
tup_expr
; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
new_force_vars = get_new_force_vars force_vars
locals = map abe_mono exports
all_locals = locals ++ new_force_vars
tup_expr = mkBigCoreVarTup all_locals
tup_ty = exprType tup_expr
; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
mkCoreLets ds_ev_binds $
mkLet core_bind $
tup_expr
; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
-- Find corresponding global or make up a new one: sometimes
-- we need to make new export to desugar strict binds, see
-- Note [Desugar Strict binds]
; (exported_force_vars, extra_exports) <- get_exports local_force_vars
; (exported_force_vars, extra_exports) <- get_exports force_vars
; let mk_bind (ABE { abe_wrap = wrap
, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
-- See Note [AbsBinds wrappers] in HsBinds
; let mk_bind (ABE { abe_wrap = wrap
, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
-- See Note [AbsBinds wrappers] in HsBinds
= do { tup_id <- newSysLocalDs tup_ty
; core_wrap <- dsHsWrapper wrap
; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $
......@@ -275,10 +294,10 @@ dsHsBind dflags
-- Id is just the selector. Hmm.
; return ((global', rhs) : fromOL spec_binds) }
; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
; return (exported_force_vars
,(poly_tup_id, poly_tup_rhs) :
; return ( exported_force_vars
, (poly_tup_id, poly_tup_rhs) :
concat export_binds_s) }
where
inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
......@@ -321,57 +340,10 @@ dsHsBind dflags
mk_export local =
do global <- newSysLocalDs
(exprType (mkLams tyvars (mkLams dicts (Var local))))
return (ABE {abe_poly = global
,abe_mono = local
,abe_wrap = WpHole
,abe_prags = SpecPrags []})
-- AbsBindsSig is a combination of AbsBinds and FunBind
dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_sig_export = global
, abs_sig_prags = prags
, abs_sig_ev_bind = ev_bind
, abs_sig_bind = bind })
| L bind_loc FunBind { fun_matches = matches
, fun_co_fn = co_fn
, fun_tick = tick } <- bind
= putSrcSpanDs bind_loc $
addDictsDs (toTcTypeBag (listToBag dicts)) $
-- addDictsDs: push type constraints deeper for pattern match check
do { (args, body) <- matchWrapper
(mkPrefixFunRhs (noLoc $ idName global))
Nothing matches
; core_wrap <- dsHsWrapper co_fn
; let body' = mkOptTickBox tick body
fun_rhs = core_wrap (mkLams args body')
force_vars
| xopt LangExt.Strict dflags
, matchGroupArity matches == 0 -- no need to force lambdas
= [global]
| isBangedBind (unLoc bind)
= [global]
| otherwise
= []
; ds_binds <- dsTcEvBinds ev_bind
; let rhs = mkLams tyvars $
mkLams dicts $
mkCoreLets ds_binds $
fun_rhs
; (spec_binds, rules) <- dsSpecs rhs prags
; let global' = addIdSpecialisations global rules
main_bind = makeCorePair dflags global' (isDefaultMethod prags)
(dictArity dicts) rhs
; return (force_vars, main_bind : fromOL spec_binds) }
| otherwise
= pprPanic "dsHsBind: AbsBindsSig" (ppr bind)
dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
return (ABE { abe_poly = global
, abe_mono = local
, abe_wrap = WpHole
, abe_prags = SpecPrags [] })
-- | This is where we apply INLINE and INLINABLE pragmas. All we need to
-- do is to attach the unfolding information to the Id.
......
......@@ -130,8 +130,6 @@ ds_val_bind (NonRecursive, hsbinds) body
where
is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
= not (null tvs && null evs)
is_polymorphic (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs })
= not (null tvs && null evs)
is_polymorphic _ = False
unlifted_must_be_bang bind
......@@ -186,15 +184,6 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
; ds_binds <- dsTcEvBinds_s ev_binds
; return (mkCoreLets ds_binds body2) }
dsUnliftedBind (AbsBindsSig { abs_tvs = []
, abs_ev_vars = []
, abs_sig_export = poly
, abs_sig_ev_bind = ev_bind
, abs_sig_bind = L _ bind }) body
= do { ds_binds <- dsTcEvBinds ev_bind
; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body
; return (mkCoreLets ds_binds body') }
dsUnliftedBind (FunBind { fun_id = L l fun
, fun_matches = matches
, fun_co_fn = co_fn
......
......@@ -1475,7 +1475,6 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
; return (srcLocSpan (getSrcLoc v), ans) }
rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
rep_bind (L _ (AbsBindsSig {})) = panic "rep_bind: AbsBindsSig"
rep_bind (L loc (PatSynBind (PSB { psb_id = syn
, psb_fvs = _fvs
, psb_args = args
......
......@@ -269,22 +269,9 @@ data HsBindLR idL idR
abs_ev_binds :: [TcEvBinds],
-- | Typechecked user bindings
abs_binds :: LHsBinds idL
}
-- | Abstraction Bindings Signature
| AbsBindsSig { -- Simpler form of AbsBinds, used with a type sig
-- in tcPolyCheck. Produces simpler desugaring and
-- is necessary to avoid #11405, comment:3.
abs_tvs :: [TyVar],
abs_ev_vars :: [EvVar],
abs_sig_export :: IdP idL, -- like abe_poly
abs_sig_prags :: TcSpecPrags,
abs_binds :: LHsBinds idL,
abs_sig_ev_bind :: TcEvBinds, -- no list needed here
abs_sig_bind :: LHsBind idL -- always only one, and it's always a
-- FunBind
abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds]
}
-- | Patterns Synonym Binding
......@@ -312,7 +299,7 @@ deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR)
-- | Abtraction Bindings Export
data ABExport p
= ABE { abe_poly :: IdP p -- ^ Any INLINE pragmas is attached to this Id
= ABE { abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id
, abe_mono :: IdP p
, abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper]
-- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
......@@ -481,6 +468,53 @@ bindings only when
lacks a user type signature
* The group forms a strongly connected component
Note [The abs_sig field of AbsBinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The abs_sig field supports a couple of special cases for bindings.
Consider
x :: Num a => (# a, a #)
x = (# 3, 4 #)
The general desugaring for AbsBinds would give
x = /\a. \ ($dNum :: Num a) ->
letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in
xm
But that has an illegal let-binding for an unboxed tuple. In this
case we'd prefer to generate the (more direct)
x = /\ a. \ ($dNum :: Num a) ->
(# fromInteger $dNum 3, fromInteger $dNum 4 #)
A similar thing happens with representation-polymorphic defns
(Trac #11405):
undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
undef = error "undef"
Again, the vanilla desugaring gives a local let-binding for a
representation-polymorphic (undefm :: a), which is illegal. But
again we can desugar without a let:
undef = /\ a. \ (d:HasCallStack) -> error a d "undef"
The abs_sig field supports this direct desugaring, with no local
let-bining. When abs_sig = True
* the abs_binds is single FunBind
* the abs_exports is a singleton
* we have a complete type sig for binder
and hence the abs_binds is non-recursive
(it binds the mono_id but refers to the poly_id
These properties are exploited in DsBinds.dsAbsBinds to
generate code without a let-binding.
Note [ABExport wrapper]
~~~~~~~~~~~~~~~~~~~~~~~
Consider
......@@ -662,21 +696,6 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, text "Evidence:" <+> ppr ev_binds ]
else
pprLHsBinds val_binds
ppr_monobind (AbsBindsSig { abs_tvs = tyvars
, abs_ev_vars = dictvars
, abs_sig_export = poly_id
, abs_sig_ev_bind = ev_bind
, abs_sig_bind = bind })
= sdocWithDynFlags $ \ dflags ->
if gopt Opt_PrintTypecheckerElaboration dflags then
hang (text "AbsBindsSig" <+> brackets (interpp'SP tyvars)
<+> brackets (interpp'SP dictvars))
2 $ braces $ vcat
[ text "Exported type:" <+> pprBndr LetBind poly_id
, text "Bind:" <+> ppr bind
, text "Evidence:" <+> ppr ev_bind ]
else
ppr bind
instance (OutputableBndrId p) => Outputable (ABExport p) where
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
......
......@@ -577,8 +577,6 @@ looksLazyPatBind (PatBind { pat_lhs = p })
= looksLazyLPat p
looksLazyPatBind (AbsBinds { abs_binds = binds })
= anyBag (looksLazyPatBind . unLoc) binds
looksLazyPatBind (AbsBindsSig { abs_sig_bind = L _ bind })
= looksLazyPatBind bind
looksLazyPatBind _
= False
......
......@@ -796,49 +796,31 @@ to return a [Name] or [Id]. Before renaming the record punning
and wild-card mechanism makes it hard to know what is bound.
So these functions should not be applied to (HsSyn RdrName)
Note [Unlifted id check in isHsUnliftedBind]
Note [Unlifted id check in isUnliftedHsBind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose there is a binding with the type (Num a => (# a, a #)). Is this a
strict binding that should be disallowed at the top level? At first glance,
no, because it's a function. But consider how this is desugared via
AbsBinds:
The function isUnliftedHsBind is used to complain if we make a top-level
binding for a variable of unlifted type.
-- x :: Num a => (# a, a #)
x = (# 3, 4 #)
Such a binding is illegal if the top-level binding would be unlifted;
but also if the local letrec generated by desugaring AbsBinds would be.
E.g.
f :: Num a => (# a, a #)
g :: Num a => a -> a
f = ...g...
g = ...g...
becomes
The top-level bindings for f,g are not unlifted (because of the Num a =>),
but the local, recursive, monomorphic bindings are:
x = \ $dictNum ->
let x_mono = (# fromInteger $dictNum 3, fromInteger $dictNum 4 #) in
x_mono
t = /\a \(d:Num a).
letrec fm :: (# a, a #) = ...g...
gm :: a -> a = ...f...
in (fm, gm)
Note that the inner let is strict. And thus if we have a bunch of mutually
recursive bindings of this form, we could end up in trouble. This was shown
up in #9140.
But if there is a type signature on x, everything changes because of the
desugaring used by AbsBindsSig:
x :: Num a => (# a, a #)
x = (# 3, 4 #)
becomes
x = \ $dictNum -> (# fromInteger $dictNum 3, fromInteger $dictNum 4 #)
No strictness anymore! The bottom line here is that, for inferred types, we
care about the strictness of the type after the =>. For checked types
(AbsBindsSig), we care about the overall strictness.
This matters. If we don't separate out the AbsBindsSig case, then GHC runs into
a problem when compiling
undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
Looking only after the =>, we cannot tell if this is strict or not. (GHC panics
if you try.) Looking at the whole type, on the other hand, tells you that this
is a lifted function type, with no trouble at all.
Here the binding for 'fm' is illegal. So generally we check the abe_mono types.
BUT we have a special case when abs_sig is true;
see HsBinds Note [The abs_sig field of AbsBinds]
-}
----------------- Bindings --------------------------
......@@ -848,18 +830,19 @@ is a lifted function type, with no trouble at all.
-- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage
-- information, see Note [Strict binds check] is DsBinds.
isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds
isUnliftedHsBind (AbsBindsSig { abs_sig_export = id })
= isUnliftedType (idType id)
isUnliftedHsBind bind
| AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind
= if has_sig
then any (is_unlifted_id . abe_poly) exports
else any (is_unlifted_id . abe_mono) exports
-- If has_sig is True we wil never generate a binding for abe_mono,
-- so we don't need to worry about it being unlifted. The abe_poly
-- binding might not be: e.g. forall a. Num a => (# a, a #)
| otherwise
= any is_unlifted_id (collectHsBindBinders bind)
where
is_unlifted_id id
= case tcSplitSigmaTy (idType id) of
(_, _, tau) -> isUnliftedType tau
-- For the is_unlifted check, we need to look inside polymorphism
-- and overloading. E.g. x = (# 1, True #)
-- would get type forall a. Num a => (# a, Bool #)
-- and we want to reject that. See Trac #9140
is_unlifted_id id = isUnliftedType (idType id)
-- | Is a binding a strict variable bind (e.g. @!x = ...@)?
isBangedBind :: HsBind GhcTc -> Bool
......@@ -911,7 +894,6 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++
-- I don't think we want the binders from the abe_binds
-- The only time we collect binders from a typechecked
-- binding (hence see AbsBinds) is in zonking in TcHsSyn
collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc
collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc
| omitPatSyn = acc
| otherwise = ps : acc
......
......@@ -38,7 +38,7 @@ import FamInstEnv( normaliseType )
import FamInst( tcGetFamInstEnvs )
import TyCon
import TcType
import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder, splitTyConApp_maybe)
import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe)
import TysPrim
import TysWiredIn( cTupleTyConName )
import Id
......@@ -717,13 +717,18 @@ tcPolyCheck prag_fn