X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBinds.lhs;h=815c0d1cfb2222319b65e8e49b185cedd4b1ba26;hb=bf902b277afa1feff586f7d96178b59be2cfcfe2;hp=8cbcf81cc934e9b6e92f4fb225f42d8381ffe0c8;hpb=a3bab0506498db41853543558c52a4fda0d183af;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 8cbcf81..815c0d1 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -56,7 +56,6 @@ import OrdList import Bag import BasicTypes hiding ( TopLevel ) import FastString --- import StaticFlags ( opt_DsMultiTyVar ) import Util import MonadUtils @@ -98,7 +97,7 @@ dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardle ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr' | otherwise = var - ; return (unitOL (var', core_expr')) } + ; return (unitOL (makeCorePair var' False 0 core_expr')) } dsHsBind auto_scc (FunBind { fun_id = L _ fun, fun_matches = matches , fun_co_fn = co_fn, fun_tick = tick @@ -527,13 +526,14 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) where is_local_id = isJust mb_poly_rhs poly_rhs | Just rhs <- mb_poly_rhs - = rhs - | Just unfolding <- maybeUnfoldingTemplate (idUnfolding poly_id) - = unfolding + = rhs -- Local Id; this is its rhs + | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id) + = unfolding -- Imported Id; this is its unfolding + -- Use realIdUnfolding so we get the unfolding + -- even when it is a loop breaker. + -- We want to specialise recursive functions! | otherwise = pprPanic "dsImpSpecs" (ppr poly_id) - -- In the Nothing case the specialisation is for an imported Id - -- whose unfolding gives the RHS to be specialised - -- The type checker has checked that it has an unfolding + -- The type checker has checked that it *has* an unfolding specUnfolding :: (CoreExpr -> CoreExpr) -> Type -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))