diff options
Diffstat (limited to 'compiler/deSugar')
| -rw-r--r-- | compiler/deSugar/Coverage.hs | 6 | ||||
| -rw-r--r-- | compiler/deSugar/DsArrows.hs | 4 | ||||
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 30 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.hs | 8 | ||||
| -rw-r--r-- | compiler/deSugar/Match.hs | 2 |
5 files changed, 31 insertions, 19 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 57d77c7eef..2711925161 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -632,7 +632,7 @@ addTickHsExpr (ExprWithTySigOut e ty) = (addTickLHsExprNever e) -- No need to tick the inner expression (return ty) -- for expressions with signatures -addTickHsExpr e@(HsType _) = return e +addTickHsExpr e@(HsTypeOut _) = return e -- Others should never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) @@ -870,8 +870,8 @@ addTickHsCmd (HsCmdArrForm e fix cmdtop) = (return fix) (mapM (liftL (addTickHsCmdTop)) cmdtop) -addTickHsCmd (HsCmdCast co cmd) - = liftM2 HsCmdCast (return co) (addTickHsCmd cmd) +addTickHsCmd (HsCmdWrap w cmd) + = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd) -- Others should never happen in a command context. --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 56c44c59d5..cc831d7c05 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -614,9 +614,9 @@ dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do return (mkApps (App core_op (Type env_ty)) core_args, unionVarSets fv_sets) -dsCmd ids local_vars stack_ty res_ty (HsCmdCast coercion cmd) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids - wrapped_cmd <- dsHsWrapper (mkWpCastN coercion) core_cmd + wrapped_cmd <- dsHsWrapper wrap core_cmd return (wrapped_cmd, env_ids') dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 7bc12cb2bd..a79e9fa7e7 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -160,20 +160,23 @@ 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 { abe_inst_wrap = inst_wrap, 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 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 $ - Let core_bind $ - Var local + inner_rhs ; (spec_binds, rules) <- dsSpecs rhs prags @@ -212,13 +215,17 @@ dsHsBind dflags -- Note [Desugar Strict binds] ; (exported_force_vars, extra_exports) <- get_exports local_force_vars - ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global + ; let mk_bind (ABE { abe_inst_wrap = inst_wrap, 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 $ - mkTupleSelector all_locals local tup_id $ - mkVarApps (Var poly_tup_id) (tyvars ++ dicts) + mkLams tyvars $ mkLams dicts $ + inner_rhs ; 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) @@ -277,6 +284,7 @@ dsHsBind dflags return (ABE {abe_poly = global ,abe_mono = local ,abe_wrap = WpHole + ,abe_inst_wrap = WpHole ,abe_prags = SpecPrags []}) dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" @@ -963,10 +971,10 @@ dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds return (mkCoreLets bs e) dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e ; dsHsWrapper c1 e1 } -dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1 - ; e1 <- dsHsWrapper c1 (Var x) - ; e2 <- dsHsWrapper c2 (mkCoreAppDs (text "dsHsWrapper") e e1) - ; return (Lam x e2) } +dsHsWrapper (WpFun c1 c2 t1) e = do { x <- newSysLocalDs t1 + ; e1 <- dsHsWrapper c1 (Var x) + ; e2 <- dsHsWrapper c2 (mkCoreAppDs (text "dsHsWrapper") e e1) + ; return (Lam x e2) } dsHsWrapper (WpCast co) e = ASSERT(coercionRole co == Representational) return $ mkCastDs e co dsHsWrapper (WpEvLam ev) e = return $ Lam ev e diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 3b9a4cfbb0..999b945c0f 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -222,7 +222,10 @@ dsExpr (HsLamCase arg matches) ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code } dsExpr e@(HsApp fun arg) - = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg + -- ignore type arguments here; they're in the wrappers instead at this point + | isLHsTypeExpr arg = dsLExpr fun + | otherwise = mkCoreAppDs (text "HsApp" <+> ppr e) + <$> dsLExpr fun <*> dsLExpr arg {- @@ -718,7 +721,8 @@ dsExpr (EWildPat {}) = panic "dsExpr:EWildPat" dsExpr (EAsPat {}) = panic "dsExpr:EAsPat" dsExpr (EViewPat {}) = panic "dsExpr:EViewPat" dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat" -dsExpr (HsType {}) = panic "dsExpr:HsType" +dsExpr (HsType {}) = panic "dsExpr:HsType" -- removed by typechecker +dsExpr (HsTypeOut {}) = panic "dsExpr:HsTypeOut" -- handled in HsApp case dsExpr (HsDo {}) = panic "dsExpr:HsDo" dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld" diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index b5a50e75af..7530a0a243 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -956,7 +956,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- equating different ways of writing a coercion) wrap WpHole WpHole = True wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' - wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2' + wrap (WpFun w1 w2 _) (WpFun w1' w2' _) = wrap w1 w1' && wrap w2 w2' wrap (WpCast co) (WpCast co') = co `eqCoercion` co' wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2 wrap (WpTyApp t) (WpTyApp t') = eqType t t' |