projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Allow RULES for seq, and exploit them
[ghc-hetmet.git]
/
compiler
/
deSugar
/
DsBinds.lhs
diff --git
a/compiler/deSugar/DsBinds.lhs
b/compiler/deSugar/DsBinds.lhs
index
020b7b4
..
e65da3c
100644
(file)
--- a/
compiler/deSugar/DsBinds.lhs
+++ b/
compiler/deSugar/DsBinds.lhs
@@
-36,6
+36,7
@@
import TcType
import CostCentre
import Module
import Id
import CostCentre
import Module
import Id
+import MkId ( seqId )
import Var ( Var, TyVar )
import VarSet
import Rules
import Var ( Var, TyVar )
import VarSet
import Rules
@@
-163,14
+164,16
@@
dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
where B is the *non-recursive* binding
fl = fg a b
gl = gg b
where B is the *non-recursive* binding
fl = fg a b
gl = gg b
- h = h a b
+ h = h a b -- See (b); note shadowing!
Notice (a) g has a different number of type variables to f, so we must
use the mkArbitraryType thing to fill in the gaps.
We use a type-let to do that.
(b) The local variable h isn't in the exports, and rather than
Notice (a) g has a different number of type variables to f, so we must
use the mkArbitraryType thing to fill in the gaps.
We use a type-let to do that.
(b) The local variable h isn't in the exports, and rather than
- clone a fresh copy we simply replace h by (h a b).
+ clone a fresh copy we simply replace h by (h a b), where
+ the two h's have different types! Shadowing happens here,
+ which looks confusing but works fine.
(c) The result is *still* quadratic-sized if there are a lot of
small bindings. So if there are more than some small
(c) The result is *still* quadratic-sized if there are a lot of
small bindings. So if there are more than some small
@@
-474,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
-- 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)
decomp env body
= case collectArgs (simpleSubst env body) of
(Var fn, args) -> Just (fn, args)
@@
-514,17
+523,23
@@
addInlinePrags prags bndr rhs
(inl:_) -> addInlineInfo inl bndr rhs
addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
(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
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}
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.
+
%************************************************************************
%* *
%************************************************************************
%* *