X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBinds.lhs;h=e65da3cf9ba13e161f746f46ea9174e62929e835;hp=4c144b8e507ba201100dc1f73fa38bec7f9f7bc6;hb=90ce88a0a9b5611416e592a6ff96781ba884975f;hpb=2dce32ca5188120ca220a36139ff216b852b389e diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 4c144b8..e65da3c 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -36,6 +36,7 @@ import TcType import CostCentre import Module import Id +import MkId ( seqId ) import Var ( Var, TyVar ) import VarSet import Rules @@ -476,6 +477,12 @@ decomposeRuleLhs lhs -- a LHS: let f71 = M.f Int in f71 decomp env (Let (NonRec dict rhs) body) = decomp (extendVarEnv env dict (simpleSubst env rhs)) body + + decomp env (Case scrut bndr ty [(DEFAULT, _, body)]) + | isDeadBinder bndr -- Note [Matching seqId] + = Just (seqId, [Type (idType bndr), Type ty, + simpleSubst env scrut, simpleSubst env body]) + decomp env body = case collectArgs (simpleSubst env body) of (Var fn, args) -> Just (fn, args) @@ -516,17 +523,23 @@ addInlinePrags prags bndr rhs (inl:_) -> addInlineInfo inl bndr rhs addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr) -addInlineInfo (Inline phase is_inline) bndr rhs - = (attach_phase bndr phase, wrap_inline is_inline rhs) +addInlineInfo (Inline prag is_inline) bndr rhs + = (attach_pragma bndr prag, wrap_inline is_inline rhs) where - attach_phase bndr phase - | isAlwaysActive phase = bndr -- Default phase - | otherwise = bndr `setInlinePragma` phase + attach_pragma bndr prag + | isDefaultInlinePragma prag = bndr + | otherwise = bndr `setInlinePragma` prag wrap_inline True body = mkInlineMe body wrap_inline False body = body \end{code} +Note [Matching seq] +~~~~~~~~~~~~~~~~~~~ +The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack +and this code turns it back into an application of seq! +See Note [Rules for seq] in MkId for the details. + %************************************************************************ %* *