diff options
Diffstat (limited to 'compiler/deSugar/DsBinds.hs')
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 443 |
1 files changed, 187 insertions, 256 deletions
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 5d9a33d660..421adcaccd 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -19,16 +19,18 @@ module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, #include "HsVersions.h" +import GhcPrelude + import {-# SOURCE #-} DsExpr( dsLExpr ) import {-# SOURCE #-} Match( matchWrapper ) import DsMonad import DsGRHSs import DsUtils +import Check ( checkGuardMatches ) import HsSyn -- lots of things import CoreSyn -- lots of things -import Literal ( Literal(MachStr) ) import CoreOpt ( simpleOptExpr ) import OccurAnal ( occurAnalyseExpr ) import MkCore @@ -47,11 +49,11 @@ import Coercion import TysWiredIn ( typeNatKind, typeSymbolKind ) import Id import MkId(proxyHashId) -import Class import Name import VarSet import Rules import VarEnv +import Var( EvVar, varType ) import Outputable import Module import SrcLoc @@ -62,6 +64,7 @@ import BasicTypes import DynFlags import FastString import Util +import UniqSet( nonDetEltsUniqSet ) import MonadUtils import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -79,7 +82,7 @@ dsTopLHsBinds binds -- see Note [Strict binds checks] | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds) = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds - ; mapBagM_ (top_level_err "strict pattern bindings") bang_binds + ; mapBagM_ (top_level_err "strict bindings") bang_binds ; return nilOL } | otherwise @@ -93,7 +96,7 @@ dsTopLHsBinds binds where unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds - bang_binds = filterBag (isBangedPatBind . unLoc) binds + bang_binds = filterBag (isBangedHsBind . unLoc) binds top_level_err desc (L loc bind) = putSrcSpanDs loc $ @@ -105,8 +108,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 +126,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 +140,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 @@ -154,17 +154,20 @@ dsHsBind dflags | xopt LangExt.Strict dflags , matchGroupArity matches == 0 -- no need to force lambdas = [id] - | isBangedBind b + | isBangedHsBind b = [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_ext = NPatBindTc _ ty + , pat_ticks = (rhs_tick, var_ticks) }) = do { body_expr <- dsGuarded grhss ty + ; checkGuardMatches PatBindGuards grhss ; let body' = mkOptTickBox rhs_tick body_expr pat' = decideBangHood dflags pat ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body' @@ -175,47 +178,75 @@ 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 (listToBag dicts) $ + dsLHsBinds binds + -- addDictsDs: push type constraints deeper + -- for inner pattern match check + -- See Check, Note [Type and Term Equality Propagation] + + ; 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" +dsHsBind _ (XHsBindsLR{}) = panic "dsHsBind: XHsBindsLR" + + +----------------------- +dsAbsBinds :: DynFlags + -> [TyVar] -> [EvVar] -> [ABExport GhcTc] + -> [CoreBind] -- Desugared evidence bindings + -> ([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 }) @@ -223,44 +254,38 @@ dsHsBind dflags ; return (makeCorePair dflags global (isDefaultMethod prags) 0 (core_wrap (Var local))) } + mk_bind (XABExport _) = panic "dsAbsBinds" ; 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 $ @@ -274,11 +299,12 @@ dsHsBind dflags -- the user written (local) function. The global -- Id is just the selector. Hmm. ; return ((global', rhs) : fromOL spec_binds) } + mk_bind (XABExport _) = panic "dsAbsBinds" - ; 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 +347,11 @@ 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_ext = noExt + , 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. @@ -384,15 +364,16 @@ dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) makeCorePair dflags gbl_id is_default_method dict_arity rhs - | is_default_method -- Default methods are *always* inlined + | is_default_method -- Default methods are *always* inlined + -- See Note [INLINE and default methods] in TcInstDcls = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs) | otherwise = case inlinePragmaSpec inline_prag of - EmptyInlineSpec -> (gbl_id, rhs) - NoInline -> (gbl_id, rhs) - Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) - Inline -> inline_pair + NoUserInline -> (gbl_id, rhs) + NoInline -> (gbl_id, rhs) + Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) + Inline -> inline_pair where inline_prag = idInlinePragma gbl_id @@ -631,7 +612,7 @@ We define an "unlifted bind" to be any bind that binds an unlifted id. Note that is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind. -Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedPatBind. +Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedHsBind. Define a "strict bind" to be either an unlifted bind or a banged bind. The restrictions are: @@ -680,7 +661,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) = putSrcSpanDs loc $ do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)) - ; return Nothing } -- Function is NOINLINE, and the specialiation inherits that + ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that -- See Note [Activation pragmas for SPECIALISE] | otherwise @@ -702,14 +683,14 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id -- , text "spec_co:" <+> ppr spec_co -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ - case decomposeRuleLhs spec_bndrs ds_lhs of { + dflags <- getDynFlags + ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of { Left msg -> do { warnDs NoReason msg; return Nothing } ; Right (rule_bndrs, _fn, args) -> do - { dflags <- getDynFlags - ; this_mod <- getModule + { this_mod <- getModule ; let fn_unf = realIdUnfolding poly_id - spec_unf = specUnfolding spec_bndrs core_app arity_decrease fn_unf + spec_unf = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf spec_id = mkLocalId spec_name spec_ty `setInlinePragma` inl_prag `setIdUnfolding` spec_unf @@ -841,14 +822,15 @@ SPEC f :: ty [n] INLINE [k] ************************************************************************ -} -decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr]) +decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr + -> Either SDoc ([Var], Id, [CoreExpr]) -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs -- may add some extra dictionary binders (see Note [Free dictionaries]) -- -- Returns an error message if the LHS isn't of the expected shape -- Note [Decomposing the left-hand side of a RULE] -decomposeRuleLhs orig_bndrs orig_lhs +decomposeRuleLhs dflags orig_bndrs orig_lhs | not (null unbound) -- Check for things unbound on LHS -- See Note [Unused spec binders] = Left (vcat (map dead_msg unbound)) @@ -869,7 +851,7 @@ decomposeRuleLhs orig_bndrs orig_lhs = Left bad_shape_msg where lhs1 = drop_dicts orig_lhs - lhs2 = simpleOptExpr lhs1 -- See Note [Simplify rule LHS] + lhs2 = simpleOptExpr dflags lhs1 -- See Note [Simplify rule LHS] (fun2,args2) = collectArgs lhs2 lhs_fvs = exprFreeVars lhs2 @@ -1040,7 +1022,7 @@ drop_dicts drops dictionary bindings on the LHS where possible. RULE forall s (d :: MonadAbstractIOST (ReaderT s)). useAbstractMonad (ReaderT s) d = $suseAbstractMonad s - Trac #8848 is a good example of where there are some intersting + Trac #8848 is a good example of where there are some interesting dictionary bindings to discard. The drop_dicts algorithm is based on these observations: @@ -1165,15 +1147,39 @@ dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this dsTcEvBinds (EvBinds bs) = dsEvBinds bs dsEvBinds :: Bag EvBind -> DsM [CoreBind] -dsEvBinds bs = mapM ds_scc (sccEvBinds bs) +dsEvBinds bs + = do { ds_bs <- mapBagM dsEvBind bs + ; return (mk_ev_binds ds_bs) } + +mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind] +-- We do SCC analysis of the evidence bindings, /after/ desugaring +-- them. This is convenient: it means we can use the CoreSyn +-- free-variable functions rather than having to do accurate free vars +-- for EvTerm. +mk_ev_binds ds_binds + = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges) where - ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r})) - = liftM (NonRec v) (dsEvTerm r) - ds_scc (CyclicSCC bs) = liftM Rec (mapM dsEvBind bs) + edges :: [ Node EvVar (EvVar,CoreExpr) ] + edges = foldrBag ((:) . mk_node) [] ds_binds + + mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr) + mk_node b@(var, rhs) + = DigraphNode { node_payload = b + , node_key = var + , node_dependencies = nonDetEltsUniqSet $ + exprFreeVars rhs `unionVarSet` + coVarsOfType (varType var) } + -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices + -- is still deterministic even if the edges are in nondeterministic order + -- as explained in Note [Deterministic SCC] in Digraph. + + ds_scc (AcyclicSCC (v,r)) = NonRec v r + ds_scc (CyclicSCC prs) = Rec prs dsEvBind :: EvBind -> DsM (Id, CoreExpr) dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) + {-********************************************************************** * * Desugaring EvTerms @@ -1181,41 +1187,15 @@ dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) **********************************************************************-} dsEvTerm :: EvTerm -> DsM CoreExpr -dsEvTerm (EvId v) = return (Var v) -dsEvTerm (EvCallStack cs) = dsEvCallStack cs -dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev -dsEvTerm (EvLit (EvNum n)) = mkNaturalExpr n -dsEvTerm (EvLit (EvStr s)) = mkStringExprFS s - -dsEvTerm (EvCast tm co) - = do { tm' <- dsEvTerm tm - ; return $ mkCastDs tm' co } - -dsEvTerm (EvDFunApp df tys tms) - = do { tms' <- mapM dsEvTerm tms - ; return $ Var df `mkTyApps` tys `mkApps` tms' } - -- The use of mkApps here is OK vis-a-vis levity polymorphism because - -- the terms are always evidence variables with types of kind Constraint - -dsEvTerm (EvCoercion co) = return (Coercion co) -dsEvTerm (EvSuperClass d n) - = do { d' <- dsEvTerm d - ; let (cls, tys) = getClassPredTys (exprType d') - sc_sel_id = classSCSelId cls n -- Zero-indexed - ; return $ Var sc_sel_id `mkTyApps` tys `App` d' } - -dsEvTerm (EvSelector sel_id tys tms) - = do { tms' <- mapM dsEvTerm tms - ; return $ Var sel_id `mkTyApps` tys `mkApps` tms' } - -dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg - -dsEvDelayedError :: Type -> FastString -> CoreExpr -dsEvDelayedError ty msg - = Var errorId `mkTyApps` [getRuntimeRep "dsEvTerm" ty, ty] `mkApps` [litMsg] - where - errorId = tYPE_ERROR_ID - litMsg = Lit (MachStr (fastStringToByteString msg)) +dsEvTerm (EvExpr e) = return e +dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev +dsEvTerm (EvFun { et_tvs = tvs, et_given = given + , et_binds = ev_binds, et_body = wanted_id }) + = do { ds_ev_binds <- dsTcEvBinds ev_binds + ; return $ (mkLams (tvs ++ given) $ + mkCoreLets ds_ev_binds $ + Var wanted_id) } + {-********************************************************************** * * @@ -1264,10 +1244,12 @@ ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) -- Note that we use the kind of the type, not the TyCon from which it -- is constructed since the latter may be kind polymorphic whereas the -- former we know is not (we checked in the solver). - ; return $ mkApps (Var mkTrCon) [ Type (typeKind ty) - , Type ty - , tc_rep - , kind_args ] + ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty) + , Type ty + , tc_rep + , kind_args ] + -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr + ; return expr } ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) @@ -1278,8 +1260,11 @@ ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). -- TypeRep a -> TypeRep b -> TypeRep (a b) ; let (k1, k2) = splitFunTy (typeKind t1) - ; return $ mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) - [ e1, e2 ] } + ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) + [ e1, e2 ] + -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr + ; return expr + } ds_ev_typeable ty (EvTypeableTrFun ev1 ev2) | Just (t1,t2) <- splitFunTy_maybe ty @@ -1288,15 +1273,16 @@ ds_ev_typeable ty (EvTypeableTrFun ev1 ev2) ; mkTrFun <- dsLookupGlobalId mkTrFunName -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). -- TypeRep a -> TypeRep b -> TypeRep (a -> b) - ; let r1 = getRuntimeRep "ds_ev_typeable" t1 - r2 = getRuntimeRep "ds_ev_typeable" t2 + ; let r1 = getRuntimeRep t1 + r2 = getRuntimeRep t2 ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2]) [ e1, e2 ] } ds_ev_typeable ty (EvTypeableTyLit ev) - = do { fun <- dsLookupGlobalId tr_fun - ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSym + = -- See Note [Typeable for Nat and Symbol] in TcInteract + do { fun <- dsLookupGlobalId tr_fun + ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty] ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) } where @@ -1332,58 +1318,3 @@ tyConRep tc ; return (Var tc_rep_id) } | otherwise = pprPanic "tyConRep" (ppr tc) - -{- Note [Memoising typeOf] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #3245, #9203 - -IMPORTANT: we don't want to recalculate the TypeRep once per call with -the proxy argument. This is what went wrong in #3245 and #9203. So we -help GHC by manually keeping the 'rep' *outside* the lambda. --} - - -{-********************************************************************** -* * - Desugaring EvCallStack evidence -* * -**********************************************************************-} - -dsEvCallStack :: EvCallStack -> DsM CoreExpr --- See Note [Overview of implicit CallStacks] in TcEvidence.hs -dsEvCallStack cs = do - df <- getDynFlags - m <- getModule - srcLocDataCon <- dsLookupDataCon srcLocDataConName - let mkSrcLoc l = - liftM (mkCoreConApps srcLocDataCon) - (sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m) - , mkStringExprFS (moduleNameFS $ moduleName m) - , mkStringExprFS (srcSpanFile l) - , return $ mkIntExprInt df (srcSpanStartLine l) - , return $ mkIntExprInt df (srcSpanStartCol l) - , return $ mkIntExprInt df (srcSpanEndLine l) - , return $ mkIntExprInt df (srcSpanEndCol l) - ]) - - emptyCS <- Var <$> dsLookupGlobalId emptyCallStackName - - pushCSVar <- dsLookupGlobalId pushCallStackName - let pushCS name loc rest = - mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest] - - let mkPush name loc tm = do - nameExpr <- mkStringExprFS name - locExpr <- mkSrcLoc loc - case tm of - EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS) - _ -> do tmExpr <- dsEvTerm tm - -- at this point tmExpr :: IP sym CallStack - -- but we need the actual CallStack to pass to pushCS, - -- so we use unwrapIP to strip the dictionary wrapper - -- See Note [Overview of implicit CallStacks] - let ip_co = unwrapIP (exprType tmExpr) - return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co)) - case cs of - EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm - EvCsEmpty -> return emptyCS |