mkCompulsoryUnfolding (Lit nullAddrLit)
------------------------------------------------
-seqId :: Id
--- 'seq' is very special. See notes with
--- See DsUtils.lhs Note [Desugaring seq (1)] and
--- Note [Desugaring seq (2)] and
--- Fixity is set in LoadIface.ghcPrimIface
+seqId :: Id -- See Note [seqId magic]
seqId = pcMiscPrelId seqName ty info
where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
\end{code}
+Note [seqId magic]
+~~~~~~~~~~~~~~~~~~
+'seq' is special in several ways.
+
+a) Its second arg can have an unboxed type
+ x `seq` (v +# w)
+
+b) Its fixity is set in LoadIface.ghcPrimIface
+
+c) It has quite a bit of desugaring magic.
+ See DsUtils.lhs Note [Desugaring seq (1)] and (2) and (3)
+
+d) There is some special rule handing: Note [RULES for seq]
+
+Note [Rules for seq]
+~~~~~~~~~~~~~~~~~~~~
+Roman found situations where he had
+ case (f n) of _ -> e
+where he knew that f (which was strict in n) would terminate if n did.
+Notice that the result of (f n) is discarded. So it makes sense to
+transform to
+ case n of _ -> e
+
+Rather than attempt some general analysis to support this, I've added
+enough support that you can do this using a rewrite rule:
+
+ RULE "f/seq" forall n. seq (f n) e = seq n e
+
+You write that rule. When GHC sees a case expression that discards
+its result, it mentally transforms it to a call to 'seq' and looks for
+a RULE. (This is done in Simplify.rebuildCase.) As usual, the
+correctness of the rule is up to you.
+
+To make this work, we need to be careful that the magical desugaring
+done in Note [seqId magic] item (c) is *not* done on the LHS of a rule.
+Or rather, we arrange to un-do it, in DsBinds.decomposeRuleLhs.
+
+
Note [lazyId magic]
~~~~~~~~~~~~~~~~~~~
lazy :: forall a?. a? -> a? (i.e. works for unboxed types too)
-- * Constructing normal syntax
mkCoreLet, mkCoreLets,
mkCoreApp, mkCoreApps, mkCoreConApps,
- mkCoreLams, mkWildCase, mkIfThenElse,
+ mkCoreLams, mkWildCase, mkWildBinder, mkIfThenElse,
-- * Constructing boxed literals
mkWordExpr, mkWordExprWord,
-----------
mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
-mk_val_app (Var f `App` Type ty1 `App` Type _ `App` arg1) arg2 _ res_ty
- | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)]
- = Case arg1 case_bndr res_ty [(DEFAULT,[],arg2)]
- where
- case_bndr = case arg1 of
- Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)]
- _ -> mkWildBinder ty1
-
mk_val_app fun arg arg_ty _ -- See Note [CoreSyn let/app invariant]
| not (needsCaseBinding arg_ty arg)
= App fun arg -- The vastly common case
(DataAlt trueDataCon, [], then_expr) ]
\end{code}
-Note [Desugaring seq (1)] cf Trac #1031
-~~~~~~~~~~~~~~~~~~~~~~~~~
- f x y = x `seq` (y `seq` (# x,y #))
-
-The [CoreSyn let/app invariant] means that, other things being equal, because
-the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
-
- f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
-
-But that is bad for two reasons:
- (a) we now evaluate y before x, and
- (b) we can't bind v to an unboxed pair
-
-Seq is very, very special! So we recognise it right here, and desugar to
- case x of _ -> case y of _ -> (# x,y #)
-
-Note [Desugaring seq (2)] cf Trac #2231
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- let chp = case b of { True -> fst x; False -> 0 }
- in chp `seq` ...chp...
-Here the seq is designed to plug the space leak of retaining (snd x)
-for too long.
-
-If we rely on the ordinary inlining of seq, we'll get
- let chp = case b of { True -> fst x; False -> 0 }
- case chp of _ { I# -> ...chp... }
-
-But since chp is cheap, and the case is an alluring contet, we'll
-inline chp into the case scrutinee. Now there is only one use of chp,
-so we'll inline a second copy. Alas, we've now ruined the purpose of
-the seq, by re-introducing the space leak:
- case (case b of {True -> fst x; False -> 0}) of
- I# _ -> ...case b of {True -> fst x; False -> 0}...
-
-We can try to avoid doing this by ensuring that the binder-swap in the
-case happens, so we get his at an early stage:
- case chp of chp2 { I# -> ...chp2... }
-But this is fragile. The real culprit is the source program. Perhaps we
-should have said explicitly
- let !chp2 = chp in ...chp2...
-
-But that's painful. So the code here does a little hack to make seq
-more robust: a saturated application of 'seq' is turned *directly* into
-the case expression. So we desugar to:
- let chp = case b of { True -> fst x; False -> 0 }
- case chp of chp { I# -> ...chp... }
-Notice the shadowing of the case binder! And now all is well.
-
-The reason it's a hack is because if you define mySeq=seq, the hack
-won't work on mySeq.
-
-Note [Desugaring seq (3)] cf Trac #2409
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The isLocalId ensures that we don't turn
- True `seq` e
-into
- case True of True { ... }
-which stupidly tries to bind the datacon 'True'.
-\begin{code}
--- The functions from this point don't really do anything cleverer than
--- their counterparts in CoreSyn, but they are here for consistency
+The functions from this point don't really do anything cleverer than
+their counterparts in CoreSyn, but they are here for consistency
+\begin{code}
-- | Create a lambda where the given expression has a number of variables
-- bound over it. The leftmost binder is that bound by the outermost
-- lambda in the result
import CostCentre
import Module
import Id
+import MkId ( seqId )
import Var ( Var, TyVar )
import VarSet
import Rules
-- 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)
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.
+
%************************************************************************
%* *
= uncurry mkLams <$> matchWrapper LambdaExpr a_Match
dsExpr (HsApp fun arg)
- = mkCoreApp <$> dsLExpr fun <*> dsLExpr arg
+ = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
\end{code}
Operator sections. At first it looks as if we can convert
\begin{code}
dsExpr (OpApp e1 op _ e2)
= -- for the type of y, we need the type of op's 2nd argument
- mkCoreApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
+ mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
- = mkCoreApp <$> dsLExpr op <*> dsLExpr expr
+ = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
-- dsLExpr (SectionR op expr) -- \ x -> op x expr
dsExpr (SectionR op expr) = do
x_id <- newSysLocalDs x_ty
y_id <- newSysLocalDs y_ty
return (bindNonRec y_id y_core $
- Lam x_id (mkCoreApps core_op [Var x_id, Var y_id]))
+ Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
dsExpr (HsSCC cc expr) = do
mod_name <- getModuleDs
This module exports some utility functions of no great interest.
\begin{code}
-
-- | Utility functions for constructing Core syntax, principally for desugaring
module DsUtils (
EquationInfo(..),
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
wrapBind, wrapBinds,
- mkErrorAppDs,
+ mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs,
seqVar,
-- let var' = viewExpr var in mr
mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
mkViewMatchResult var' viewExpr var =
- adjustMatchResult (mkCoreLet (NonRec var' (mkCoreApp viewExpr (Var var))))
+ adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var))))
mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
mkEvalMatchResult var ty
return (mkApps (Var err_id) [Type ty, core_msg])
\end{code}
+'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
+
+Note [Desugaring seq (1)] cf Trac #1031
+~~~~~~~~~~~~~~~~~~~~~~~~~
+ f x y = x `seq` (y `seq` (# x,y #))
+
+The [CoreSyn let/app invariant] means that, other things being equal, because
+the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
+
+ f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
+
+But that is bad for two reasons:
+ (a) we now evaluate y before x, and
+ (b) we can't bind v to an unboxed pair
+
+Seq is very, very special! So we recognise it right here, and desugar to
+ case x of _ -> case y of _ -> (# x,y #)
+
+Note [Desugaring seq (2)] cf Trac #2231
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ let chp = case b of { True -> fst x; False -> 0 }
+ in chp `seq` ...chp...
+Here the seq is designed to plug the space leak of retaining (snd x)
+for too long.
+
+If we rely on the ordinary inlining of seq, we'll get
+ let chp = case b of { True -> fst x; False -> 0 }
+ case chp of _ { I# -> ...chp... }
+
+But since chp is cheap, and the case is an alluring contet, we'll
+inline chp into the case scrutinee. Now there is only one use of chp,
+so we'll inline a second copy. Alas, we've now ruined the purpose of
+the seq, by re-introducing the space leak:
+ case (case b of {True -> fst x; False -> 0}) of
+ I# _ -> ...case b of {True -> fst x; False -> 0}...
+
+We can try to avoid doing this by ensuring that the binder-swap in the
+case happens, so we get his at an early stage:
+ case chp of chp2 { I# -> ...chp2... }
+But this is fragile. The real culprit is the source program. Perhaps we
+should have said explicitly
+ let !chp2 = chp in ...chp2...
+
+But that's painful. So the code here does a little hack to make seq
+more robust: a saturated application of 'seq' is turned *directly* into
+the case expression. So we desugar to:
+ let chp = case b of { True -> fst x; False -> 0 }
+ case chp of chp { I# -> ...chp... }
+Notice the shadowing of the case binder! And now all is well.
+
+The reason it's a hack is because if you define mySeq=seq, the hack
+won't work on mySeq.
+
+Note [Desugaring seq (3)] cf Trac #2409
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The isLocalId ensures that we don't turn
+ True `seq` e
+into
+ case True of True { ... }
+which stupidly tries to bind the datacon 'True'.
+
+\begin{code}
+mkCoreAppDs :: CoreExpr -> CoreExpr -> CoreExpr
+mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
+ | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)]
+ = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
+ where
+ case_bndr = case arg1 of
+ Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)]
+ _ -> mkWildBinder ty1
+
+mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore
+
+mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
+mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
+\end{code}
+
+
%************************************************************************
%* *
\subsection[mkSelectorBind]{Make a selector bind}
import SimplUtils
import FamInstEnv ( FamInstEnv )
import Id
-import MkId ( mkImpossibleExpr )
+import MkId ( mkImpossibleExpr, seqId )
import Var
import IdInfo
import Coercion
import CoreUtils
import CoreArity ( exprArity )
import Rules ( lookupRule, getRules )
-import BasicTypes ( isMarkedStrict )
+import BasicTypes ( isMarkedStrict, Arity )
import CostCentre ( currentCCS )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
completeCall env var cont
- = do { dflags <- getDOptsSmpl
- ; let (args,call_cont) = contArgs cont
+ = do { let (args,call_cont) = contArgs cont
-- The args are OutExprs, obtained by *lazily* substituting
-- in the args found in cont. These args are only examined
-- to limited depth (unless a rule fires). But we must do
-- We used to use the black-listing mechanism to ensure that inlining of
-- the wrapper didn't occur for things that have specialisations till a
-- later phase, so but now we just try RULES first
- --
- -- Note [Rules for recursive functions]
- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- -- You might think that we shouldn't apply rules for a loop breaker:
- -- doing so might give rise to an infinite loop, because a RULE is
- -- rather like an extra equation for the function:
- -- RULE: f (g x) y = x+y
- -- Eqn: f a y = a-y
- --
- -- But it's too drastic to disable rules for loop breakers.
- -- Even the foldr/build rule would be disabled, because foldr
- -- is recursive, and hence a loop breaker:
- -- foldr k z (build g) = g k z
- -- So it's up to the programmer: rules can cause divergence
- ; rule_base <- getSimplRules
- ; let in_scope = getInScope env
- rules = getRules rule_base var
- maybe_rule = case activeRule dflags env of
- Nothing -> Nothing -- No rules apply
- Just act_fn -> lookupRule act_fn in_scope
- var args rules
- ; case maybe_rule of {
- Just (rule, rule_rhs) -> do
- tick (RuleFired (ru_name rule))
- (if dopt Opt_D_dump_rule_firings dflags then
- pprTrace "Rule fired" (vcat [
- text "Rule:" <+> ftext (ru_name rule),
- text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
- text "After: " <+> pprCoreExpr rule_rhs,
- text "Cont: " <+> ppr call_cont])
- else
- id) $
- simplExprF env rule_rhs (dropArgs (ruleArity rule) cont)
+ --
+ -- See also Note [Rules for recursive functions]
+ ; mb_rule <- tryRules env var args call_cont
+ ; case mb_rule of {
+ Just (n_args, rule_rhs) -> simplExprF env rule_rhs (dropArgs n_args cont) ;
-- The ruleArity says how many args the rule consumed
+ ; Nothing -> do -- No rules
- ; Nothing -> do -- No rules
------------- Next try inlining ----------------
- { let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
+ { dflags <- getDOptsSmpl
+ ; let arg_infos = [interestingArg arg | arg <- args, isValArg arg]
n_val_args = length arg_infos
interesting_cont = interestingCallContext call_cont
active_inline = activeInline env var
discard the entire application and replace it with (error "foo"). Getting
all this at once is TOO HARD!
+
+%************************************************************************
+%* *
+ Rewrite rules
+%* *
+%************************************************************************
+
+\begin{code}
+tryRules :: SimplEnv -> Id -> [OutExpr] -> SimplCont
+ -> SimplM (Maybe (Arity, CoreExpr)) -- The arity is the number of
+ -- args consumed by the rule
+tryRules env fn args call_cont
+ = do { dflags <- getDOptsSmpl
+ ; rule_base <- getSimplRules
+ ; let in_scope = getInScope env
+ rules = getRules rule_base fn
+ maybe_rule = case activeRule dflags env of
+ Nothing -> Nothing -- No rules apply
+ Just act_fn -> lookupRule act_fn in_scope
+ fn args rules
+ ; case (rules, maybe_rule) of {
+ ([], _) -> return Nothing ;
+ (_, Nothing) -> return Nothing ;
+ (_, Just (rule, rule_rhs)) -> do
+
+ { tick (RuleFired (ru_name rule))
+ ; (if dopt Opt_D_dump_rule_firings dflags then
+ pprTrace "Rule fired" (vcat [
+ text "Rule:" <+> ftext (ru_name rule),
+ text "Before:" <+> ppr fn <+> sep (map pprParendExpr args),
+ text "After: " <+> pprCoreExpr rule_rhs,
+ text "Cont: " <+> ppr call_cont])
+ else
+ id) $
+ return (Just (ruleArity rule, rule_rhs)) }}}
+\end{code}
+
+Note [Rules for recursive functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might think that we shouldn't apply rules for a loop breaker:
+doing so might give rise to an infinite loop, because a RULE is
+rather like an extra equation for the function:
+ RULE: f (g x) y = x+y
+ Eqn: f a y = a-y
+
+But it's too drastic to disable rules for loop breakers.
+Even the foldr/build rule would be disabled, because foldr
+is recursive, and hence a loop breaker:
+ foldr k z (build g) = g k z
+So it's up to the programmer: rules can cause divergence
+
+
%************************************************************************
%* *
Rebuilding a cse expression
---------------------------------------------------------
-- Eliminate the case if possible
-rebuildCase :: SimplEnv
- -> OutExpr -- Scrutinee
- -> InId -- Case binder
- -> [InAlt] -- Alternatives (inceasing order)
- -> SimplCont
- -> SimplM (SimplEnv, OutExpr)
+rebuildCase, reallyRebuildCase
+ :: SimplEnv
+ -> OutExpr -- Scrutinee
+ -> InId -- Case binder
+ -> [InAlt] -- Alternatives (inceasing order)
+ -> SimplCont
+ -> SimplM (SimplEnv, OutExpr)
--------------------------------------------------
-- 1. Eliminate the case if there's a known constructor
-- exprOkForSpeculation was intended for.
var_demanded_later _ = False
+rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
+ | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq'
+ = -- For this case, see Note [Rules for seq] in MkId
+ do { let rhs' = substExpr env rhs
+ out_args = [Type (substTy env (idType case_bndr)),
+ Type (exprType rhs'), scrut, rhs']
+ -- Lazily evaluated, so we don't do most of this
+ ; mb_rule <- tryRules env seqId out_args cont
+ ; case mb_rule of
+ Just (n_args, res) -> simplExprF (zapSubstEnv env)
+ (mkApps res (drop n_args out_args))
+ cont
+ Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
+
+rebuildCase env scrut case_bndr alts cont
+ = reallyRebuildCase env scrut case_bndr alts cont
--------------------------------------------------
-- 3. Catch-all case
--------------------------------------------------
-rebuildCase env scrut case_bndr alts cont
+reallyRebuildCase env scrut case_bndr alts cont
= do { -- Prepare the continuation;
-- The new subst_env is in place
(env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
import FunDeps
import TcMType
import TcType
-import MkCore
+import MkCore ( mkBigCoreTupTy )
import TyCon
import Type
import TypeRep
import VectCore
import VectMonad
-import MkCore
+import MkCore ( mkCoreTup, mkCoreTupTy, mkWildCase )
import CoreSyn
import CoreUtils
import Coercion
projects / ghc-hetmet.git / commitdiff