Commit 90ce88a0 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Allow RULES for seq, and exploit them

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.

This patch implements the extra stuff.  I have not documented it explicitly
in the user manual yet... let's see how useful it is first.

The patch looks bigger than it is, because
  a) Comments; see esp MkId Note [seqId magic]

  b) Some refactoring.  Notably, I moved the special desugaring for
     seq from MkCore back into DsUtils where it properly belongs.
     (It's really a desugaring thing, not a CoreSyn invariant.)

  c) Annoyingly, in a RULE left-hand side we need to be careful that
     the magical desugaring done in MkId 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.
parent 1bca92d7
......@@ -904,11 +904,7 @@ nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
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
......@@ -927,6 +923,44 @@ lazyId = pcMiscPrelId lazyIdName ty info
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)
......
......@@ -4,7 +4,7 @@ module MkCore (
-- * Constructing normal syntax
mkCoreLet, mkCoreLets,
mkCoreApp, mkCoreApps, mkCoreConApps,
mkCoreLams, mkWildCase, mkIfThenElse,
mkCoreLams, mkWildCase, mkWildBinder, mkIfThenElse,
-- * Constructing boxed literals
mkWordExpr, mkWordExprWord,
......@@ -120,14 +120,6 @@ mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args
-----------
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
......@@ -167,69 +159,10 @@ mkIfThenElse guard then_expr else_expr
(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
......
......@@ -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)
......@@ -527,6 +534,12 @@ addInlineInfo (Inline prag is_inline) bndr rhs
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.
%************************************************************************
%* *
......
......@@ -216,7 +216,7 @@ dsExpr (HsLam a_Match)
= 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
......@@ -243,10 +243,10 @@ will sort it out.
\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
......@@ -258,7 +258,7 @@ 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
......
......@@ -8,7 +8,6 @@ Utilities for desugaring
This module exports some utility functions of no great interest.
\begin{code}
-- | Utility functions for constructing Core syntax, principally for desugaring
module DsUtils (
EquationInfo(..),
......@@ -23,7 +22,7 @@ module DsUtils (
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
wrapBind, wrapBinds,
mkErrorAppDs,
mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs,
seqVar,
......@@ -236,7 +235,7 @@ mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
-- 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
......@@ -402,6 +401,85 @@ mkErrorAppDs err_id ty msg = do
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}
......
......@@ -15,7 +15,7 @@ import SimplEnv
import SimplUtils
import FamInstEnv ( FamInstEnv )
import Id
import MkId ( mkImpossibleExpr )
import MkId ( mkImpossibleExpr, seqId )
import Var
import IdInfo
import Coercion
......@@ -28,7 +28,7 @@ import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) )
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 )
......@@ -1053,8 +1053,7 @@ simplVar env var cont
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
......@@ -1070,45 +1069,18 @@ completeCall env var cont
-- 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
......@@ -1214,6 +1186,58 @@ to get the effect that finding (error "foo") in a strict arg position will
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
......@@ -1310,12 +1334,13 @@ I don't really know how to improve this situation.
---------------------------------------------------------
-- 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
......@@ -1376,12 +1401,28 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
-- 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
......
......@@ -62,7 +62,7 @@ import InstEnv
import FunDeps
import TcMType
import TcType
import MkCore
import MkCore ( mkBigCoreTupTy )
import TyCon
import Type
import TypeRep
......
......@@ -22,7 +22,7 @@ module VectUtils (
import VectCore
import VectMonad
import MkCore
import MkCore ( mkCoreTup, mkCoreTupTy, mkWildCase )
import CoreSyn
import CoreUtils
import Coercion
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment