Commit 3c6635ef authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Fix #11405.

This adds a new variant of AbsBinds that is used solely for bindings
with a type signature. This allows for a simpler desugaring that
does not produce the bogus output that tripped up Core Lint in
ticket #11405. Should make other desugarings simpler, too.
parent 80b4c71c
......@@ -294,6 +294,29 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
| ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
, isAnyInlinePragma (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
add_inlines mono_id env
| isAnyInlinePragma (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
......
......@@ -154,8 +154,8 @@ dsHsBind dflags
-- A common case: one exported variable, only non-strict binds
-- Non-recursive bindings come through this way
-- So do self-recursive bindings, and recursive bindings
-- that have been chopped up with type signatures
-- 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]
......@@ -287,6 +287,44 @@ dsHsBind dflags
,abe_inst_wrap = WpHole
,abe_prags = SpecPrags []})
-- this 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)) $
do { (args, body) <- matchWrapper (FunRhs (idName global)) Nothing matches
; let body' = mkOptTickBox tick body
; fun_rhs <- dsHsWrapper co_fn $
mkLams args body'
; let force_vars
| xopt LangExt.Strict dflags
, matchGroupArity matches == 0 -- no need to force lambdas
= [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"
......
......@@ -143,6 +143,15 @@ 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 _ fun
, fun_matches = matches
, fun_co_fn = co_fn
......@@ -172,6 +181,8 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
unliftedMatchOnly :: HsBind Id -> Bool
unliftedMatchOnly (AbsBinds { abs_binds = lbinds })
= anyBag (unliftedMatchOnly . unLoc) lbinds
unliftedMatchOnly (AbsBindsSig { abs_sig_bind = L _ bind })
= unliftedMatchOnly bind
unliftedMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
= isUnLiftedType rhs_ty
|| isUnliftedLPat lpat
......
......@@ -1403,6 +1403,7 @@ 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 _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec)
-----------------------------------------------------------------------------
-- Since everything in a Bind is mutually recursive we need rename all
......
......@@ -205,6 +205,20 @@ data HsBindLR idL idR
abs_binds :: LHsBinds idL
}
| 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 :: idL, -- like abe_poly
abs_sig_prags :: TcSpecPrags,
abs_sig_ev_bind :: TcEvBinds, -- no list needed here
abs_sig_bind :: LHsBind idL -- always only one, and it's always a
-- FunBind
}
| PatSynBind (PatSynBind idL idR)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
-- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',
......@@ -550,7 +564,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, abs_exports = exports, abs_binds = val_binds
, abs_ev_binds = ev_binds })
= sdocWithDynFlags $ \ dflags ->
if gopt Opt_PrintTypechekerElaboration dflags then
if gopt Opt_PrintTypecheckerElaboration dflags then
-- Show extra information (bug number: #10662)
hang (ptext (sLit "AbsBinds") <+> brackets (interpp'SP tyvars)
<+> brackets (interpp'SP dictvars))
......@@ -563,6 +577,19 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, ptext (sLit "Evidence:") <+> ppr ev_binds ]
else
pprLHsBinds val_binds
ppr_monobind (AbsBindsSig { abs_tvs = tyvars
, abs_ev_vars = dictvars
, 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 "Bind:" <+> ppr bind
, text "Evidence:" <+> ppr ev_bind ]
else
ppr bind
instance (OutputableBndr id) => Outputable (ABExport id) where
ppr (ABE { abe_wrap = wrap, abe_inst_wrap = inst_wrap
......
......@@ -773,6 +773,7 @@ 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 =
if omitPatSyn then acc else ps : acc
......
......@@ -390,7 +390,7 @@ data GeneralFlag
| Opt_PrintUnicodeSyntax
| Opt_PrintExpandedSynonyms
| Opt_PrintPotentialInstances
| Opt_PrintTypechekerElaboration
| Opt_PrintTypecheckerElaboration
-- optimisation opts
| Opt_CallArity
......@@ -3047,7 +3047,7 @@ fFlags = [
flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax,
flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms,
flagSpec "print-potential-instances" Opt_PrintPotentialInstances,
flagSpec "print-typechecker-elaboration" Opt_PrintTypechekerElaboration,
flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration,
flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs,
flagSpec "prof-count-entries" Opt_ProfCountEntries,
flagSpec "regs-graph" Opt_RegsGraph,
......
......@@ -593,7 +593,7 @@ tcPolyCheck rec_tc prag_fn
-- there is was one. This will appear in messages like
-- "type variable x is bound by .. at <loc>"
name = idName poly_id
; (ev_binds, (binds', [mono_info]))
; (ev_binds, (binds', _))
<- setSrcSpan loc $
checkConstraints skol_info skol_tvs ev_vars $
tcMonoBinds rec_tc (\_ -> Just (TcIdSig sig)) LetLclBndr [bind]
......@@ -601,15 +601,17 @@ tcPolyCheck rec_tc prag_fn
; spec_prags <- tcSpecPrags poly_id prag_sigs
; poly_id <- addInlinePrags poly_id prag_sigs
; let export = ABE { abe_wrap = idHsWrapper
, abe_inst_wrap = idHsWrapper
, abe_poly = poly_id
, abe_mono = mbi_mono_id mono_info
, abe_prags = SpecPrags spec_prags }
abs_bind = L loc $ AbsBinds
; let bind' = case bagToList binds' of
[b] -> b
_ -> pprPanic "tcPolyCheck" (ppr binds')
abs_bind = L loc $ AbsBindsSig
{ abs_tvs = skol_tvs
, abs_ev_vars = ev_vars, abs_ev_binds = [ev_binds]
, abs_exports = [export], abs_binds = binds' }
, abs_ev_vars = ev_vars
, abs_sig_export = poly_id
, abs_sig_prags = SpecPrags spec_prags
, abs_sig_ev_bind = ev_binds
, abs_sig_bind = bind' }
; return (unitBag abs_bind, [poly_id]) }
tcPolyCheck _rec_tc _prag_fn sig _bind
......@@ -1916,7 +1918,7 @@ data GeneralisationPlan
| CheckGen (LHsBind Name) TcIdSigInfo
-- One binding with a signature
-- Explicit generalisation; there is an AbsBinds
-- Explicit generalisation; there is an AbsBindsSig
-- A consequence of the no-AbsBinds choice (NoGen) is that there is
-- no "polymorphic Id" and "monmomorphic Id"; there is just the one
......@@ -2006,6 +2008,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
&& no_sig (unLoc v)
restricted (PatSynBind {}) = panic "isRestrictedGroup/unrestricted PatSynBind"
restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
restricted (AbsBindsSig {}) = panic "isRestrictedGroup/unrestricted AbsBindsSig"
restricted_match (MG { mg_alts = L _ (L _ (Match _ [] _ _) : _ )}) = True
restricted_match _ = False
......@@ -2065,6 +2068,8 @@ checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
= null tvs && null evs
is_monomorphic (L _ (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs }))
= null tvs && null evs
is_monomorphic _ = True
check :: Bool -> MsgDoc -> TcM ()
......
......@@ -443,6 +443,26 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abe_mono = zonkIdOcc env mono_id
, abe_prags = new_prags })
zonk_bind env (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 = bind })
= 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
; new_val_bind <- zonk_lbind env2 bind
; new_poly_id <- zonkIdBndr env2 poly
; new_prags <- zonkSpecPrags env2 prags
; 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 }) }
zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
, psb_args = details
, psb_def = lpat
......
......@@ -12,5 +12,5 @@ test('TypeLevelVec',normal,compile, [''])
test('T9632', normal, compile, [''])
test('dynamic-paper', normal, compile, [''])
test('T11311', normal, compile, [''])
test('T11405', expect_broken(11405), compile, [''])
test('T11405', normal, compile, [''])
......@@ -31,9 +31,11 @@ main = do
return $ not $ isEmptyBag fs
removeFile "Test.hs"
print ok
where
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,
......
......@@ -279,7 +279,8 @@ boundThings modname lbinding =
FunBind { fun_id = id } -> [thing id]
PatBind { pat_lhs = lhs } -> patThings lhs []
VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
AbsBinds { } -> [] -- nothing interesting in a type abstraction
AbsBinds { } -> [] -- nothing interesting in a type abstraction
AbsBindsSig { } -> []
PatSynBind PSB{ psb_id = id } -> [thing id]
where thing = foundOfLName modname
patThings lpat tl =
......
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