summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/Coverage.hs25
-rw-r--r--compiler/deSugar/DsBinds.hs236
-rw-r--r--compiler/deSugar/DsExpr.hs11
-rw-r--r--compiler/deSugar/DsMeta.hs1
-rw-r--r--compiler/hsSyn/HsBinds.hs81
-rw-r--r--compiler/hsSyn/HsPat.hs2
-rw-r--r--compiler/hsSyn/HsUtils.hs76
-rw-r--r--compiler/typecheck/TcBinds.hs32
-rw-r--r--compiler/typecheck/TcClassDcl.hs9
-rw-r--r--compiler/typecheck/TcHsSyn.hs76
-rw-r--r--compiler/typecheck/TcInstDcls.hs20
-rw-r--r--testsuite/tests/ghc-api/T6145.hs2
-rw-r--r--testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr3
-rw-r--r--utils/ghctags/Main.hs1
14 files changed, 250 insertions, 325 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 16537bd7a5..d44c203b6f 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -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
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 5d9a33d660..ae23a765c4 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -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.
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index c3d9489476..048d558825 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -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
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index e732ce56b0..cc2ff133ae 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -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
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index d766ab2c13..a8efa7206f 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -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 })
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index f7d18768df..edf2e1b349 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -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
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index e953697ce2..5be757fb72 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -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
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 2327b6ffef..0995f6bae8 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -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
, bind_fvs = placeHolderNamesTc
, fun_tick = funBindTicks nm_loc mono_id mod prag_sigs }
- abs_bind = L loc $ AbsBindsSig
- { abs_sig_export = poly_id
- , abs_tvs = skol_tvs
- , abs_ev_vars = ev_vars
- , abs_sig_prags = SpecPrags spec_prags
- , abs_sig_ev_bind = ev_binds
- , abs_sig_bind = L loc bind' }
+ export = ABE { abe_wrap = idHsWrapper
+ , abe_poly = poly_id
+ , abe_mono = mono_id
+ , abe_prags = SpecPrags spec_prags }
+
+ abs_bind = L loc $
+ AbsBinds { abs_tvs = skol_tvs
+ , abs_ev_vars = ev_vars
+ , abs_ev_binds = [ev_binds]
+ , abs_exports = [export]
+ , abs_binds = unitBag (L loc bind')
+ , abs_sig = True }
; return (unitBag abs_bind, [poly_id]) }
@@ -799,7 +804,8 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
abs_bind = L loc $
AbsBinds { abs_tvs = qtvs
, abs_ev_vars = givens, abs_ev_binds = [ev_binds]
- , abs_exports = exports, abs_binds = binds' }
+ , abs_exports = exports, abs_binds = binds'
+ , abs_sig = False }
; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
; return (unitBag abs_bind, poly_ids) }
@@ -858,9 +864,9 @@ mkExport prag_fn insoluble qtvs theta
; return (ABE { abe_wrap = wrap
-- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
- , abe_poly = poly_id
- , abe_mono = mono_id
- , abe_prags = SpecPrags spec_prags}) }
+ , abe_poly = poly_id
+ , abe_mono = mono_id
+ , abe_prags = SpecPrags spec_prags }) }
where
prag_sigs = lookupPragEnv prag_fn poly_name
sig_ctxt = InfSigCtxt poly_name
@@ -1611,7 +1617,7 @@ data GeneralisationPlan
| CheckGen (LHsBind GhcRn) TcIdSigInfo
-- One FunBind with a signature
- -- Explicit generalisation; there is an AbsBindsSig
+ -- Explicit generalisation
-- A consequence of the no-AbsBinds choice (NoGen) is that there is
-- no "polymorphic Id" and "monmomorphic Id"; there is just the one
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index a3e9549a1c..5519cc8bca 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -278,14 +278,15 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
(L bind_loc lm_bind)
; let export = ABE { abe_poly = global_dm_id
- , abe_mono = local_dm_id
- , abe_wrap = idHsWrapper
- , abe_prags = IsDefaultMethod }
+ , abe_mono = local_dm_id
+ , abe_wrap = idHsWrapper
+ , abe_prags = IsDefaultMethod }
full_bind = AbsBinds { abs_tvs = tyvars
, abs_ev_vars = [this_dict]
, abs_exports = [export]
, abs_ev_binds = [ev_binds]
- , abs_binds = tc_bind }
+ , abs_binds = tc_bind
+ , abs_sig = True }
; return (unitBag (L bind_loc full_bind)) }
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 86ade903ec..c5de0dce01 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -455,24 +455,44 @@ zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abs_ev_binds = ev_binds
, abs_exports = exports
- , abs_binds = val_binds })
+ , abs_binds = val_binds
+ , abs_sig = has_sig })
= ASSERT( all isImmutableTyVar tyvars )
do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
; (env1, new_evs) <- zonkEvBndrsX env0 evs
; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
- do { let env3 = extendIdZonkEnvRec env2
- (collectHsBindsBinders new_val_binds)
- ; new_val_binds <- zonkMonoBinds env3 val_binds
- ; new_exports <- mapM (zonkExport env3) exports
+ do { let env3 = extendIdZonkEnvRec env2 $
+ collectHsBindsBinders new_val_binds
+ ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds
+ ; new_exports <- mapM (zonk_export env3) exports
; return (new_val_binds, new_exports) }
; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
, abs_ev_binds = new_ev_binds
- , abs_exports = new_exports, abs_binds = new_val_bind }) }
+ , abs_exports = new_exports, abs_binds = new_val_bind
+ , abs_sig = has_sig }) }
where
- zonkExport env (ABE{ abe_wrap = wrap
- , abe_poly = poly_id
- , abe_mono = mono_id, abe_prags = prags })
+ zonk_val_bind env lbind
+ | has_sig
+ , L loc bind@(FunBind { fun_id = L mloc mono_id
+ , fun_matches = ms
+ , fun_co_fn = co_fn }) <- lbind
+ = do { new_mono_id <- updateVarTypeM (zonkTcTypeToType env) mono_id
+ -- Specifically /not/ zonkIdBndr; we do not
+ -- want to complain about a levity-polymorphic binder
+ ; (env', new_co_fn) <- zonkCoFn env co_fn
+ ; new_ms <- zonkMatchGroup env' zonkLExpr ms
+ ; return $ L loc $
+ bind { fun_id = L mloc new_mono_id
+ , fun_matches = new_ms
+ , fun_co_fn = new_co_fn } }
+ | otherwise
+ = zonk_lbind env lbind -- The normal case
+
+ zonk_export env (ABE{ abe_wrap = wrap
+ , abe_poly = poly_id
+ , abe_mono = mono_id
+ , abe_prags = prags })
= do new_poly_id <- zonkIdBndr env poly_id
(_, new_wrap) <- zonkCoFn env wrap
new_prags <- zonkSpecPrags env prags
@@ -481,44 +501,6 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abe_mono = zonkIdOcc env mono_id
, abe_prags = new_prags })
-zonk_bind env outer_bind@(AbsBindsSig { abs_tvs = tyvars
- , abs_ev_vars = evs
- , abs_sig_export = poly
- , abs_sig_prags = prags
- , abs_sig_ev_bind = ev_bind
- , abs_sig_bind = lbind })
- | L bind_loc bind@(FunBind { fun_id = L loc local
- , fun_matches = ms
- , fun_co_fn = co_fn }) <- lbind
- = ASSERT( all isImmutableTyVar tyvars )
- do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
- ; (env1, new_evs) <- zonkEvBndrsX env0 evs
- ; (env2, new_ev_bind) <- zonkTcEvBinds env1 ev_bind
- -- Inline zonk_bind (FunBind ...) because we wish to skip
- -- the check for representation-polymorphic binders. The
- -- local binder in the FunBind in an AbsBindsSig is never actually
- -- bound in Core -- indeed, that's the whole point of AbsBindsSig.
- -- just calling zonk_bind causes #11405.
- ; new_local <- updateVarTypeM (zonkTcTypeToType env2) local
- ; (env3, new_co_fn) <- zonkCoFn env2 co_fn
- ; new_ms <- zonkMatchGroup env3 zonkLExpr ms
- -- If there is a representation polymorphism problem, it will
- -- be caught here:
- ; new_poly_id <- zonkIdBndr env2 poly
- ; new_prags <- zonkSpecPrags env2 prags
- ; let new_val_bind = L bind_loc (bind { fun_id = L loc new_local
- , fun_matches = new_ms
- , fun_co_fn = new_co_fn })
- ; return (AbsBindsSig { abs_tvs = new_tyvars
- , abs_ev_vars = new_evs
- , abs_sig_export = new_poly_id
- , abs_sig_prags = new_prags
- , abs_sig_ev_bind = new_ev_bind
- , abs_sig_bind = new_val_bind }) }
-
- | otherwise
- = pprPanic "zonk_bind" (ppr outer_bind)
-
zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
, psb_args = details
, psb_def = lpat
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index dc8eb0ce9d..fe513f4f59 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -889,7 +889,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
, abs_ev_vars = dfun_ev_vars
, abs_exports = [export]
, abs_ev_binds = []
- , abs_binds = unitBag dict_bind }
+ , abs_binds = unitBag dict_bind
+ , abs_sig = True }
; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds)
}
@@ -1037,7 +1038,8 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
, abs_ev_vars = dfun_evs
, abs_exports = [export]
, abs_ev_binds = [dfun_ev_binds, local_ev_binds]
- , abs_binds = emptyBag }
+ , abs_binds = emptyBag
+ , abs_sig = False }
; return (sc_top_id, L loc bind, sc_implic) }
-------------------
@@ -1374,17 +1376,18 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
; spec_prags <- tcSpecPrags global_meth_id prags
; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
- export = ABE { abe_poly = global_meth_id
- , abe_mono = local_meth_id
- , abe_wrap = idHsWrapper
- , abe_prags = specs }
+ export = ABE { abe_poly = global_meth_id
+ , abe_mono = local_meth_id
+ , abe_wrap = idHsWrapper
+ , abe_prags = specs }
local_ev_binds = TcEvBinds ev_binds_var
full_bind = AbsBinds { abs_tvs = tyvars
, abs_ev_vars = dfun_ev_vars
, abs_exports = [export]
, abs_ev_binds = [dfun_ev_binds, local_ev_binds]
- , abs_binds = tc_bind }
+ , abs_binds = tc_bind
+ , abs_sig = True }
; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
where
@@ -1429,7 +1432,8 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
; return (unitBag $ L (getLoc meth_bind) $
AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_exports = [export]
- , abs_binds = tc_bind, abs_ev_binds = [] }) }
+ , abs_binds = tc_bind, abs_ev_binds = []
+ , abs_sig = True }) }
| otherwise -- No instance signature
= do { let ctxt = FunSigCtxt sel_name False
diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs
index fc0a71ade3..f1a619be1a 100644
--- a/testsuite/tests/ghc-api/T6145.hs
+++ b/testsuite/tests/ghc-api/T6145.hs
@@ -34,8 +34,6 @@ main = do
where
isDataCon (L _ (AbsBinds { abs_binds = bs }))
= not (isEmptyBag (filterBag isDataCon bs))
- isDataCon (L _ (AbsBindsSig { abs_sig_bind = b }))
- = isDataCon b
isDataCon (L l (f@FunBind {}))
| (MG (L _ (m:_)) _ _ _) <- fun_matches f,
(L _ (c@ConPatOut{}):_)<-hsLMatchPats m,
diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
index 663a7d7f2e..d96c448cf9 100644
--- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
@@ -275,5 +275,6 @@
(FromSource))
(WpHole) {NameSet:
[]}
- []))]}))]}
+ []))]}
+ (False)))]}
diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs
index c4db3ca212..f74c7514db 100644
--- a/utils/ghctags/Main.hs
+++ b/utils/ghctags/Main.hs
@@ -284,7 +284,6 @@ boundThings modname lbinding =
PatBind { pat_lhs = lhs } -> patThings lhs []
VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
AbsBinds { } -> [] -- nothing interesting in a type abstraction
- AbsBindsSig { } -> []
PatSynBind PSB{ psb_id = id } -> [thing id]
where thing = foundOfLName modname
patThings lpat tl =
View Lorry Controller Status