Commit c6485d5e authored by Simon Peyton Jones's avatar Simon Peyton Jones

Simplify AbsBinds wrapping

In poking Trac #11414 I found myself sinking into the abe_inst_wrap
swamp.  What is this strange thing?  (It turned out that #11414 was
breaking because of it.)

Thrillingly, I found a way to sweep it away again, putting the deep
instantation into tcMonoBinds instead of mkExport; and it turned out
that the fun_co_fn field of FunBind was already there ready to receive
exactly this wrapper. Hooray.  Result

* Death to abe_inst_wrap
* Death to mbi_orig
* Death to the plumbing in tcPolyInfer that did the
  deep instantiation

I did find that I had to re-engineer the treatment of instance type
signatures (again), but the result looks more modular and robust to
me.

And #11414 is fixed.
parent f3b9db31
......@@ -160,39 +160,37 @@ dsHsBind dflags
(AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = [export]
, abs_ev_binds = ev_binds, abs_binds = binds })
| ABE { abe_inst_wrap = inst_wrap, abe_wrap = wrap, abe_poly = global
| ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = prags } <- export
, not (xopt LangExt.Strict dflags) -- handle strict binds
, not (anyBag (isBangedPatBind . unLoc) binds) -- in the next case
= -- push type constraints deeper for pattern match check
-- See Note [AbsBinds wrappers] in HsBinds
, not (xopt LangExt.Strict dflags) -- Handle strict binds
, not (anyBag (isBangedPatBind . unLoc) binds) -- in the next case
= -- See Note [AbsBinds wrappers] in HsBinds
addDictsDs (toTcTypeBag (listToBag dicts)) $
do { (_, bind_prs) <- ds_lhs_binds binds
; let core_bind = Rec bind_prs
; ds_binds <- dsTcEvBinds_s ev_binds
; inner_rhs <- dsHsWrapper inst_wrap $
Let core_bind $
Var local
; rhs <- dsHsWrapper wrap $ -- Usually the identity
mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
inner_rhs
-- addDictsDs: push type constraints deeper for pattern match check
do { (_, bind_prs) <- ds_lhs_binds binds
; let core_bind = Rec bind_prs
; ds_binds <- dsTcEvBinds_s ev_binds
; rhs <- dsHsWrapper wrap $ -- Usually the identity
mkLams tyvars $ mkLams dicts $
mkCoreLets ds_binds $
Let core_bind $
Var local
; (spec_binds, rules) <- dsSpecs rhs prags
; (spec_binds, rules) <- dsSpecs rhs prags
; let global' = addIdSpecialisations global rules
main_bind = makeCorePair dflags global' (isDefaultMethod prags)
(dictArity dicts) rhs
; let global' = addIdSpecialisations global rules
main_bind = makeCorePair dflags global' (isDefaultMethod prags)
(dictArity dicts) rhs
; return ([], main_bind : fromOL spec_binds) }
; return ([], main_bind : fromOL spec_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]
= -- push type constraints deeper for pattern match check
addDictsDs (toTcTypeBag (listToBag dicts)) $
= addDictsDs (toTcTypeBag (listToBag dicts)) $
-- addDictsDs: push type constraints deeper for pattern match check
do { (local_force_vars, bind_prs) <- ds_lhs_binds binds
; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
| (lcl_id, rhs) <- bind_prs ]
......@@ -215,17 +213,15 @@ dsHsBind dflags
-- Note [Desugar Strict binds]
; (exported_force_vars, extra_exports) <- get_exports local_force_vars
; let mk_bind (ABE { abe_inst_wrap = inst_wrap, abe_wrap = wrap
; 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
; inner_rhs <- dsHsWrapper inst_wrap $
mkTupleSelector all_locals local tup_id $
mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
; rhs <- dsHsWrapper wrap $
mkLams tyvars $ mkLams dicts $
inner_rhs
mkTupleSelector all_locals local tup_id $
mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
; let global' = (global `setInlinePragma` defaultInlinePragma)
......@@ -284,10 +280,9 @@ dsHsBind dflags
return (ABE {abe_poly = global
,abe_mono = local
,abe_wrap = WpHole
,abe_inst_wrap = WpHole
,abe_prags = SpecPrags []})
-- this is a combination of AbsBinds and FunBind
-- 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
......@@ -298,6 +293,7 @@ dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
, fun_tick = tick } <- bind
= putSrcSpanDs bind_loc $
addDictsDs (toTcTypeBag (listToBag dicts)) $
-- addDictsDs: push type constraints deeper for pattern match check
do { (args, body) <- matchWrapper (FunRhs (idName global)) Nothing matches
; let body' = mkOptTickBox tick body
; fun_rhs <- dsHsWrapper co_fn $
......
......@@ -246,10 +246,8 @@ deriving instance (DataId idL, DataId idR)
data ABExport id
= ABE { abe_poly :: id -- ^ Any INLINE pragmas is attached to this Id
, abe_mono :: id
, abe_inst_wrap :: HsWrapper -- ^ See Note [AbsBinds wrappers]
-- ^ Shape: abe_mono ~ abe_insted
, abe_wrap :: HsWrapper -- ^ See Note [AbsBinds wrappers]
-- Shape: (forall abs_tvs. abs_ev_vars => abe_insted) ~ abe_poly
, abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper]
-- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
, abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
} deriving (Data, Typeable)
......@@ -367,9 +365,8 @@ bindings only when
lacks a user type signature
* The group forms a strongly connected component
Note [AbsBinds wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~
Note [ABExport wrapper]
~~~~~~~~~~~~~~~~~~~~~~~
Consider
(f,g) = (\x.x, \y.y)
This ultimately desugars to something like this:
......@@ -385,27 +382,6 @@ The abe_wrap field deals with impedance-matching between
and the thing we really want, which may have fewer type
variables. The action happens in TcBinds.mkExport.
For abe_inst_wrap, consider this:
x = (*)
The abe_mono type will be forall a. Num a => a -> a -> a
because no instantiation happens during typechecking. Before inferring
a final type, we must instantiate this. See Note [Instantiate when inferring
a type] in TcBinds. The abe_inst_wrap takes the uninstantiated abe_mono type
to a proper instantiated type. In this case, the "abe_insted" is
(b -> b -> b). Note that the value of "abe_insted" isn't important; it's
just an intermediate form as we're going from abe_mono to abe_poly. See also
the desugaring code in DsBinds.
It's conceivable that we could combine the two wrappers, but note that there
is a gap: neither wrapper tacks on the tvs and dicts from the outer AbsBinds.
These bits are added manually in desugaring. (See DsBinds.dsHsBind.) A problem
that would arise in combining them is that zonking becomes more challenging:
we want to zonk the tvs and dicts in the AbsBinds, but then we end up re-zonking
when we zonk the ABExport. And -- worse -- the combined wrapper would have
the tvs and dicts in binding positions, so they would shadow the original
tvs and dicts. This is all resolvable with some plumbing, but it seems simpler
just to keep the two wrappers distinct.
Note [Bind free vars]
~~~~~~~~~~~~~~~~~~~~~
The bind_fvs field of FunBind and PatBind records the free variables
......@@ -592,12 +568,10 @@ ppr_monobind (AbsBindsSig { abs_tvs = tyvars
ppr bind
instance (OutputableBndr id) => Outputable (ABExport id) where
ppr (ABE { abe_wrap = wrap, abe_inst_wrap = inst_wrap
, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
= vcat [ ppr gbl <+> text "<=" <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
, nest 2 (ppr wrap)
, nest 2 (ppr inst_wrap)]
, nest 2 (text "wrap:" <+> ppr wrap)]
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where
ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir })
......
This diff is collapsed.
......@@ -253,7 +253,6 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
-- completeSigPolyId
, abe_mono = completeIdSigPolyId local_dm_sig
, abe_wrap = idHsWrapper
, abe_inst_wrap = idHsWrapper
, abe_prags = IsDefaultMethod }
full_bind = AbsBinds { abs_tvs = tyvars
, abs_ev_vars = [this_dict]
......
......@@ -438,14 +438,13 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abs_ev_binds = new_ev_binds
, abs_exports = new_exports, abs_binds = new_val_bind }) }
where
zonkExport env (ABE{ abe_wrap = wrap, abe_inst_wrap = inst_wrap
zonkExport 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_inst_wrap) <- zonkCoFn env inst_wrap
new_prags <- zonkSpecPrags env prags
return (ABE{ abe_wrap = new_wrap, abe_inst_wrap = new_inst_wrap
return (ABE{ abe_wrap = new_wrap
, abe_poly = new_poly_id
, abe_mono = zonkIdOcc env mono_id
, abe_prags = new_prags })
......
This diff is collapsed.
......@@ -104,4 +104,4 @@ test('T10251', normal, compile, [''])
test('T10767', normal, compile, [''])
test('DsStrictWarn', normal, compile, [''])
test('T10662', normal, compile, ['-Wall'])
test('T11414', expect_broken(11414), compile, [''])
test('T11414', normal, compile, [''])
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