else
completeLazyBind
-simplRecPair: [binder already simplified, but not its IdInfo]
+simplLazyBind: [binder already simplified, but not its IdInfo]
[used for both rec and top-lvl non-rec]
[must not be strict/unboxed; case not allowed]
- check for PreInlineUnconditionally
\begin{code}
dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule)
+dsRule in_scope (IfaceRuleOut fun rule) -- Built-in rules come this way
+ = returnDs (fun, rule)
+
dsRule in_scope (HsRule name act sig_tvs vars lhs rhs loc)
= putSrcLocDs loc $
ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
name -- Head of LHS
CoreRule
+isIfaceRuleDecl :: RuleDecl name pat -> Bool
isIfaceRuleDecl (HsRule _ _ _ _ _ _ _) = False
isIfaceRuleDecl other = True
fiExpr to_drop (_, AnnLam b body)
= case collect [b] body of
(bndrs, real_body)
- | all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
+-- | all is_ok bndrs -> mkLams bndrs (fiExpr to_drop real_body)
+-- [July 01: I'm experiment with getting the full laziness
+-- pass to floats bindings out past big lambdas (instead of the simplifier)
+-- so I don't want the float-in pass to just push them right back in.
+-- I'm going to try just dumping all bindings outside lambdas.]
| otherwise -> mkCoLets' to_drop (mkLams bndrs (fiExpr [] real_body))
where
collect bs (_, AnnLam b body) = collect (b:bs) body
collect bs body = (reverse bs, body)
- is_ok bndr = isTyVar bndr || isOneShotLambda bndr
+-- is_ok bndr = isTyVar bndr || isOneShotLambda bndr
\end{code}
We don't float lets inwards past an SCC.
import CoreSyn
import CoreUtils ( mkSCC )
-import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
+import CmdLineOpts ( DynFlags, DynFlag(..) )
import ErrUtils ( dumpIfSet_dyn )
import CostCentre ( dupifyCC, CostCentre )
import Id ( Id )
initEnv :: Int -> LibCaseEnv
initEnv bomb_size = LibCaseEnv bomb_size 0 emptyVarEnv emptyVarEnv []
-pprEnv :: LibCaseEnv -> SDoc
-pprEnv (LibCaseEnv _ lvl lvl_env _ scruts)
- = vcat [text "LibCaseEnv" <+> int lvl,
- fsep (map ppr (ufmToList lvl_env)),
- fsep (map ppr scruts)]
-
bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
\end{code}
import CoreUtils ( exprIsTrivial )
import Id ( isDataConId, isOneShotLambda, setOneShotLambda,
idOccInfo, setIdOccInfo,
- isExportedId, modifyIdInfo, idInfo,
+ isExportedId, modifyIdInfo, idInfo, idArity,
idSpecialisation, isLocalId,
idType, idUnique, Id
)
Here's the externally-callable interface:
\begin{code}
-occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
- -> CoreExpr
- -> (IdEnv OccInfo, -- Occ info for interesting free vars
- CoreExpr)
-
-occurAnalyseExpr interesting expr
- = occAnal initial_env expr
- where
- initial_env = OccEnv interesting emptyVarSet []
-
occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr
occurAnalyseGlobalExpr expr
= -- Top level expr, so no interesting free vars, and
-- discard occurence info returned
- snd (occurAnalyseExpr (\_ -> False) expr)
+ snd (occAnal (initOccEnv emptyVarSet) expr)
occurAnalyseRule :: CoreRule -> CoreRule
occurAnalyseRule rule@(BuiltinRule _ _) = rule
-occurAnalyseRule (Rule str tpl_vars tpl_args rhs)
+occurAnalyseRule (Rule str act tpl_vars tpl_args rhs)
-- Add occ info to tpl_vars, rhs
- = Rule str tpl_vars' tpl_args rhs'
+ = Rule str act tpl_vars' tpl_args rhs'
where
- (rhs_uds, rhs') = occurAnalyseExpr isLocalId rhs
+ (rhs_uds, rhs') = occAnal (initOccEnv (mkVarSet tpl_vars)) rhs
(_, tpl_vars') = tagBinders rhs_uds tpl_vars
\end{code}
occurAnalyseBinds binds
= binds'
where
- (_, _, binds') = go initialTopEnv binds
+ (_, _, binds') = go (initOccEnv emptyVarSet) binds
go :: OccEnv -> [CoreBind]
-> (UsageDetails, -- Occurrence info
other -> -- Ho ho! The normal case
(final_usage, ind_env, new_binds ++ binds')
-initialTopEnv = OccEnv isLocalId -- Anything local is interesting
- emptyVarSet
- []
-
-- Deal with any indirections
zapBind ind_env (NonRec bndr rhs)
occAnalRhs env id rhs
= (final_usage, rhs')
where
- (rhs_usage, rhs') = occAnal (zapCtxt env) rhs
+ (rhs_usage, rhs') = occAnal (rhsCtxt env) rhs
-- [March 98] A new wrinkle is that if the binder has specialisations inside
-- it then we count the specialised Ids as "extra rhs's". That way
\begin{code}
occAnal env app@(App fun arg)
- = occAnalApp env (collectArgs app)
+ = occAnalApp env (collectArgs app) False
-- Ignore type variables altogether
-- (a) occurrences inside type lambdas only not marked as InsideLam
-- Then, the simplifier is careful when partially applying lambdas.
occAnal env expr@(Lam _ _)
- = case occAnal (env_body `addNewCands` binders) body of { (body_usage, body') ->
+ = case occAnal env_body body of { (body_usage, body') ->
let
(final_usage, tagged_binders) = tagBinders body_usage binders
-- URGH! Sept 99: we don't seem to be able to use binders' here, because
(really_final_usage,
mkLams tagged_binders body') }
where
- (binders, body) = collectBinders expr
- (linear, env_body, _) = oneShotGroup env binders
+ (binders, body) = collectBinders expr
+ (linear, env1, _) = oneShotGroup env binders
+ env2 = env1 `addNewCands` binders -- Add in-scope binders
+ env_body = vanillaCtxt env2 -- Body is (no longer) an RhsContext
occAnal env (Case scrut bndr alts)
- = case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') ->
- case occAnal (zapCtxt env) scrut of { (scrut_usage, scrut') ->
+ = case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
+ case occAnal (vanillaCtxt env) scrut of { (scrut_usage, scrut') ->
+ -- No need for rhsCtxt
let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
alts_usage' = addCaseBndrUsage alts_usage
= case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
(foldr combineUsageDetails emptyDetails arg_uds_s, args')}
where
- arg_env = zapCtxt env
+ arg_env = vanillaCtxt env
\end{code}
Applications are dealt with specially because we want
\begin{code}
-- Hack for build, fold, runST
-occAnalApp env (Var fun, args)
+occAnalApp env (Var fun, args) is_rhs
= case args_stuff of { (args_uds, args') ->
let
final_uds = fun_uds `combineUsageDetails` args_uds
args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
| fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
| fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
- | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
-
- | isDataConId fun = case occAnalArgs env args of
- (arg_uds, args') -> (mapVarEnv markMany arg_uds, args')
- -- We mark the free vars of the argument of a constructor as "many"
- -- This means that nothing gets inlined into a constructor argument
- -- position, which is what we want. Typically those constructor
- -- arguments are just variables, or trivial expressions.
-
- | otherwise = occAnalArgs env args
-
-
-occAnalApp env (fun, args)
- = case occAnal (zapCtxt env) fun of { (fun_uds, fun') ->
- case occAnalArgs env args of { (args_uds, args') ->
+ | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
+ -- (foldr k z xs) may call k many times, but it never
+ -- shares a partial application of k; hence [False,True]
+ -- This means we can optimise
+ -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
+ -- by floating in the v
+
+ | isRhsEnv env,
+ isDataConId fun || valArgCount args < idArity fun
+ = case occAnalArgs env args of
+ (arg_uds, args') -> (mapVarEnv markMany arg_uds, args')
+ -- We mark the free vars of the argument of a constructor or PAP
+ -- as "many", if it is the RHS of a let(rec).
+ -- This means that nothing gets inlined into a constructor argument
+ -- position, which is what we want. Typically those constructor
+ -- arguments are just variables, or trivial expressions.
+
+ | otherwise = occAnalArgs env args
+
+
+occAnalApp env (fun, args) is_rhs
+ = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
+ -- The addAppCtxt is a bit cunning. One iteration of the simplifier
+ -- often leaves behind beta redexs like
+ -- (\x y -> e) a1 a2
+ -- Here we would like to mark x,y as one-shot, and treat the whole
+ -- thing much like a let. We do this by pushing some True items
+ -- onto the context stack.
+
+ case occAnalArgs env args of { (args_uds, args') ->
let
final_uds = fun_uds `combineUsageDetails` args_uds
in
(final_uds, mkApps fun' args') }}
-appSpecial :: OccEnv -> Int -> CtxtTy -> [CoreExpr] -> (UsageDetails, [CoreExpr])
+appSpecial :: OccEnv
+ -> Int -> CtxtTy -- Argument number, and context to use for it
+ -> [CoreExpr]
+ -> (UsageDetails, [CoreExpr])
appSpecial env n ctxt args
= go n args
where
+ arg_env = vanillaCtxt env
+
go n [] = (emptyDetails, []) -- Too few args
go 1 (arg:args) -- The magic arg
- = case occAnal (setCtxt env ctxt) arg of { (arg_uds, arg') ->
- case occAnalArgs env args of { (args_uds, args') ->
+ = case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') ->
+ case occAnalArgs env args of { (args_uds, args') ->
(combineUsageDetails arg_uds args_uds, arg':args') }}
go n (arg:args)
- = case occAnal env arg of { (arg_uds, arg') ->
+ = case occAnal arg_env arg of { (arg_uds, arg') ->
case go (n-1) args of { (args_uds, args') ->
(combineUsageDetails arg_uds args_uds, arg':args') }}
\end{code}
Case alternatives
~~~~~~~~~~~~~~~~~
+If the case binder occurs at all, the other binders effectively do too.
+For example
+ case e of x { (a,b) -> rhs }
+is rather like
+ let x = (a,b) in rhs
+If e turns out to be (e1,e2) we indeed get something like
+ let a = e1; b = e2; x = (a,b) in rhs
+
\begin{code}
-occAnalAlt env (con, bndrs, rhs)
+occAnalAlt env case_bndr (con, bndrs, rhs)
= case occAnal (env `addNewCands` bndrs) rhs of { (rhs_usage, rhs') ->
let
(final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
+ final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs
+ | otherwise = tagged_bndrs
+ -- Leave the binders untagged if the case
+ -- binder occurs at all; see note above
in
- (final_usage, (con, tagged_bndrs, rhs')) }
+ (final_usage, (con, final_bndrs, rhs')) }
\end{code}
%************************************************************************
%* *
-\subsection[OccurAnal-types]{Data types}
+\subsection[OccurAnal-types]{OccEnv}
%* *
%************************************************************************
\begin{code}
--- We gather inforamtion for variables that are either
--- (a) in scope or
--- (b) interesting
-
-data OccEnv =
- OccEnv (Id -> Bool) -- Tells whether an Id occurrence is interesting,
- IdSet -- In-scope Ids
- CtxtTy -- Tells about linearity
+data OccEnv
+ = OccEnv IdSet -- In-scope Ids; we gather info about these only
+ OccEncl -- Enclosing context information
+ CtxtTy -- Tells about linearity
+
+-- OccEncl is used to control whether to inline into constructor arguments
+-- For example:
+-- x = (p,q) -- Don't inline p or q
+-- y = /\a -> (p a, q a) -- Still don't inline p or q
+-- z = f (p,q) -- Do inline p,q; it may make a rule fire
+-- So OccEncl tells enought about the context to know what to do when
+-- we encounter a contructor application or PAP.
+
+data OccEncl
+ = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
+ -- Don't inline into constructor args here
+ | OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
+ -- Do inline into constructor args here
type CtxtTy = [Bool]
-- [] No info
-- be applied many times; but when it is,
-- the CtxtTy inside applies
+initOccEnv :: VarSet -> OccEnv
+initOccEnv vars = OccEnv vars OccRhs []
+
+isRhsEnv (OccEnv _ OccRhs _) = True
+isRhsEnv (OccEnv _ OccVanilla _) = False
+
isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv ifun cands _) id = id `elemVarSet` cands || ifun id
+isCandidate (OccEnv cands encl _) id = id `elemVarSet` cands
addNewCands :: OccEnv -> [Id] -> OccEnv
-addNewCands (OccEnv ifun cands ctxt) ids
- = OccEnv ifun (cands `unionVarSet` mkVarSet ids) ctxt
+addNewCands (OccEnv cands encl ctxt) ids
+ = OccEnv (cands `unionVarSet` mkVarSet ids) encl ctxt
addNewCand :: OccEnv -> Id -> OccEnv
-addNewCand (OccEnv ifun cands ctxt) id
- = OccEnv ifun (extendVarSet cands id) ctxt
+addNewCand (OccEnv cands encl ctxt) id
+ = OccEnv (extendVarSet cands id) encl ctxt
setCtxt :: OccEnv -> CtxtTy -> OccEnv
-setCtxt (OccEnv ifun cands _) ctxt = OccEnv ifun cands ctxt
+setCtxt (OccEnv cands encl _) ctxt = OccEnv cands encl ctxt
oneShotGroup :: OccEnv -> [CoreBndr] -> (Bool, OccEnv, [CoreBndr])
-- True <=> this is a one-shot linear lambda group
-- linearity context knows that c,n are one-shot, and it records that fact in
-- the binder. This is useful to guide subsequent float-in/float-out tranformations
-oneShotGroup (OccEnv ifun cands ctxt) bndrs
+oneShotGroup (OccEnv cands encl ctxt) bndrs
= case go ctxt bndrs [] of
- (new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv ifun cands new_ctxt, new_bndrs)
+ (new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv cands encl new_ctxt, new_bndrs)
where
is_one_shot b = isId b && isOneShotLambda b
go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
-zapCtxt env@(OccEnv ifun cands []) = env
-zapCtxt (OccEnv ifun cands _ ) = OccEnv ifun cands []
+vanillaCtxt (OccEnv cands _ _) = OccEnv cands OccVanilla []
+rhsCtxt (OccEnv cands _ _) = OccEnv cands OccRhs []
+
+addAppCtxt (OccEnv cands encl ctxt) args
+ = OccEnv cands encl (replicate (valArgCount args) True ++ ctxt)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[OccurAnal-types]{OccEnv}
+%* *
+%************************************************************************
+\begin{code}
type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
combineUsageDetails, combineAltsUsageDetails
(mkVarApps (Var new_bndr) lam_bndrs))],
poly_env)
- | otherwise
+ | otherwise -- Non-null abs_vars
= newPolyBndrs dest_lvl env abs_vars bndrs `thenLvl` \ (new_env, new_bndrs) ->
mapLvl (lvlFloatRhs abs_vars dest_lvl new_env) rhss `thenLvl` \ new_rhss ->
returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
\end{code}
\begin{code}
-abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
- -- Find the variables in fvs, free vars of the target expresion,
- -- whose level is less than than the supplied level
- -- These are the ones we are going to abstract out
-abstractVars dest_lvl env fvs
- = uniq (sortLt lt [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])
- where
- -- Sort the variables so we don't get
- -- mixed-up tyvars and Ids; it's just messy
- v1 `lt` v2 = case (isId v1, isId v2) of
- (True, False) -> False
- (False, True) -> True
- other -> v1 < v2 -- Same family
- uniq :: [Var] -> [Var]
- -- Remove adjacent duplicates; the sort will have brought them together
- uniq (v1:v2:vs) | v1 == v2 = uniq (v2:vs)
- | otherwise = v1 : uniq (v2:vs)
- uniq vs = vs
-
-- Destintion level is the max Id level of the expression
-- (We'll abstract the type variables, if any.)
destLevel :: LevelEnv -> VarSet -> Bool -> Level
Just (_, expr) -> expr
other -> Var v
+abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
+ -- Find the variables in fvs, free vars of the target expresion,
+ -- whose level is greater than the destination level
+ -- These are the ones we are going to abstract out
+abstractVars dest_lvl env fvs
+ = uniq (sortLt lt [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])
+ where
+ -- Sort the variables so we don't get
+ -- mixed-up tyvars and Ids; it's just messy
+ v1 `lt` v2 = case (isId v1, isId v2) of
+ (True, False) -> False
+ (False, True) -> True
+ other -> v1 < v2 -- Same family
+
+ uniq :: [Var] -> [Var]
+ -- Remove adjacent duplicates; the sort will have brought them together
+ uniq (v1:v2:vs) | v1 == v2 = uniq (v2:vs)
+ | otherwise = v1 : uniq (v2:vs)
+ uniq vs = vs
+
absVarsOf :: Level -> LevelEnv -> Var -> [Var]
- -- If f is free in the exression, and f maps to poly_f a b c in the
+ -- If f is free in the expression, and f maps to poly_f a b c in the
-- current substitution, then we must report a b c as candidate type
-- variables
absVarsOf dest_lvl (_, lvl_env, _, id_env) v
| isId v
- = [final_av | av <- lookup_avs v, abstract_me av, final_av <- add_tyvars av]
+ = [zap av2 | av1 <- lookup_avs v, av2 <- add_tyvars av1, abstract_me av2]
| otherwise
= if abstract_me v then [v] else []
Just (abs_vars, _) -> abs_vars
Nothing -> [v]
- -- We are going to lambda-abstract, so nuke any IdInfo,
- -- and add the tyvars of the Id
- add_tyvars v | isId v = zap v : varSetElems (idFreeTyVars v)
+ add_tyvars v | isId v = v : varSetElems (idFreeTyVars v)
| otherwise = [v]
- zap v = WARN( workerExists (idWorkerInfo v)
- || not (isEmptyCoreRules (idSpecialisation v)),
- text "absVarsOf: discarding info on" <+> ppr v )
- setIdInfo v vanillaIdInfo
+ -- We are going to lambda-abstract, so nuke any IdInfo,
+ -- and add the tyvars of the Id (if necessary)
+ zap v | isId v = WARN( workerExists (idWorkerInfo v) ||
+ not (isEmptyCoreRules (idSpecialisation v)),
+ text "absVarsOf: discarding info on" <+> ppr v )
+ setIdInfo v vanillaIdInfo
+ | otherwise = v
\end{code}
\begin{code}
#include "HsVersions.h"
-import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
- SwitchResult(..), intSwitchSet,
+import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), SimplifierMode(..),
DynFlags, DynFlag(..), dopt, dopt_CoreToDo
)
import CoreSyn
extendRuleBaseList, addRuleBaseFVs, pprRuleBase,
ruleCheckProgram )
import Module ( moduleEnvElts )
-import CoreUnfold
import PprCore ( pprCoreBindings, pprCoreExpr )
import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
import CoreUtils ( coreBindsSize )
import CoreLint ( endPass )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( idName, isDataConWrapId, setIdLocalExported, isImplicitId )
+import Id ( idName, setIdLocalExported, isImplicitId )
import VarSet
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
; us <- mkSplitUniqSupply 's'
- ; let (expr', _counts) = initSmpl dflags sw_chkr us emptyVarSet black_list_nothing
- (simplExprGently expr)
+ ; let env = emptySimplEnv (SimplPhase 0) [] emptyVarSet
+ (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
(pprCoreExpr expr')
; return expr'
}
- where
- sw_chkr any = SwBool False -- A bit bogus
- black_list_nothing v = False -- Black list nothing
doCorePasses :: DynFlags
doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
-doCorePass dfs rb us binds (CoreDoSimplify sw_chkr)
- = _scc_ "Simplify" simplifyPgm dfs rb sw_chkr us binds
+doCorePass dfs rb us binds (CoreDoSimplify mode switches)
+ = _scc_ "Simplify" simplifyPgm dfs rb mode switches us binds
doCorePass dfs rb us binds CoreCSE
= _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
doCorePass dfs rb us binds CoreLiberateCase
= _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds)
doCorePass dfs rb us binds CoreDoGlomBinds
= noStats dfs (glomBinds dfs binds)
-doCorePass dfs rb us binds (CoreDoRuleCheck pat)
- = noStats dfs (ruleCheck dfs pat binds)
+doCorePass dfs rb us binds (CoreDoRuleCheck phase pat)
+ = noStats dfs (ruleCheck dfs phase pat binds)
doCorePass dfs rb us binds CoreDoNothing
= noStats dfs (return binds)
(pprCoreBindings binds)
return binds
-ruleCheck dflags pat binds = do showPass dflags "RuleCheck"
- printDump (ruleCheckProgram pat binds)
- return binds
+ruleCheck dflags phase pat binds = do showPass dflags "RuleCheck"
+ printDump (ruleCheckProgram phase pat binds)
+ return binds
-- most passes return no stats and don't change rules
noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
IdSet) -- RHS free vars of all rules
prepareRules dflags pkg_rule_base hst us binds local_rules
- = do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all
- (mapSmpl simplRule local_rules)
+ = do { let env = emptySimplEnv SimplGently [] local_ids
+ (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
; let (local_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
-- We use (`elemVarSet` local_ids) rather than isLocalId because
; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
}
where
- sw_chkr any = SwBool False -- A bit bogus
- black_list_all v = not (isDataConWrapId v)
- -- This stops all inlining except the
- -- wrappers for data constructors
-
add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds)
-- Boringly, we need to gather the in-scope set.
This doesn't match unless you do eta reduction on the build argument.
\begin{code}
-simplRule rule@(id, BuiltinRule _ _)
+simplRule env rule@(id, BuiltinRule _ _)
= returnSmpl rule
-simplRule rule@(id, Rule name bndrs args rhs)
- = simplBinders bndrs $ \ bndrs' ->
- mapSmpl simplExprGently args `thenSmpl` \ args' ->
- simplExprGently rhs `thenSmpl` \ rhs' ->
- returnSmpl (id, Rule name bndrs' args' rhs')
+simplRule env rule@(id, Rule act name bndrs args rhs)
+ = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
+ mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
+ simplExprGently env rhs `thenSmpl` \ rhs' ->
+ returnSmpl (id, Rule act name bndrs' args' rhs')
-- It's important that simplExprGently does eta reduction.
-- For example, in a rule like:
\end{code}
\begin{code}
-simplExprGently :: CoreExpr -> SimplM CoreExpr
+simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
-- Simplifies an expression
-- does occurrence analysis, then simplification
-- and repeats (twice currently) because one pass
-- alone leaves tons of crud.
-- Used (a) for user expressions typed in at the interactive prompt
-- (b) the LHS and RHS of a RULE
-simplExprGently expr
- = simplExpr (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
- simplExpr (occurAnalyseGlobalExpr expr1)
+simplExprGently env expr
+ = simplExpr env (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
+ simplExpr env (occurAnalyseGlobalExpr expr1)
\end{code}
\begin{code}
simplifyPgm :: DynFlags
-> RuleBase
- -> (SimplifierSwitch -> SwitchResult)
+ -> SimplifierMode
+ -> [SimplifierSwitch]
-> UniqSupply
-> [CoreBind] -- Input
-> IO (SimplCount, [CoreBind]) -- New bindings
simplifyPgm dflags rule_base
- sw_chkr us binds
+ mode switches us binds
= do {
showPass dflags "Simplify";
return (counts_out, binds')
}
where
- max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
- black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
+ phase_info = case mode of
+ SimplGently -> "gentle"
+ SimplPhase n -> show n
+
imported_rule_ids = ruleBaseIds rule_base
- rule_lhs_fvs = ruleBaseFVs rule_base
+ simpl_env = emptySimplEnv mode switches imported_rule_ids
+ sw_chkr = getSwitchChecker simpl_env
+ max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
iteration us iteration_no counts binds
-- Try and force thunks off the binds; significantly reduces
-- case t of {(_,counts') -> if counts'=0 then ...
-- So the conditional didn't force counts', because the
-- selection got duplicated. Sigh!
- case initSmpl dflags sw_chkr us1 imported_rule_ids black_list_fn
- (simplTopBinds tagged_binds)
- of { (binds', counts') -> do {
+ case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
+ (binds', counts') -> do {
-- The imported_rule_ids are used by initSmpl to initialise
-- the in-scope set. That way, the simplifier will change any
-- occurrences of the imported id to the one in the imported_rule_ids
-- set, which are decorated with their rules.
- let { all_counts = counts `plusSimplCount` counts' } ;
+ let { all_counts = counts `plusSimplCount` counts' ;
+ herald = "Simplifier phase " ++ phase_info ++
+ ", iteration " ++ show iteration_no ++
+ " out of " ++ show max_iterations
+ } ;
-- Stop if nothing happened; don't dump output
if isZeroSimplCount counts' then
else do {
-- Dump the result of this iteration
- dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations
- ("Simplifier iteration " ++ show iteration_no
- ++ " out of " ++ show max_iterations)
+ dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
(pprSimplCount counts') ;
- endPass dflags
- ("Simplifier iteration " ++ show iteration_no ++ " result")
- Opt_D_dump_simpl_iterations
- binds' ;
+ endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
-- Stop if we've run out of iterations
if iteration_no == max_iterations then
\begin{code}
module SimplMonad (
InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
- OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
- OutExprStuff, OutStuff, returnOutStuff,
+ OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
+ FloatsWith, FloatsWithExpr,
-- The monad
SimplM,
mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
getDOptsSmpl,
- -- The inlining black-list
- setBlackList, getBlackList, noInlineBlackList,
+ -- The simplifier mode
+ setMode, getMode,
-- Unique supply
getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl,
- newId, newIds,
-- Counting
SimplCount, Tick(..),
plusSimplCount, isZeroSimplCount,
-- Switch checker
- SwitchChecker, getSwitchChecker, getSimplIntSwitch,
+ SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch,
+ isAmongSimpl, intSwitchSet, switchIsOn,
-- Cost centres
getEnclosingCC, setEnclosingCC,
-- Environments
- getEnv, setAllExceptInScope,
- getSubst, setSubst,
+ SimplEnv, emptySimplEnv, getSubst, setSubst,
getSubstEnv, extendSubst, extendSubstList,
getInScope, setInScope, modifyInScope, addNewInScopeIds,
setSubstEnv, zapSubstEnv,
- getSimplBinderStuff, setSimplBinderStuff,
- -- Adding bindings
- addLetBind, addLetBinds, addAuxiliaryBind, addAuxiliaryBinds,
- addCaseBind, needsCaseBinding, addNonRecBind, wrapFloats, addFloats
+ -- Floats
+ Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats,
+ allLifted, wrapFloats, floatBinds,
+ addAuxiliaryBind,
+
+ -- Inlining,
+ preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
+ inlineMode
) where
#include "HsVersions.h"
-import Id ( Id, mkSysLocal, idType, idUnfolding, isDataConWrapId,
- isGlobalId )
+import Id ( Id, idType, isDataConWrapId,
+ idOccInfo, idInlinePragma
+ )
import CoreSyn
-import CoreUnfold ( isCompulsoryUnfolding )
-import CoreUtils ( exprOkForSpeculation )
+import CoreUtils ( needsCaseBinding, exprIsTrivial )
import PprCore () -- Instances
import CostCentre ( CostCentreStack, subsumedCCS )
-import OccName ( UserFS )
+import Var
import VarEnv
import VarSet
import OrdList
UniqSupply
)
import FiniteMap
-import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..),
- DynFlags, DynFlag(..), dopt,
- opt_PprStyle_Debug, opt_HistorySize,
- intSwitchSet
+import BasicTypes ( TopLevelFlag, isTopLevel,
+ Activation, isActive, isAlwaysActive,
+ OccInfo(..)
+ )
+import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..),
+ DynFlags, DynFlag(..), dopt,
+ opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining,
)
import Unique ( Unique )
import Maybes ( expectJust )
-import Util ( zipWithEqual )
import Outputable
+import Array ( array, (//) )
+import FastTypes
+import GlaExts ( indexArray# )
+
+#if __GLASGOW_HASKELL__ < 301
+import ArrBase ( Array(..) )
+#else
+import PrelArr ( Array(..) )
+#endif
infixr 0 `thenSmpl`, `thenSmpl_`
\end{code}
type OutBinder = CoreBndr
type OutId = Id -- Cloned
+type OutTyVar = TyVar -- Cloned
type OutType = Type -- Cloned
type OutBind = CoreBind
type OutExpr = CoreExpr
type OutAlt = CoreAlt
type OutArg = CoreArg
+\end{code}
-type SwitchChecker = SimplifierSwitch -> SwitchResult
+%************************************************************************
+%* *
+\subsection{Floats}
+%* *
+%************************************************************************
-type OutExprStuff = OutStuff OutExpr
-type OutStuff a = (OrdList OutBind, (InScopeSet, a))
+\begin{code}
+type FloatsWithExpr = FloatsWith OutExpr
+type FloatsWith a = (Floats, a)
-- We return something equivalent to (let b in e), but
-- in pieces to avoid the quadratic blowup when floating
-- incrementally. Comments just before simplExprB in Simplify.lhs
+
+data Floats = Floats (OrdList OutBind)
+ InScopeSet -- Environment "inside" all the floats
+ Bool -- True <=> All bindings are lifted
+
+allLifted :: Floats -> Bool
+allLifted (Floats _ _ is_lifted) = is_lifted
+
+wrapFloats :: Floats -> OutExpr -> OutExpr
+wrapFloats (Floats bs _ _) body = foldrOL Let body bs
+
+isEmptyFloats :: Floats -> Bool
+isEmptyFloats (Floats bs _ _) = isNilOL bs
+
+floatBinds :: Floats -> [OutBind]
+floatBinds (Floats bs _ _) = fromOL bs
+
+flattenFloats :: Floats -> Floats
+-- Flattens into a single Rec group
+flattenFloats (Floats bs is is_lifted)
+ = ASSERT2( is_lifted, ppr (fromOL bs) )
+ Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted
\end{code}
\begin{code}
-wrapFloats :: OrdList CoreBind -> CoreExpr -> CoreExpr
-wrapFloats binds body = foldOL Let body binds
-
-returnOutStuff :: a -> SimplM (OutStuff a)
-returnOutStuff x = getInScope `thenSmpl` \ in_scope ->
- returnSmpl (nilOL, (in_scope, x))
-
-addFloats :: OrdList CoreBind -> InScopeSet -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-addFloats floats in_scope thing_inside
- = setInScope in_scope thing_inside `thenSmpl` \ (binds, res) ->
- returnSmpl (floats `appOL` binds, res)
-
-addLetBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-addLetBind bind thing_inside
- = thing_inside `thenSmpl` \ (binds, res) ->
- returnSmpl (bind `consOL` binds, res)
-
-addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-addLetBinds binds1 thing_inside
- = thing_inside `thenSmpl` \ (binds2, res) ->
- returnSmpl (toOL binds1 `appOL` binds2, res)
-
-addAuxiliaryBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
- -- Extends the in-scope environment as well as wrapping the bindings
-addAuxiliaryBinds binds1 thing_inside
- = addNewInScopeIds (bindersOfBinds binds1) $
- addLetBinds binds1 thing_inside
-
-addAuxiliaryBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+emptyFloats :: SimplEnv -> Floats
+emptyFloats env = Floats nilOL (getInScope env) True
+
+unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats
+-- A single non-rec float; extend the in-scope set
+unitFloat env var rhs = Floats (unitOL (NonRec var rhs))
+ (Subst.extendInScopeSet (getInScope env) var)
+ (not (isUnLiftedType (idType var)))
+
+addFloats :: SimplEnv -> Floats
+ -> (SimplEnv -> SimplM (FloatsWith a))
+ -> SimplM (FloatsWith a)
+addFloats env (Floats b1 is1 l1) thing_inside
+ | isNilOL b1
+ = thing_inside env
+ | otherwise
+ = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) ->
+ returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res)
+
+addLetBind :: OutBind -> Floats -> Floats
+addLetBind bind (Floats binds in_scope lifted)
+ = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind)
+
+is_lifted_bind (Rec _) = True
+is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b))
+
+-- addAuxiliaryBind * takes already-simplified things (bndr and rhs)
+-- * extends the in-scope env
+-- * assumes it's a let-bindable thing
+addAuxiliaryBind :: SimplEnv -> OutBind
+ -> (SimplEnv -> SimplM (FloatsWith a))
+ -> SimplM (FloatsWith a)
-- Extends the in-scope environment as well as wrapping the bindings
-addAuxiliaryBind bind thing_inside
- = addNewInScopeIds (bindersOf bind) $
- addLetBind bind thing_inside
-
-needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
- -- Make a case expression instead of a let
- -- These can arise either from the desugarer,
- -- or from beta reductions: (\x.e) (x +# y)
-
-addCaseBind bndr rhs thing_inside
- = thing_inside `thenSmpl` \ (floats, (_, body)) ->
- returnOutStuff (Case rhs bndr [(DEFAULT, [], wrapFloats floats body)])
-
-addNonRecBind bndr rhs thing_inside
- -- Checks for needing a case binding
- | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside
- | otherwise = addLetBind (NonRec bndr rhs) thing_inside
+addAuxiliaryBind env bind thing_inside
+ = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } )
+ thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) ->
+ returnSmpl (addLetBind bind floats, x)
\end{code}
\begin{code}
type SimplM result
- = DynFlags
- -> SimplEnv -- We thread the unique supply because
+ = DynFlags -- We thread the unique supply because
-> UniqSupply -- constantly splitting it is rather expensive
-> SimplCount
-> (result, UniqSupply, SimplCount)
-
-type BlackList = Id -> Bool -- True => don't inline this Id
-
-data SimplEnv
- = SimplEnv {
- seChkr :: SwitchChecker,
- seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
- seBlackList :: BlackList,
- seSubst :: Subst -- The current substitution
- }
- -- The range of the substitution is OutType and OutExpr resp
- --
- -- The substitution is idempotent
- -- It *must* be applied; things in its domain simply aren't
- -- bound in the result.
- --
- -- The substitution usually maps an Id to its clone,
- -- but if the orig defn is a let-binding, and
- -- the RHS of the let simplifies to an atom,
- -- we just add the binding to the substitution and elide the let.
-
- -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
- -- The elements of the set may have better IdInfo than the
- -- occurrences of in-scope Ids, and (more important) they will
- -- have a correctly-substituted type. So we use a lookup in this
- -- set to replace occurrences
\end{code}
\begin{code}
initSmpl :: DynFlags
- -> SwitchChecker
-> UniqSupply -- No init count; set to 0
- -> VarSet -- In scope (usually empty, but useful for nested calls)
- -> BlackList -- Black-list function
-> SimplM a
-> (a, SimplCount)
-initSmpl dflags chkr us in_scope black_list m
- = case m dflags (emptySimplEnv chkr in_scope black_list) us
- (zeroSimplCount dflags) of
+initSmpl dflags us m
+ = case m dflags us (zeroSimplCount dflags) of
(result, _, count) -> (result, count)
{-# INLINE returnSmpl #-}
returnSmpl :: a -> SimplM a
-returnSmpl e dflags env us sc = (e, us, sc)
+returnSmpl e dflags us sc = (e, us, sc)
thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
-thenSmpl m k dflags env us0 sc0
- = case (m dflags env us0 sc0) of
- (m_result, us1, sc1) -> k m_result dflags env us1 sc1
+thenSmpl m k dflags us0 sc0
+ = case (m dflags us0 sc0) of
+ (m_result, us1, sc1) -> k m_result dflags us1 sc1
-thenSmpl_ m k dflags env us0 sc0
- = case (m dflags env us0 sc0) of
- (_, us1, sc1) -> k dflags env us1 sc1
+thenSmpl_ m k dflags us0 sc0
+ = case (m dflags us0 sc0) of
+ (_, us1, sc1) -> k dflags us1 sc1
\end{code}
\begin{code}
getUniqSupplySmpl :: SimplM UniqSupply
-getUniqSupplySmpl dflags env us sc
+getUniqSupplySmpl dflags us sc
= case splitUniqSupply us of
(us1, us2) -> (us1, us2, sc)
getUniqueSmpl :: SimplM Unique
-getUniqueSmpl dflags env us sc
+getUniqueSmpl dflags us sc
= case splitUniqSupply us of
(us1, us2) -> (uniqFromSupply us1, us2, sc)
getUniquesSmpl :: SimplM [Unique]
-getUniquesSmpl dflags env us sc
+getUniquesSmpl dflags us sc
= case splitUniqSupply us of
(us1, us2) -> (uniqsFromSupply us1, us2, sc)
getDOptsSmpl :: SimplM DynFlags
-getDOptsSmpl dflags env us sc
+getDOptsSmpl dflags us sc
= (dflags, us, sc)
\end{code}
\begin{code}
getSimplCount :: SimplM SimplCount
-getSimplCount dflags env us sc = (sc, us, sc)
+getSimplCount dflags us sc = (sc, us, sc)
tick :: Tick -> SimplM ()
-tick t dflags env us sc
+tick t dflags us sc
= sc' `seq` ((), us, sc')
where
sc' = doTick t sc
freeTick :: Tick -> SimplM ()
-- Record a tick, but don't add to the total tick count, which is
-- used to decide when nothing further has happened
-freeTick t dflags env us sc
+freeTick t dflags us sc
= sc' `seq` ((), us, sc')
where
sc' = doFreeTick t sc
| CaseOfCase Id -- Bndr on *inner* case
| KnownBranch Id -- Case binder
| CaseMerge Id -- Binder on outer case
+ | AltMerge Id -- Case binder
| CaseElim Id -- Case binder
| CaseIdentity Id -- Case binder
| FillInCaseDefault Id -- Case binder
tickToTag (FillInCaseDefault _) = 13
tickToTag BottomFound = 14
tickToTag SimplifierDone = 16
+tickToTag (AltMerge _) = 17
tickString :: Tick -> String
tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
tickString (CaseOfCase _) = "CaseOfCase"
tickString (KnownBranch _) = "KnownBranch"
tickString (CaseMerge _) = "CaseMerge"
+tickString (AltMerge _) = "AltMerge"
tickString (CaseElim _) = "CaseElim"
tickString (CaseIdentity _) = "CaseIdentity"
tickString (FillInCaseDefault _) = "FillInCaseDefault"
pprTickCts (CaseOfCase v) = ppr v
pprTickCts (KnownBranch v) = ppr v
pprTickCts (CaseMerge v) = ppr v
+pprTickCts (AltMerge v) = ppr v
pprTickCts (CaseElim v) = ppr v
pprTickCts (CaseIdentity v) = ppr v
pprTickCts (FillInCaseDefault v) = ppr v
cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
+cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
\end{code}
+
%************************************************************************
%* *
-\subsubsection{Command-line switches}
+\subsubsection{The @SimplEnv@ type}
%* *
%************************************************************************
+
\begin{code}
-getSwitchChecker :: SimplM SwitchChecker
-getSwitchChecker dflags env us sc = (seChkr env, us, sc)
+data SimplEnv
+ = SimplEnv {
+ seMode :: SimplifierMode,
+ seChkr :: SwitchChecker,
+ seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
+ seSubst :: Subst -- The current substitution
+ }
+ -- The range of the substitution is OutType and OutExpr resp
+ --
+ -- The substitution is idempotent
+ -- It *must* be applied; things in its domain simply aren't
+ -- bound in the result.
+ --
+ -- The substitution usually maps an Id to its clone,
+ -- but if the orig defn is a let-binding, and
+ -- the RHS of the let simplifies to an atom,
+ -- we just add the binding to the substitution and elide the let.
-getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
-getSimplIntSwitch chkr switch
- = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
-\end{code}
+ -- The in-scope part of Subst includes *all* in-scope TyVars and Ids
+ -- The elements of the set may have better IdInfo than the
+ -- occurrences of in-scope Ids, and (more important) they will
+ -- have a correctly-substituted type. So we use a lookup in this
+ -- set to replace occurrences
+emptySimplEnv :: SimplifierMode -> [SimplifierSwitch] -> VarSet -> SimplEnv
+emptySimplEnv mode switches in_scope
+ = SimplEnv { seChkr = isAmongSimpl switches, seCC = subsumedCCS, seMode = mode,
+ seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
+ -- The top level "enclosing CC" is "SUBSUMED".
-@setBlackList@ is used to prepare the environment for simplifying
-the RHS of an Id that's marked with an INLINE pragma. It is going to
-be inlined wherever they are used, and then all the inlining will take
-effect. Meanwhile, there isn't much point in doing anything to the
-as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off
-inlining! because
- (a) not doing so will inline a worker straight back into its wrapper!
+---------------------
+getSwitchChecker :: SimplEnv -> SwitchChecker
+getSwitchChecker env = seChkr env
-and (b) Consider the following example
- let f = \pq -> BIG
- in
- let g = \y -> f y y
- {-# INLINE g #-}
- in ...g...g...g...g...g...
+---------------------
+getMode :: SimplEnv -> SimplifierMode
+getMode env = seMode env
- Now, if that's the ONLY occurrence of f, it will be inlined inside g,
- and thence copied multiple times when g is inlined.
+setMode :: SimplifierMode -> SimplEnv -> SimplEnv
+setMode mode env = env { seMode = mode }
- Andy disagrees! Example:
- all xs = foldr (&&) True xs
- any p = all . map p {-# INLINE any #-}
-
- Problem: any won't get deforested, and so if it's exported and
- the importer doesn't use the inlining, (eg passes it as an arg)
- then we won't get deforestation at all.
- We havn't solved this problem yet!
-
-We prepare the envt by simply modifying the black list.
-
-6/98 update:
-
-We *don't* prevent inlining from happening for identifiers
-that are marked as IMustBeINLINEd. An example of where
-doing this is crucial is:
-
- class Bar a => Foo a where
- ...g....
- {-# INLINE f #-}
- f :: Foo a => a -> b
- f x = ....Foo_sc1...
-
-If `f' needs to peer inside Foo's superclass, Bar, it refers
-to the appropriate super class selector, which is marked as
-must-inlineable. We don't generate any code for a superclass
-selector, so failing to inline it in the RHS of `f' will
-leave a reference to a non-existent id, with bad consequences.
-
-ALSO NOTE that we do all this by modifing the black list
-not by zapping the unfolding. The latter may still be useful for
-knowing when something is evaluated.
+---------------------
+getEnclosingCC :: SimplEnv -> CostCentreStack
+getEnclosingCC env = seCC env
-\begin{code}
-setBlackList :: BlackList -> SimplM a -> SimplM a
-setBlackList black_list m dflags env us sc
- = m dflags (env { seBlackList = black_list }) us sc
-
-getBlackList :: SimplM BlackList
-getBlackList dflags env us sc = (seBlackList env, us, sc)
-
-noInlineBlackList :: SimplM BlackList
- -- Inside inlinings, black list anything that is in scope or imported.
- -- except for data con wrappers. The exception is a hack, like the one in
- -- SimplCore.simplRules, to make wrappers inline in rule LHSs.
- -- We may as well do the same here.
-noInlineBlackList dflags env us sc = (blacklisted,us,sc)
- where blacklisted v =
- not (isDataConWrapId v) &&
- (v `isInScope` (seSubst env) || isGlobalId v)
- -- NB: An earlier version omitted the last clause; this meant
- -- that even inlinings *completely within* an INLINE didn't happen.
- -- This was cheaper, and probably adequate, but produced awful code
- -- for some dictionary constructions.
-\end{code}
+setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv
+setEnclosingCC env cc = env {seCC = cc}
+---------------------
+getSubst :: SimplEnv -> Subst
+getSubst env = seSubst env
-%************************************************************************
-%* *
-\subsubsection{The ``enclosing cost-centre''}
-%* *
-%************************************************************************
+setSubst :: SimplEnv -> Subst -> SimplEnv
+setSubst env subst = env {seSubst = subst}
-\begin{code}
-getEnclosingCC :: SimplM CostCentreStack
-getEnclosingCC dflags env us sc = (seCC env, us, sc)
+extendSubst :: SimplEnv -> CoreBndr -> SubstResult -> SimplEnv
+extendSubst env@(SimplEnv {seSubst = subst}) var res
+ = env {seSubst = Subst.extendSubst subst var res}
+
+extendSubstList :: SimplEnv -> [CoreBndr] -> [SubstResult] -> SimplEnv
+extendSubstList env@(SimplEnv {seSubst = subst}) vars ress
+ = env {seSubst = Subst.extendSubstList subst vars ress}
-setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
-setEnclosingCC cc m dflags env us sc = m dflags (env { seCC = cc }) us sc
+---------------------
+getInScope :: SimplEnv -> InScopeSet
+getInScope env = substInScope (seSubst env)
+
+setInScope :: SimplEnv -> SimplEnv -> SimplEnv
+setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope)
+
+setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
+setInScopeSet env@(SimplEnv {seSubst = subst}) in_scope
+ = env {seSubst = Subst.setInScope subst in_scope}
+
+addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
+ -- The new Ids are guaranteed to be freshly allocated
+addNewInScopeIds env@(SimplEnv {seSubst = subst}) vs
+ = env {seSubst = Subst.extendNewInScopeList subst vs}
+
+modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv
+modifyInScope env@(SimplEnv {seSubst = subst}) v v'
+ = env {seSubst = Subst.modifyInScope subst v v'}
+
+---------------------
+getSubstEnv :: SimplEnv -> SubstEnv
+getSubstEnv env = substEnv (seSubst env)
+
+setSubstEnv :: SimplEnv -> SubstEnv -> SimplEnv
+setSubstEnv env@(SimplEnv {seSubst = subst}) senv
+ = env {seSubst = Subst.setSubstEnv subst senv}
+
+zapSubstEnv :: SimplEnv -> SimplEnv
+zapSubstEnv env@(SimplEnv {seSubst = subst})
+ = env {seSubst = Subst.zapSubstEnv subst}
\end{code}
%************************************************************************
%* *
-\subsubsection{The @SimplEnv@ type}
+\subsection{Decisions about inlining}
%* *
%************************************************************************
+Inlining is controlled partly by the SimplifierMode switch. This has two
+settings:
+
+ SimplGently (a) Simplifying before specialiser/full laziness
+ (b) Simplifiying inside INLINE pragma
+ (c) Simplifying the LHS of a rule
+
+ SimplPhase n Used at all other times
+
+The key thing about SimplGently is that it does no call-site inlining.
+Before full laziness we must be careful not to inline wrappers,
+because doing so inhibits floating
+ e.g. ...(case f x of ...)...
+ ==> ...(case (case x of I# x# -> fw x#) of ...)...
+ ==> ...(case x of I# x# -> case fw x# of ...)...
+and now the redex (f x) isn't floatable any more.
+
+INLINE pragmas
+~~~~~~~~~~~~~~
+SimplGently is also used as the mode to simplify inside an InlineMe note.
\begin{code}
-emptySimplEnv :: SwitchChecker -> VarSet -> (Id -> Bool) -> SimplEnv
+inlineMode :: SimplifierMode
+inlineMode = SimplGently
+\end{code}
-emptySimplEnv sw_chkr in_scope black_list
- = SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
- seBlackList = black_list,
- seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
- -- The top level "enclosing CC" is "SUBSUMED".
+It really is important to switch off inlinings inside such
+expressions. Consider the following example
+
+ let f = \pq -> BIG
+ in
+ let g = \y -> f y y
+ {-# INLINE g #-}
+ in ...g...g...g...g...g...
+
+Now, if that's the ONLY occurrence of f, it will be inlined inside g,
+and thence copied multiple times when g is inlined.
+
+
+This function may be inlinined in other modules, so we
+don't want to remove (by inlining) calls to functions that have
+specialisations, or that may have transformation rules in an importing
+scope.
+
+E.g. {-# INLINE f #-}
+ f x = ...g...
+
+and suppose that g is strict *and* has specialisations. If we inline
+g's wrapper, we deny f the chance of getting the specialised version
+of g when f is inlined at some call site (perhaps in some other
+module).
+
+It's also important not to inline a worker back into a wrapper.
+A wrapper looks like
+ wraper = inline_me (\x -> ...worker... )
+Normally, the inline_me prevents the worker getting inlined into
+the wrapper (initially, the worker's only call site!). But,
+if the wrapper is sure to be called, the strictness analyser will
+mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
+continuation. That's why the keep_inline predicate returns True for
+ArgOf continuations. It shouldn't do any harm not to dissolve the
+inline-me note under these circumstances.
+
+Note that the result is that we do very little simplification
+inside an InlineMe.
+
+ all xs = foldr (&&) True xs
+ any p = all . map p {-# INLINE any #-}
+
+Problem: any won't get deforested, and so if it's exported and the
+importer doesn't use the inlining, (eg passes it as an arg) then we
+won't get deforestation at all. We havn't solved this problem yet!
+
+
+preInlineUnconditionally
+~~~~~~~~~~~~~~~~~~~~~~~~
+@preInlineUnconditionally@ examines a bndr to see if it is used just
+once in a completely safe way, so that it is safe to discard the
+binding inline its RHS at the (unique) usage site, REGARDLESS of how
+big the RHS might be. If this is the case we don't simplify the RHS
+first, but just inline it un-simplified.
+
+This is much better than first simplifying a perhaps-huge RHS and then
+inlining and re-simplifying it.
+
+NB: we don't even look at the RHS to see if it's trivial
+We might have
+ x = y
+where x is used many times, but this is the unique occurrence of y.
+We should NOT inline x at all its uses, because then we'd do the same
+for y -- aargh! So we must base this pre-rhs-simplification decision
+solely on x's occurrences, not on its rhs.
+
+Evne RHSs labelled InlineMe aren't caught here, because there might be
+no benefit from inlining at the call site.
+
+[Sept 01] Don't unconditionally inline a top-level thing, because that
+can simply make a static thing into something built dynamically. E.g.
+ x = (a,b)
+ main = \s -> h x
+
+[Remember that we treat \s as a one-shot lambda.] No point in
+inlining x unless there is something interesting about the call site.
+
+But watch out: if you aren't careful, some useful foldr/build fusion
+can be lost (most notably in spectral/hartel/parstof) because the
+foldr didn't see the build. Doing the dynamic allocation isn't a big
+deal, in fact, but losing the fusion can be. But the right thing here
+seems to be to do a callSiteInline based on the fact that there is
+something interesting about the call site (it's strict). Hmm. That
+seems a bit fragile.
-getEnv :: SimplM SimplEnv
-getEnv dflags env us sc = (env, us, sc)
+\begin{code}
+preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
+preInlineUnconditionally env top_lvl bndr
+-- | isTopLevel top_lvl = False
+-- Top-level fusion lost if we do this for (e.g. string constants)
+ | not active = False
+ | opt_SimplNoPreInlining = False
+ | otherwise = case idOccInfo bndr of
+ IAmDead -> True -- Happens in ((\x.1) v)
+ OneOcc in_lam once -> not in_lam && once
+ -- Not inside a lambda, one occurrence ==> safe!
+ other -> False
+ where
+ active = case getMode env of
+ SimplGently -> isAlwaysActive prag
+ SimplPhase n -> isActive n prag
+ prag = idInlinePragma bndr
+\end{code}
-setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
-setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m dflags
- (SimplEnv {seSubst = old_subst}) us sc
- = m dflags (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)})
- us sc
+postInlineUnconditionally
+~~~~~~~~~~~~~~~~~~~~~~~~~
+@postInlineUnconditionally@ decides whether to unconditionally inline
+a thing based on the form of its RHS; in particular if it has a
+trivial RHS. If so, we can inline and discard the binding altogether.
-getSubst :: SimplM Subst
-getSubst dflags env us sc = (seSubst env, us, sc)
+NB: a loop breaker has must_keep_binding = True and non-loop-breakers
+only have *forward* references Hence, it's safe to discard the binding
+
+NOTE: This isn't our last opportunity to inline. We're at the binding
+site right now, and we'll get another opportunity when we get to the
+ocurrence(s)
-setSubst :: Subst -> SimplM a -> SimplM a
-setSubst subst m dflags env us sc = m dflags (env {seSubst = subst}) us sc
+Note that we do this unconditional inlining only for trival RHSs.
+Don't inline even WHNFs inside lambdas; doing so may simply increase
+allocation when the function is called. This isn't the last chance; see
+NOTE above.
-getSubstEnv :: SimplM SubstEnv
-getSubstEnv dflags env us sc = (substEnv (seSubst env), us, sc)
+NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
+Because we don't even want to inline them into the RHS of constructor
+arguments. See NOTE above
-addNewInScopeIds :: [CoreBndr] -> SimplM a -> SimplM a
- -- The new Ids are guaranteed to be freshly allocated
-addNewInScopeIds vs m dflags env@(SimplEnv {seSubst = subst}) us sc
- = m dflags (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc
+NB: At one time even NOINLINE was ignored here: if the rhs is trivial
+it's best to inline it anyway. We often get a=E; b=a from desugaring,
+with both a and b marked NOINLINE. But that seems incompatible with
+our new view that inlining is like a RULE, so I'm sticking to the 'active'
+story for now.
-getInScope :: SimplM InScopeSet
-getInScope dflags env us sc = (substInScope (seSubst env), us, sc)
+\begin{code}
+postInlineUnconditionally :: SimplEnv -> OutId -> Bool -> OutExpr -> Bool
+postInlineUnconditionally env bndr loop_breaker rhs
+ = exprIsTrivial rhs
+ && active
+ && not loop_breaker
+ && not (isExportedId bndr)
+ where
+ active = case getMode env of
+ SimplGently -> isAlwaysActive prag
+ SimplPhase n -> isActive n prag
+ prag = idInlinePragma bndr
+\end{code}
-setInScope :: InScopeSet -> SimplM a -> SimplM a
-setInScope in_scope m dflags env@(SimplEnv {seSubst = subst}) us sc
- = m dflags (env {seSubst = Subst.setInScope subst in_scope}) us sc
+blackListInline tells if we must not inline at a call site because the
+Id's inline pragma says not to do so.
-modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
-modifyInScope v v' m dflags env@(SimplEnv {seSubst = subst}) us sc
- = m dflags (env {seSubst = Subst.modifyInScope subst v v'}) us sc
+However, blackListInline is ignored for things with with Compulsory inlinings,
+because they don't have bindings, so we must inline them no matter how
+gentle we are being.
-extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
-extendSubst var res m dflags env@(SimplEnv {seSubst = subst}) us sc
- = m dflags (env { seSubst = Subst.extendSubst subst var res }) us sc
+\begin{code}
+activeInline :: SimplEnv -> OutId -> Bool
+activeInline env id
+ = case getMode env of
+ SimplGently -> isDataConWrapId id
+ -- No inlining at all when doing gentle stuff,
+ -- except (hack alert) for data con wrappers
+ -- We want to inline data con wrappers even in gentle mode
+ -- because rule LHSs match better then
+ SimplPhase n -> isActive n (idInlinePragma id)
+
+activeRule :: SimplEnv -> Maybe (Activation -> Bool)
+-- Nothing => No rules at all
+activeRule env
+ = case getMode env of
+ SimplGently -> Nothing -- No rules in gentle mode
+ SimplPhase n -> Just (isActive n)
+\end{code}
-extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
-extendSubstList vars ress m dflags env@(SimplEnv {seSubst = subst}) us sc
- = m dflags (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
-setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
-setSubstEnv senv m dflags env@(SimplEnv {seSubst = subst}) us sc
- = m dflags (env {seSubst = Subst.setSubstEnv subst senv}) us sc
+%************************************************************************
+%* *
+\subsubsection{Command-line switches}
+%* *
+%************************************************************************
-zapSubstEnv :: SimplM a -> SimplM a
-zapSubstEnv m dflags env@(SimplEnv {seSubst = subst}) us sc
- = m dflags (env {seSubst = Subst.zapSubstEnv subst}) us sc
+\begin{code}
+getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
+getSimplIntSwitch chkr switch
+ = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
-getSimplBinderStuff :: SimplM (Subst, UniqSupply)
-getSimplBinderStuff dflags (SimplEnv {seSubst = subst}) us sc
- = ((subst, us), us, sc)
+switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
-setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
-setSimplBinderStuff (subst, us) m dflags env _ sc
- = m dflags (env {seSubst = subst}) us sc
+switchIsOn lookup_fn switch
+ = case (lookup_fn switch) of
+ SwBool False -> False
+ _ -> True
+
+intSwitchSet :: (switch -> SwitchResult)
+ -> (Int -> switch)
+ -> Maybe Int
+
+intSwitchSet lookup_fn switch
+ = case (lookup_fn (switch (panic "intSwitchSet"))) of
+ SwInt int -> Just int
+ _ -> Nothing
+\end{code}
+
+
+\begin{code}
+type SwitchChecker = SimplifierSwitch -> SwitchResult
+
+data SwitchResult
+ = SwBool Bool -- on/off
+ | SwString FAST_STRING -- nothing or a String
+ | SwInt Int -- nothing or an Int
+
+isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
+isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
+ -- in the list; defaults right at the end.
+ = let
+ tidied_on_switches = foldl rm_dups [] on_switches
+ -- The fold*l* ensures that we keep the latest switches;
+ -- ie the ones that occur earliest in the list.
+
+ sw_tbl :: Array Int SwitchResult
+ sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
+ all_undefined)
+ // defined_elems
+
+ all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
+
+ defined_elems = map mk_assoc_elem tidied_on_switches
+ in
+ -- (avoid some unboxing, bounds checking, and other horrible things:)
+#if __GLASGOW_HASKELL__ < 405
+ case sw_tbl of { Array bounds_who_needs_'em stuff ->
+#else
+ case sw_tbl of { Array _ _ stuff ->
+#endif
+ \ switch ->
+ case (indexArray# stuff (tagOf_SimplSwitch switch)) of
+#if __GLASGOW_HASKELL__ < 400
+ Lift v -> v
+#elif __GLASGOW_HASKELL__ < 403
+ (# _, v #) -> v
+#else
+ (# v #) -> v
+#endif
+ }
+ where
+ mk_assoc_elem k@(MaxSimplifierIterations lvl)
+ = (iBox (tagOf_SimplSwitch k), SwInt lvl)
+ mk_assoc_elem k
+ = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
+
+ -- cannot have duplicates if we are going to use the array thing
+ rm_dups switches_so_far switch
+ = if switch `is_elem` switches_so_far
+ then switches_so_far
+ else switch : switches_so_far
+ where
+ sw `is_elem` [] = False
+ sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
+ || sw `is_elem` ss
\end{code}
+These things behave just like enumeration types.
\begin{code}
-newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a
- -- Extends the in-scope-env too
-newId fs ty m dflags env@(SimplEnv {seSubst = subst}) us sc
- = case splitUniqSupply us of
- (us1, us2) -> m v dflags (env {seSubst = Subst.extendNewInScope subst v})
- us2 sc
- where
- v = mkSysLocal fs (uniqFromSupply us1) ty
-
-newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a
-newIds fs tys m dflags env@(SimplEnv {seSubst = subst}) us sc
- = case splitUniqSupply us of
- (us1, us2) -> m vs dflags (env {seSubst = Subst.extendNewInScopeList subst vs})
- us2 sc
- where
- vs = zipWith (mkSysLocal fs) (uniqsFromSupply us1) tys
+instance Eq SimplifierSwitch where
+ a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
+
+instance Ord SimplifierSwitch where
+ a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
+ a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
+
+
+tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
+tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
+
+-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
+
+lAST_SIMPL_SWITCH_TAG = 2
\end{code}
+
\begin{code}
module SimplUtils (
- simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinder,
- tryRhsTyLam, tryEtaExpansion,
- mkCase,
+ simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinders,
+ tryEtaExpansion,
+ newId, mkLam, mkCase,
-- The continuation type
- SimplCont(..), DupFlag(..), contIsDupable, contResultType,
- countValArgs, countArgs, mkRhsStop, mkStop,
+ SimplCont(..), DupFlag(..), LetRhsFlag(..),
+ contIsDupable, contResultType,
+ countValArgs, countArgs,
+ mkBoringStop, mkStop, contIsRhs, contIsRhsOrArg,
getContArgs, interestingCallContext, interestingArg, isStrictType, discardInline
) where
#include "HsVersions.h"
-import CmdLineOpts ( switchIsOn, SimplifierSwitch(..),
- opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge,
- opt_UF_UpdateInPlace
+import CmdLineOpts ( SimplifierSwitch(..),
+ opt_SimplDoLambdaEtaExpansion, opt_SimplDoEtaReduction,
+ opt_SimplCaseMerge, opt_UF_UpdateInPlace
)
import CoreSyn
+import CoreFVs ( exprSomeFreeVars, exprsSomeFreeVars )
import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap,
etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
- findDefault
+ findDefault, exprOkForSpeculation, exprIsValue
)
import Subst ( InScopeSet, mkSubst, substExpr )
import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id ( idType, idName,
+import Id ( Id, idType, idName,
+ mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo,
idUnfolding, idNewStrictness,
mkLocalId, idInfo
)
-import Maybes ( maybeToBool, catMaybes )
import Name ( setNameUnique )
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
import Type ( Type, mkForAllTys, seqType,
splitTyConApp_maybe, tyConAppArgs, mkTyVarTys,
- isUnLiftedType, isStrictType,
- splitRepFunTys
+ isUnLiftedType, splitRepFunTys, isStrictType
)
-import TyCon ( tyConDataConsIfAvailable )
-import DataCon ( dataConRepArity )
+import OccName ( UserFS )
+import TyCon ( tyConDataConsIfAvailable, isDataTyCon )
+import DataCon ( dataConRepArity, dataConSig, dataConArgTys )
+import Var ( mkSysTyVar, tyVarKind )
import VarEnv ( SubstEnv )
+import VarSet ( mkVarSet, varSetElems, intersectVarSet )
import Util ( lengthExceeds, mapAccumL )
import Outputable
\end{code}
\begin{code}
data SimplCont -- Strict contexts
= Stop OutType -- Type of the result
- Bool -- True => This is the RHS of a thunk whose type suggests
- -- that update-in-place would be possible
- -- (This makes the inliner a little keener.)
+ LetRhsFlag
+ Bool -- True <=> This is the RHS of a thunk whose type suggests
+ -- that update-in-place would be possible
+ -- (This makes the inliner a little keener.)
| CoerceIt OutType -- The To-type, simplified
SimplCont
SimplCont -- keen to inline itelf
| ApplyTo DupFlag
- InExpr SubstEnv -- The argument, as yet unsimplified,
- SimplCont -- and its subst-env
+ InExpr SimplEnv -- The argument, as yet unsimplified,
+ SimplCont -- and its environment
| Select DupFlag
- InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
+ InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
SimplCont
| ArgOf DupFlag -- An arbitrary strict context: the argument
-- of a strict function, or a primitive-arg fn
-- or a PrimOp
+ LetRhsFlag
OutType -- cont_ty: the type of the expression being sought by the context
-- f (error "foo") ==> coerce t (error "foo")
-- when f is strict
-- We need to know the type t, to which to coerce.
- (OutExpr -> SimplM OutExprStuff) -- What to do with the result
+ (SimplEnv -> OutExpr -> SimplM FloatsWithExpr) -- What to do with the result
-- The result expression in the OutExprStuff has type cont_ty
+data LetRhsFlag = AnArg -- It's just an argument not a let RHS
+ | AnRhs -- It's the RHS of a let (so please float lets out of big lambdas)
+
+instance Outputable LetRhsFlag where
+ ppr AnArg = ptext SLIT("arg")
+ ppr AnRhs = ptext SLIT("rhs")
+
instance Outputable SimplCont where
- ppr (Stop _ _) = ptext SLIT("Stop")
+ ppr (Stop _ is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs)
ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
- ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup
+ ppr (ArgOf dup _ _ _) = ptext SLIT("ArgOf...") <+> ppr dup
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
(nest 4 (ppr alts)) $$ ppr cont
ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
-------------------
-mkRhsStop, mkStop :: OutType -> SimplCont
-mkStop ty = Stop ty False
-mkRhsStop ty = Stop ty (canUpdateInPlace ty)
+mkBoringStop :: OutType -> SimplCont
+mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty)
+
+mkStop :: OutType -> LetRhsFlag -> SimplCont
+mkStop ty is_rhs = Stop ty is_rhs (canUpdateInPlace ty)
+contIsRhs :: SimplCont -> Bool
+contIsRhs (Stop _ AnRhs _) = True
+contIsRhs (ArgOf _ AnRhs _ _) = True
+contIsRhs other = False
+
+contIsRhsOrArg (Stop _ _ _) = True
+contIsRhsOrArg (ArgOf _ _ _ _) = True
+contIsRhsOrArg other = False
-------------------
contIsDupable :: SimplCont -> Bool
-contIsDupable (Stop _ _) = True
+contIsDupable (Stop _ _ _) = True
contIsDupable (ApplyTo OkToDup _ _ _) = True
-contIsDupable (ArgOf OkToDup _ _) = True
+contIsDupable (ArgOf OkToDup _ _ _) = True
contIsDupable (Select OkToDup _ _ _ _) = True
contIsDupable (CoerceIt _ cont) = contIsDupable cont
contIsDupable (InlinePlease cont) = contIsDupable cont
-------------------
discardableCont :: SimplCont -> Bool
-discardableCont (Stop _ _) = False
+discardableCont (Stop _ _ _) = False
discardableCont (CoerceIt _ cont) = discardableCont cont
discardableCont (InlinePlease cont) = discardableCont cont
discardableCont other = True
discardCont :: SimplCont -- A continuation, expecting
-> SimplCont -- Replace the continuation with a suitable coerce
discardCont cont = case cont of
- Stop to_ty _ -> cont
- other -> CoerceIt to_ty (mkStop to_ty)
+ Stop to_ty is_rhs _ -> cont
+ other -> CoerceIt to_ty (mkBoringStop to_ty)
where
to_ty = contResultType cont
-------------------
contResultType :: SimplCont -> OutType
-contResultType (Stop to_ty _) = to_ty
-contResultType (ArgOf _ to_ty _) = to_ty
+contResultType (Stop to_ty _ _) = to_ty
+contResultType (ArgOf _ _ to_ty _) = to_ty
contResultType (ApplyTo _ _ _ cont) = contResultType cont
contResultType (CoerceIt _ cont) = contResultType cont
contResultType (InlinePlease cont) = contResultType cont
\begin{code}
-getContArgs :: OutId -> SimplCont
- -> SimplM ([(InExpr, SubstEnv, Bool)], -- Arguments; the Bool is true for strict args
- SimplCont, -- Remaining continuation
- Bool) -- Whether we came across an InlineCall
+getContArgs :: SwitchChecker
+ -> OutId -> SimplCont
+ -> ([(InExpr, SimplEnv, Bool)], -- Arguments; the Bool is true for strict args
+ SimplCont, -- Remaining continuation
+ Bool) -- Whether we came across an InlineCall
-- getContArgs id k = (args, k', inl)
-- args are the leading ApplyTo items in k
-- (i.e. outermost comes first)
-- augmented with demand info from the functionn
-getContArgs fun orig_cont
- = getSwitchChecker `thenSmpl` \ chkr ->
- let
+getContArgs chkr fun orig_cont
+ = let
-- Ignore strictness info if the no-case-of-case
-- flag is on. Strictness changes evaluation order
-- and that can change full laziness
-- * f (error "Hello") where f is strict
-- etc
go acc ss inl cont
- | null ss && discardableCont cont = tick BottomFound `thenSmpl_`
- returnSmpl (reverse acc, discardCont cont, inl)
- | otherwise = returnSmpl (reverse acc, cont, inl)
+ | null ss && discardableCont cont = (reverse acc, discardCont cont, inl)
+ | otherwise = (reverse acc, cont, inl)
----------------------------
vanilla_stricts, computed_stricts :: [Bool]
-- s = "foo"
-- f = \x -> ...(error s)...
- -- Fundamentally such contexts should not ecourage inlining becuase
+ -- Fundamentally such contexts should not ecourage inlining because
-- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
-- so there's no gain.
--
-- Perhaps True is a bit over-keen, but I've
-- seen (coerce f) x, where f has an INLINE prag,
-- So we have to give some motivaiton for inlining it
- interesting (ArgOf _ _ _) = some_val_args
- interesting (Stop ty upd_in_place) = some_val_args && upd_in_place
- interesting (CoerceIt _ cont) = interesting cont
+ interesting (ArgOf _ _ _ _) = some_val_args
+ interesting (Stop ty _ upd_in_place) = some_val_args && upd_in_place
+ interesting (CoerceIt _ cont) = interesting cont
-- If this call is the arg of a strict function, the context
-- is a bit interesting. If we inline here, we may get useful
-- evaluation information to avoid repeated evals: e.g.
%* *
%************************************************************************
+These functions are in the monad only so that they can be made strict via seq.
+
\begin{code}
-simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
-simplBinders bndrs thing_inside
- = getSubst `thenSmpl` \ subst ->
- let
- (subst', bndrs') = Subst.simplBndrs subst bndrs
+simplBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
+simplBinders env bndrs
+ = let
+ (subst', bndrs') = Subst.simplBndrs (getSubst env) bndrs
in
seqBndrs bndrs' `seq`
- setSubst subst' (thing_inside bndrs')
+ returnSmpl (setSubst env subst', bndrs')
-simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
-simplBinder bndr thing_inside
- = getSubst `thenSmpl` \ subst ->
- let
- (subst', bndr') = Subst.simplBndr subst bndr
+simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
+simplBinder env bndr
+ = let
+ (subst', bndr') = Subst.simplBndr (getSubst env) bndr
in
seqBndr bndr' `seq`
- setSubst subst' (thing_inside bndr')
+ returnSmpl (setSubst env subst', bndr')
-simplLamBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
-simplLamBinder bndr thing_inside
- = getSubst `thenSmpl` \ subst ->
- let
- (subst', bndr') = Subst.simplLamBndr subst bndr
+simplLamBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
+simplLamBinders env bndrs
+ = let
+ (subst', bndrs') = mapAccumL Subst.simplLamBndr (getSubst env) bndrs
in
- seqBndr bndr' `seq`
- setSubst subst' (thing_inside bndr')
-
+ seqBndrs bndrs' `seq`
+ returnSmpl (setSubst env subst', bndrs')
-simplRecIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
-simplRecIds ids thing_inside
- = getSubst `thenSmpl` \ subst ->
- let
- (subst', ids') = mapAccumL Subst.simplLetId subst ids
+simplRecIds :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
+simplRecIds env ids
+ = let
+ (subst', ids') = mapAccumL Subst.simplLetId (getSubst env) ids
in
seqBndrs ids' `seq`
- setSubst subst' (thing_inside ids')
+ returnSmpl (setSubst env subst', ids')
-simplLetId :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
-simplLetId id thing_inside
- = getSubst `thenSmpl` \ subst ->
- let
- (subst', id') = Subst.simplLetId subst id
+simplLetId :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
+simplLetId env id
+ = let
+ (subst', id') = Subst.simplLetId (getSubst env) id
in
- seqBndr id' `seq`
- setSubst subst' (thing_inside id')
+ seqBndr id' `seq`
+ returnSmpl (setSubst env subst', id')
seqBndrs [] = ()
seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
\end{code}
+\begin{code}
+newId :: UserFS -> Type -> SimplM Id
+newId fs ty = getUniqueSmpl `thenSmpl` \ uniq ->
+ returnSmpl (mkSysLocal fs uniq ty)
+\end{code}
+
+
%************************************************************************
%* *
-\subsection{Local tyvar-lifting}
+\subsection{Rebuilding a lambda}
%* *
%************************************************************************
-mkRhsTyLam tries this transformation, when the big lambda appears as
+\begin{code}
+mkLam :: SimplEnv -> [OutBinder] -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
+\end{code}
+
+Try three things
+ a) eta reduction, if that gives a trivial expression
+ b) eta expansion [only if there are some value lambdas]
+ c) floating lets out through big lambdas
+ [only if all tyvar lambdas, and only if this lambda
+ is the RHS of a let]
+
+\begin{code}
+mkLam env bndrs body cont
+ | opt_SimplDoEtaReduction,
+ Just etad_lam <- tryEtaReduce bndrs body
+ = tick (EtaReduction (head bndrs)) `thenSmpl_`
+ returnSmpl (emptyFloats env, etad_lam)
+
+ | opt_SimplDoLambdaEtaExpansion,
+ any isRuntimeVar bndrs
+ = tryEtaExpansion body `thenSmpl` \ body' ->
+ returnSmpl (emptyFloats env, mkLams bndrs body')
+
+{- Sept 01: I'm experimenting with getting the
+ full laziness pass to float out past big lambdsa
+ | all isTyVar bndrs, -- Only for big lambdas
+ contIsRhs cont -- Only try the rhs type-lambda floating
+ -- if this is indeed a right-hand side; otherwise
+ -- we end up floating the thing out, only for float-in
+ -- to float it right back in again!
+ = tryRhsTyLam env bndrs body `thenSmpl` \ (floats, body') ->
+ returnSmpl (floats, mkLams bndrs body')
+-}
+
+ | otherwise
+ = returnSmpl (emptyFloats env, mkLams bndrs body)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Eta expansion and reduction}
+%* *
+%************************************************************************
+
+We try for eta reduction here, but *only* if we get all the
+way to an exprIsTrivial expression.
+We don't want to remove extra lambdas unless we are going
+to avoid allocating this thing altogether
+
+\begin{code}
+tryEtaReduce :: [OutBinder] -> OutExpr -> Maybe OutExpr
+tryEtaReduce bndrs body
+ -- We don't use CoreUtils.etaReduce, because we can be more
+ -- efficient here:
+ -- (a) we already have the binders
+ -- (b) we can do the triviality test before computing the free vars
+ -- [in fact I take the simple path and look for just a variable]
+ = go (reverse bndrs) body
+ where
+ go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
+ go [] (Var fun) | ok_fun fun = Just (Var fun) -- Success!
+ go _ _ = Nothing -- Failure!
+
+ ok_fun fun = not (fun `elem` bndrs) && not (hasNoBinding fun)
+ ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
+\end{code}
+
+
+ Try eta expansion for RHSs
+
+We go for:
+ f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym
+ (n >= 0)
+
+where (in both cases)
+
+ * The xi can include type variables
+
+ * The yi are all value variables
+
+ * N is a NORMAL FORM (i.e. no redexes anywhere)
+ wanting a suitable number of extra args.
+
+We may have to sandwich some coerces between the lambdas
+to make the types work. exprEtaExpandArity looks through coerces
+when computing arity; and etaExpand adds the coerces as necessary when
+actually computing the expansion.
+
+\begin{code}
+tryEtaExpansion :: OutExpr -> SimplM OutExpr
+-- There is at least one runtime binder in the binders
+tryEtaExpansion body
+ | arity_is_manifest -- Some lambdas but not enough
+ = returnSmpl body
+
+ | otherwise
+ = getUniquesSmpl `thenSmpl` \ us ->
+ returnSmpl (etaExpand fun_arity us body (exprType body))
+ where
+ (fun_arity, arity_is_manifest) = exprEtaExpandArity body
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Floating lets out of big lambdas}
+%* *
+%************************************************************************
+
+tryRhsTyLam tries this transformation, when the big lambda appears as
the RHS of a let(rec) binding:
/\abc -> let(rec) x = e in b
\begin{code}
-tryRhsTyLam :: OutExpr -> SimplM ([OutBind], OutExpr)
+{- Trying to do this in full laziness
-tryRhsTyLam rhs -- Only does something if there's a let
- | null tyvars || not (worth_it body) -- inside a type lambda,
- = returnSmpl ([], rhs) -- and a WHNF inside that
+tryRhsTyLam :: SimplEnv -> [OutTyVar] -> OutExpr -> SimplM FloatsWithExpr
+-- Call ensures that all the binders are type variables
+
+tryRhsTyLam env tyvars body -- Only does something if there's a let
+ | not (all isTyVar tyvars)
+ || not (worth_it body) -- inside a type lambda,
+ = returnSmpl (emptyFloats env, body) -- and a WHNF inside that
| otherwise
- = go (\x -> x) body `thenSmpl` \ (binds, body') ->
- returnSmpl (binds, mkLams tyvars body')
+ = go env (\x -> x) body
where
- (tyvars, body) = collectTyBinders rhs
-
worth_it e@(Let _ _) = whnf_in_middle e
worth_it e = False
whnf_in_middle (Let _ e) = whnf_in_middle e
whnf_in_middle e = exprIsCheap e
- go fn (Let bind@(NonRec var rhs) body)
+ main_tyvar_set = mkVarSet tyvars
+
+ go env fn (Let bind@(NonRec var rhs) body)
| exprIsTrivial rhs
- = go (fn . Let bind) body
+ = go env (fn . Let bind) body
- go fn (Let (NonRec var rhs) body)
- = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') ->
- go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ (binds, body') ->
- returnSmpl (NonRec var' (mkLams tyvars_here (fn rhs)) : binds, body')
+ go env fn (Let (NonRec var rhs) body)
+ = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') ->
+ addAuxiliaryBind env (NonRec var' (mkLams tyvars_here (fn rhs))) $ \ env ->
+ go env (fn . Let (mk_silly_bind var rhs')) body
where
- tyvars_here = tyvars
- -- main_tyvar_set = mkVarSet tyvars
- -- var_ty = idType var
- -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
- -- tyvars_here was an attempt to reduce the number of tyvars
+
+ tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprSomeFreeVars isTyVar rhs)
+ -- Abstract only over the type variables free in the rhs
-- wrt which the new binding is abstracted. But the naive
-- approach of abstract wrt the tyvars free in the Id's type
-- fails. Consider:
-- abstracting wrt *all* the tyvars. We'll see if that
-- gives rise to problems. SLPJ June 98
- go fn (Let (Rec prs) body)
+ go env fn (Let (Rec prs) body)
= mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') ->
let
- gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss'))
- new_bind = Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])
+ gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss'))
+ pairs = vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss]
in
- go gn body `thenSmpl` \ (binds, body') ->
- returnSmpl (new_bind : binds, body')
+ addAuxiliaryBind env (Rec pairs) $ \ env ->
+ go env gn body
where
(vars,rhss) = unzip prs
- tyvars_here = tyvars
- -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys)
- -- var_tys = map idType vars
+ tyvars_here = varSetElems (main_tyvar_set `intersectVarSet` exprsSomeFreeVars isTyVar (map snd prs))
-- See notes with tyvars_here above
- go fn body = returnSmpl ([], fn body)
+ go env fn body = returnSmpl (emptyFloats env, fn body)
mk_poly tyvars_here var
= getUniqueSmpl `thenSmpl` \ uniq ->
-- Solution: put an INLINE note on g's RHS, so that poly_g seems
-- to appear many times. (NB: mkInlineMe eliminates
-- such notes on trivial RHSs, so do it manually.)
+-}
\end{code}
%************************************************************************
%* *
-\subsection{Eta expansion}
+\subsection{Case absorption and identity-case elimination}
%* *
%************************************************************************
- Try eta expansion for RHSs
+mkCase puts a case expression back together, trying various transformations first.
-We go for:
- Case 1 f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym
- (n >= 0)
- OR
- Case 2 f = N E1..En ==> z1=E1
- (n > 0) ..
- zn=En
- f = \y1..ym -> N z1..zn y1..ym
+\begin{code}
+mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
-where (in both cases)
+mkCase scrut case_bndr alts
+ = mkAlts scrut case_bndr alts `thenSmpl` \ better_alts ->
+ mkCase1 scrut case_bndr better_alts
+\end{code}
- * The xi can include type variables
- * The yi are all value variables
+mkAlts tries these things:
- * N is a NORMAL FORM (i.e. no redexes anywhere)
- wanting a suitable number of extra args.
+1. If several alternatives are identical, merge them into
+ a single DEFAULT alternative. I've occasionally seen this
+ making a big difference:
- * the Ei must not have unlifted type
+ case e of =====> case e of
+ C _ -> f x D v -> ....v....
+ D v -> ....v.... DEFAULT -> f x
+ DEFAULT -> f x
-There is no point in looking for a combination of the two, because
-that would leave use with some lets sandwiched between lambdas; that's
-what the final test in the first equation is for.
+ The point is that we merge common RHSs, at least for the DEFAULT case.
+ [One could do something more elaborate but I've never seen it needed.]
+ To avoid an expensive test, we just merge branches equal to the *first*
+ alternative; this picks up the common cases
+ a) all branches equal
+ b) some branches equal to the DEFAULT (which occurs first)
+
+2. If the DEFAULT alternative can match only one possible constructor,
+ then make that constructor explicit.
+ e.g.
+ case e of x { DEFAULT -> rhs }
+ ===>
+ case e of x { (a,b) -> rhs }
+ where the type is a single constructor type. This gives better code
+ when rhs also scrutinises x or e.
+
+3. Case merging:
+ case e of b { ==> case e of b {
+ p1 -> rhs1 p1 -> rhs1
+ ... ...
+ pm -> rhsm pm -> rhsm
+ _ -> case b of b' { pn -> let b'=b in rhsn
+ pn -> rhsn ...
+ ... po -> let b'=b in rhso
+ po -> rhso _ -> let b'=b in rhsd
+ _ -> rhsd
+ }
+
+ which merges two cases in one case when -- the default alternative of
+ the outer case scrutises the same variable as the outer case This
+ transformation is called Case Merging. It avoids that the same
+ variable is scrutinised multiple times.
+
+
+The case where transformation (1) showed up was like this (lib/std/PrelCError.lhs):
-In Case 1, we may have to sandwich some coerces between the lambdas
-to make the types work. exprEtaExpandArity looks through coerces
-when computing arity; and etaExpand adds the coerces as necessary when
-actually computing the expansion.
+ x | p `is` 1 -> e1
+ | p `is` 2 -> e2
+ ...etc...
-\begin{code}
-tryEtaExpansion :: OutExpr -> OutType -> SimplM ([OutBind], OutExpr)
-tryEtaExpansion rhs rhs_ty
- | not opt_SimplDoLambdaEtaExpansion -- Not if switched off
- || exprIsTrivial rhs -- Not if RHS is trivial
- || final_arity == 0 -- Not if arity is zero
- = returnSmpl ([], rhs)
-
- | n_val_args == 0 && not arity_is_manifest
- = -- Some lambdas but not enough: case 1
- getUniqSupplySmpl `thenSmpl` \ us ->
- returnSmpl ([], etaExpand final_arity us rhs rhs_ty)
-
- | n_val_args > 0 && not (any cant_bind arg_infos)
- = -- Partial application: case 2
- mapAndUnzipSmpl bind_z_arg arg_infos `thenSmpl` \ (maybe_z_binds, z_args) ->
- getUniqSupplySmpl `thenSmpl` \ us ->
- returnSmpl (catMaybes maybe_z_binds,
- etaExpand final_arity us (mkApps fun z_args) rhs_ty)
+where @is@ was something like
+
+ p `is` n = p /= (-1) && p == n
- | otherwise
- = returnSmpl ([], rhs)
- where
- (fun, args) = collectArgs rhs
- n_val_args = valArgCount args
- (fun_arity, arity_is_manifest) = exprEtaExpandArity fun
- final_arity = 0 `max` (fun_arity - n_val_args)
- arg_infos = [(arg, exprType arg, exprIsTrivial arg) | arg <- args]
- cant_bind (_, ty, triv) = not triv && isUnLiftedType ty
-
- bind_z_arg (arg, arg_ty, trivial_arg)
- | trivial_arg = returnSmpl (Nothing, arg)
- | otherwise = newId SLIT("z") arg_ty $ \ z ->
- returnSmpl (Just (NonRec z arg), Var z)
-\end{code}
+This gave rise to a horrible sequence of cases
+ case p of
+ (-1) -> $j p
+ 1 -> e1
+ DEFAULT -> $j p
-%************************************************************************
-%* *
-\subsection{Case absorption and identity-case elimination}
-%* *
-%************************************************************************
+and similarly in cascade for all the join points!
-\begin{code}
-mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
-\end{code}
-@mkCase@ tries the following transformation (if possible):
-
-case e of b { ==> case e of b {
- p1 -> rhs1 p1 -> rhs1
- ... ...
- pm -> rhsm pm -> rhsm
- _ -> case b of b' { pn -> rhsn[b/b'] {or (alg) let b=b' in rhsn}
- {or (prim) case b of b' { _ -> rhsn}}
- pn -> rhsn ...
- ... po -> rhso[b/b']
- po -> rhso _ -> rhsd[b/b'] {or let b'=b in rhsd}
- _ -> rhsd
-}
-
-which merges two cases in one case when -- the default alternative of
-the outer case scrutises the same variable as the outer case This
-transformation is called Case Merging. It avoids that the same
-variable is scrutinised multiple times.
\begin{code}
-mkCase scrut outer_bndr outer_alts
- | opt_SimplCaseMerge
- && maybeToBool maybe_case_in_default
-
- = tick (CaseMerge outer_bndr) `thenSmpl_`
- returnSmpl (Case scrut outer_bndr new_alts)
- -- Warning: don't call mkCase recursively!
+--------------------------------------------------
+-- 1. Merge identical branches
+--------------------------------------------------
+mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
+ | all isDeadBinder bndrs1, -- Remember the default
+ length filtered_alts < length con_alts -- alternative comes first
+ = tick (AltMerge case_bndr) `thenSmpl_`
+ returnSmpl better_alts
+ where
+ filtered_alts = filter keep con_alts
+ keep (con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
+ better_alts = (DEFAULT, [], rhs1) : filtered_alts
+
+
+--------------------------------------------------
+-- 2. Fill in missing constructor
+--------------------------------------------------
+
+mkAlts scrut case_bndr alts
+ | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
+ isDataTyCon tycon, -- It's a data type
+ (alts_no_deflt, Just rhs) <- findDefault alts,
+ -- There is a DEFAULT case
+ [missing_con] <- filter is_missing (tyConDataConsIfAvailable tycon)
+ -- There is just one missing constructor!
+ = tick (FillInCaseDefault case_bndr) `thenSmpl_`
+ getUniquesSmpl `thenSmpl` \ tv_uniqs ->
+ getUniquesSmpl `thenSmpl` \ id_uniqs ->
+ let
+ (_,_,ex_tyvars,_,_,_) = dataConSig missing_con
+ ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
+ mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
+ arg_ids = zipWith (mkSysLocal SLIT("a")) id_uniqs arg_tys
+ arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
+ better_alts = (DataAlt missing_con, ex_tyvars' ++ arg_ids, rhs) : alts_no_deflt
+ in
+ returnSmpl better_alts
+ where
+ impossible_cons = otherCons (idUnfolding case_bndr)
+ handled_data_cons = [data_con | DataAlt data_con <- impossible_cons] ++
+ [data_con | (DataAlt data_con, _, _) <- alts]
+ is_missing con = not (con `elem` handled_data_cons)
+
+--------------------------------------------------
+-- 3. Merge nested cases
+--------------------------------------------------
+
+mkAlts scrut outer_bndr outer_alts
+ | opt_SimplCaseMerge,
+ (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
+ Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
+ scruting_same_var scrut_var
+
+ = let -- Eliminate any inner alts which are shadowed by the outer ones
+ outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
+
+ munged_inner_alts = [ (con, args, munge_rhs rhs)
+ | (con, args, rhs) <- inner_alts,
+ not (con `elem` outer_cons) -- Eliminate shadowed inner alts
+ ]
+ munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
+
+ (inner_con_alts, maybe_inner_default) = findDefault munged_inner_alts
+
+ new_alts = add_default maybe_inner_default
+ (outer_alts_without_deflt ++ inner_con_alts)
+ in
+ tick (CaseMerge outer_bndr) `thenSmpl_`
+ returnSmpl new_alts
+ -- Warning: don't call mkAlts recursively!
-- Firstly, there's no point, because inner alts have already had
-- mkCase applied to them, so they won't have a case in their default
- -- Secondly, if you do, you get an infinite loop, because the bindNonRec
- -- in munge_rhs puts a case into the DEFAULT branch!
+ -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
+ -- in munge_rhs may put a case into the DEFAULT branch!
where
- new_alts = add_default maybe_inner_default
- (outer_alts_without_deflt ++ inner_con_alts)
+ -- We are scrutinising the same variable if it's
+ -- the outer case-binder, or if the outer case scrutinises a variable
+ -- (and it's the same). Testing both allows us not to replace the
+ -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
+ scruting_same_var = case scrut of
+ Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
+ other -> \ v -> v == outer_bndr
+
+ add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts
+ add_default Nothing alts = alts
- maybe_case_in_default = case findDefault outer_alts of
- (outer_alts_without_default,
- Just (Case (Var scrut_var) inner_bndr inner_alts))
- | outer_bndr == scrut_var
- -> Just (outer_alts_without_default, inner_bndr, inner_alts)
- other -> Nothing
- Just (outer_alts_without_deflt, inner_bndr, inner_alts) = maybe_case_in_default
+--------------------------------------------------
+-- Catch-all
+--------------------------------------------------
- -- Eliminate any inner alts which are shadowed by the outer ones
- outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
+mkAlts scrut case_bndr other_alts = returnSmpl other_alts
+\end{code}
- munged_inner_alts = [ (con, args, munge_rhs rhs)
- | (con, args, rhs) <- inner_alts,
- not (con `elem` outer_cons) -- Eliminate shadowed inner alts
- ]
- munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs
- (inner_con_alts, maybe_inner_default) = findDefault munged_inner_alts
- add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts
- add_default Nothing alts = alts
-\end{code}
+=================================================================================
+
+mkCase1 tries these things
+
+1. Eliminate the case altogether if possible
-Now the identity-case transformation:
+2. Case-identity:
case e of ===> e
True -> True;
False -> False
-and similar friends.
+ and similar friends.
+
+
+Start with a simple situation:
+
+ case x# of ===> e[x#/y#]
+ y# -> e
+
+(when x#, y# are of primitive type, of course). We can't (in general)
+do this for algebraic cases, because we might turn bottom into
+non-bottom!
+
+Actually, we generalise this idea to look for a case where we're
+scrutinising a variable, and we know that only the default case can
+match. For example:
+\begin{verbatim}
+ case x of
+ 0# -> ...
+ other -> ...(case x of
+ 0# -> ...
+ other -> ...) ...
+\end{code}
+Here the inner case can be eliminated. This really only shows up in
+eliminating error-checking code.
+
+We also make sure that we deal with this very common case:
+
+ case e of
+ x -> ...x...
+
+Here we are using the case as a strict let; if x is used only once
+then we want to inline it. We have to be careful that this doesn't
+make the program terminate when it would have diverged before, so we
+check that
+ - x is used strictly, or
+ - e is already evaluated (it may so if e is a variable)
+
+Lastly, we generalise the transformation to handle this:
+
+ case e of ===> r
+ True -> r
+ False -> r
+
+We only do this for very cheaply compared r's (constructors, literals
+and variables). If pedantic bottoms is on, we only do it when the
+scrutinee is a PrimOp which can't fail.
+
+We do it *here*, looking at un-simplified alternatives, because we
+have to check that r doesn't mention the variables bound by the
+pattern in each alternative, so the binder-info is rather useful.
+
+So the case-elimination algorithm is:
+
+ 1. Eliminate alternatives which can't match
+
+ 2. Check whether all the remaining alternatives
+ (a) do not mention in their rhs any of the variables bound in their pattern
+ and (b) have equal rhss
+
+ 3. Check we can safely ditch the case:
+ * PedanticBottoms is off,
+ or * the scrutinee is an already-evaluated variable
+ or * the scrutinee is a primop which is ok for speculation
+ -- ie we want to preserve divide-by-zero errors, and
+ -- calls to error itself!
+
+ or * [Prim cases] the scrutinee is a primitive variable
+
+ or * [Alg cases] the scrutinee is a variable and
+ either * the rhs is the same variable
+ (eg case x of C a b -> x ===> x)
+ or * there is only one alternative, the default alternative,
+ and the binder is used strictly in its scope.
+ [NB this is helped by the "use default binder where
+ possible" transformation; see below.]
+
+
+If so, then we can replace the case with one of the rhss.
+
\begin{code}
-mkCase scrut case_bndr alts
+--------------------------------------------------
+-- 1. Eliminate the case altogether if poss
+--------------------------------------------------
+
+mkCase1 scrut case_bndr [(con,bndrs,rhs)]
+ -- See if we can get rid of the case altogether
+ -- See the extensive notes on case-elimination above
+ -- mkCase made sure that if all the alternatives are equal,
+ -- then there is now only one (DEFAULT) rhs
+ | all isDeadBinder bndrs,
+
+ -- Check that the scrutinee can be let-bound instead of case-bound
+ exprOkForSpeculation scrut
+ -- OK not to evaluate it
+ -- This includes things like (==# a# b#)::Bool
+ -- so that we simplify
+ -- case ==# a# b# of { True -> x; False -> x }
+ -- to just
+ -- x
+ -- This particular example shows up in default methods for
+ -- comparision operations (e.g. in (>=) for Int.Int32)
+ || exprIsValue scrut -- It's already evaluated
+ || var_demanded_later scrut -- It'll be demanded later
+
+-- || not opt_SimplPedanticBottoms) -- Or we don't care!
+-- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
+-- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
+-- its argument: case x of { y -> dataToTag# y }
+-- Here we must *not* discard the case, because dataToTag# just fetches the tag from
+-- the info pointer. So we'll be pedantic all the time, and see if that gives any
+-- other problems
+ = tick (CaseElim case_bndr) `thenSmpl_`
+ returnSmpl (bindCaseBndr case_bndr scrut rhs)
+
+ where
+ -- The case binder is going to be evaluated later,
+ -- and the scrutinee is a simple variable
+ var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo case_bndr)
+ var_demanded_later other = False
+
+
+--------------------------------------------------
+-- 2. Identity case
+--------------------------------------------------
+
+mkCase1 scrut case_bndr alts -- Identity case
| all identity_alt alts
= tick (CaseIdentity case_bndr) `thenSmpl_`
returnSmpl (re_note scrut)
re_note scrut = case head alts of
(_,_,rhs1@(Note _ _)) -> mkCoerce (exprType rhs1) (idType case_bndr) scrut
other -> scrut
-\end{code}
-
-The catch-all case. We do a final transformation that I've
-occasionally seen making a big difference:
- case e of =====> case e of
- C _ -> f x D v -> ....v....
- D v -> ....v.... DEFAULT -> f x
- DEFAULT -> f x
-
-The point is that we merge common RHSs, at least for the DEFAULT case.
-[One could do something more elaborate but I've never seen it needed.]
-The case where this came up was like this (lib/std/PrelCError.lhs):
-
- x | p `is` 1 -> e1
- | p `is` 2 -> e2
- ...etc...
-where @is@ was something like
-
- p `is` n = p /= (-1) && p == n
+--------------------------------------------------
+-- Catch-all
+--------------------------------------------------
+mkCase1 scrut bndr alts = returnSmpl (Case scrut bndr alts)
+\end{code}
-This gave rise to a horrible sequence of cases
- case p of
- (-1) -> $j p
- 1 -> e1
- DEFAULT -> $j p
+When adding auxiliary bindings for the case binder, it's worth checking if
+its dead, because it often is, and occasionally these mkCase transformations
+cascade rather nicely.
-and similarly in cascade for all the join points!
-
\begin{code}
-mkCase other_scrut case_bndr other_alts
- = returnSmpl (Case other_scrut case_bndr (mergeDefault other_alts))
-
-mergeDefault (deflt_alt@(DEFAULT,_,deflt_rhs) : con_alts)
- = deflt_alt : [alt | alt@(con,_,rhs) <- con_alts, not (rhs `cheapEqExpr` deflt_rhs)]
- -- NB: we can neglect the binders because we won't get equality if the
- -- binders are mentioned in rhs (no shadowing)
-mergeDefault other_alts
- = other_alts
+bindCaseBndr bndr rhs body
+ | isDeadBinder bndr = body
+ | otherwise = bindNonRec bndr rhs body
\end{code}
#include "HsVersions.h"
-import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction,
- opt_SimplNoPreInlining,
- dopt, DynFlag(Opt_D_dump_inlinings),
+import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings),
SimplifierSwitch(..)
)
import SimplMonad
-import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion,
- simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinder,
- SimplCont(..), DupFlag(..), mkStop, mkRhsStop,
- contResultType, discardInline, countArgs, contIsDupable,
+import SimplUtils ( mkCase, mkLam, newId,
+ simplBinder, simplLamBinders, simplBinders, simplRecIds, simplLetId,
+ SimplCont(..), DupFlag(..), LetRhsFlag(..),
+ mkStop, mkBoringStop,
+ contResultType, discardInline, countArgs, contIsDupable, contIsRhsOrArg,
getContArgs, interestingCallContext, interestingArg, isStrictType
)
-import Var ( mkSysTyVar, tyVarKind, mustHaveLocalBinding )
+import Var ( mustHaveLocalBinding )
import VarEnv
-import Literal ( Literal )
-import Id ( Id, idType, idInfo, isDataConId, hasNoBinding,
- idUnfolding, setIdUnfolding, isExportedId, isDeadBinder,
+import Id ( Id, idType, idInfo, idArity, isDataConId,
+ idUnfolding, setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
- idOccInfo, setIdOccInfo,
+ setIdOccInfo,
zapLamIdInfo, setOneShotLambda,
)
-import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker,
+import IdInfo ( OccInfo(..), isLoopBreaker,
setArityInfo,
setUnfoldingInfo,
occInfo
)
import NewDemand ( isStrictDmd )
-import DataCon ( dataConNumInstArgs, dataConRepStrictness,
- dataConSig, dataConArgTys
- )
+import DataCon ( dataConNumInstArgs, dataConRepStrictness )
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
-import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons,
- callSiteInline
- )
-import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial,
+import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline )
+import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiType, findAlt, findDefault,
exprType, coreAltsType, exprIsValue,
exprOkForSpeculation, exprArity,
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
-import Type ( mkTyVarTys, isUnLiftedType, seqType,
- mkFunTy, splitTyConApp_maybe, tyConAppArgs,
+import Type ( isUnLiftedType, seqType, mkFunTy, tyConAppArgs,
funResultTy, splitFunTy_maybe, splitFunTy, eqType
)
-import Subst ( mkSubst, substTy, substEnv, substExpr,
+import Subst ( mkSubst, substTy, substExpr,
isInScope, lookupIdSubst, simplIdInfo
)
-import TyCon ( isDataTyCon, tyConDataConsIfAvailable )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
+import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
+ RecFlag(..), isNonRec
+ )
import OrdList
-import Maybes ( maybeToBool )
+import Maybe ( Maybe )
import Outputable
\end{code}
-The guts of the simplifier is in this module, but the driver
-loop for the simplifier is in SimplCore.lhs.
+The guts of the simplifier is in this module, but the driver loop for
+the simplifier is in SimplCore.lhs.
-----------------------------------------
documented with simplifyArgs.
+-----------------------------------------
+ *** IMPORTANT NOTE ***
+-----------------------------------------
+Many parts of the simplifier return a bunch of "floats" as well as an
+expression. This is wrapped as a datatype SimplUtils.FloatsWith.
+
+All "floats" are let-binds, not case-binds, but some non-rec lets may
+be unlifted (with RHS ok-for-speculation).
+
+
+
+-----------------------------------------
+ ORGANISATION OF FUNCTIONS
+-----------------------------------------
+simplTopBinds
+ - simplify all top-level binders
+ - for NonRec, call simplRecOrTopPair
+ - for Rec, call simplRecBind
+
+
+ ------------------------------
+simplExpr (applied lambda) ==> simplNonRecBind
+simplExpr (Let (NonRec ...) ..) ==> simplNonRecBind
+simplExpr (Let (Rec ...) ..) ==> simplify binders; simplRecBind
+
+ ------------------------------
+simplRecBind [binders already simplfied]
+ - use simplRecOrTopPair on each pair in turn
+
+simplRecOrTopPair [binder already simplified]
+ Used for: recursive bindings (top level and nested)
+ top-level non-recursive bindings
+ Returns:
+ - check for PreInlineUnconditionally
+ - simplLazyBind
+
+simplNonRecBind
+ Used for: non-top-level non-recursive bindings
+ beta reductions (which amount to the same thing)
+ Because it can deal with strict arts, it takes a
+ "thing-inside" and returns an expression
+
+ - check for PreInlineUnconditionally
+ - simplify binder, including its IdInfo
+ - if strict binding
+ simplStrictArg
+ mkAtomicArgs
+ completeNonRecX
+ else
+ simplLazyBind
+ addFloats
+
+simplNonRecX: [given a *simplified* RHS, but an *unsimplified* binder]
+ Used for: binding case-binder and constr args in a known-constructor case
+ - check for PreInLineUnconditionally
+ - simplify binder
+ - completeNonRecX
+
+ ------------------------------
+simplLazyBind: [binder already simplified, RHS not]
+ Used for: recursive bindings (top level and nested)
+ top-level non-recursive bindings
+ non-top-level, but *lazy* non-recursive bindings
+ [must not be strict or unboxed]
+ Returns floats + an augmented environment, not an expression
+ - substituteIdInfo and add result to in-scope
+ [so that rules are available in rec rhs]
+ - simplify rhs
+ - mkAtomicArgs
+ - float if exposes constructor or PAP
+ - completeLazyBind
+
+
+completeNonRecX: [binder and rhs both simplified]
+ - if the the thing needs case binding (unlifted and not ok-for-spec)
+ build a Case
+ else
+ completeLazyBind
+ addFloats
+
+completeLazyBind: [given a simplified RHS]
+ [used for both rec and non-rec bindings, top level and not]
+ - try PostInlineUnconditionally
+ - add unfolding [this is the only place we add an unfolding]
+ - add arity
+
+
+
+Right hand sides and arguments
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In many ways we want to treat
+ (a) the right hand side of a let(rec), and
+ (b) a function argument
+in the same way. But not always! In particular, we would
+like to leave these arguments exactly as they are, so they
+will match a RULE more easily.
+
+ f (g x, h x)
+ g (+ x)
+
+It's harder to make the rule match if we ANF-ise the constructor,
+or eta-expand the PAP:
+
+ f (let { a = g x; b = h x } in (a,b))
+ g (\y. + x y)
+
+On the other hand if we see the let-defns
+
+ p = (g x, h x)
+ q = + x
+
+then we *do* want to ANF-ise and eta-expand, so that p and q
+can be safely inlined.
+
+Even floating lets out is a bit dubious. For let RHS's we float lets
+out if that exposes a value, so that the value can be inlined more vigorously.
+For example
+
+ r = let x = e in (x,x)
+
+Here, if we float the let out we'll expose a nice constructor. We did experiments
+that showed this to be a generally good thing. But it was a bad thing to float
+lets out unconditionally, because that meant they got allocated more often.
+
+For function arguments, there's less reason to expose a constructor (it won't
+get inlined). Just possibly it might make a rule match, but I'm pretty skeptical.
+So for the moment we don't float lets out of function arguments either.
+
+
+Eta expansion
+~~~~~~~~~~~~~~
+For eta expansion, we want to catch things like
+
+ case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
+
+If the \x was on the RHS of a let, we'd eta expand to bring the two
+lambdas together. And in general that's a good thing to do. Perhaps
+we should eta expand wherever we find a (value) lambda? Then the eta
+expansion at a let RHS can concentrate solely on the PAP case.
%************************************************************************
%************************************************************************
\begin{code}
-simplTopBinds :: [InBind] -> SimplM [OutBind]
+simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind]
-simplTopBinds binds
+simplTopBinds env binds
= -- Put all the top-level binders into scope at the start
-- so that if a transformation rule has unexpectedly brought
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
- simplRecIds (bindersOfBinds binds) $ \ bndrs' ->
- simpl_binds binds bndrs' `thenSmpl` \ (binds', _) ->
- freeTick SimplifierDone `thenSmpl_`
- returnSmpl (fromOL binds')
+ simplRecIds env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') ->
+ simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
+ freeTick SimplifierDone `thenSmpl_`
+ returnSmpl (floatBinds floats)
where
-
-- We need to track the zapped top-level binders, because
-- they should have their fragile IdInfo zapped (notably occurrence info)
- simpl_binds [] bs = ASSERT( null bs ) returnSmpl (nilOL, panic "simplTopBinds corner")
- simpl_binds (NonRec bndr rhs : binds) (b:bs) = simplLazyBind True bndr b rhs (simpl_binds binds bs)
- simpl_binds (Rec pairs : binds) bs = simplRecBind True pairs (take n bs) (simpl_binds binds (drop n bs))
- where
- n = length pairs
-
-simplRecBind :: Bool -> [(InId, InExpr)] -> [OutId]
- -> SimplM (OutStuff a) -> SimplM (OutStuff a)
-simplRecBind top_lvl pairs bndrs' thing_inside
- = go pairs bndrs' `thenSmpl` \ (binds', (_, (binds'', res))) ->
- returnSmpl (unitOL (Rec (flattenBinds (fromOL binds'))) `appOL` binds'', res)
+ -- That's why we run down binds and bndrs' simultaneously.
+ simpl_binds :: SimplEnv -> [InBind] -> [OutId] -> SimplM (FloatsWith ())
+ simpl_binds env [] bs = ASSERT( null bs ) returnSmpl (emptyFloats env, ())
+ simpl_binds env (bind:binds) bs = simpl_bind env bind bs `thenSmpl` \ (floats,env) ->
+ addFloats env floats $ \env ->
+ simpl_binds env binds (drop_bs bind bs)
+
+ drop_bs (NonRec _ _) (_ : bs) = bs
+ drop_bs (Rec prs) bs = drop (length prs) bs
+
+ simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
+ simpl_bind env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs'
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{simplNonRec}
+%* *
+%************************************************************************
+
+simplNonRecBind is used for
+ * non-top-level non-recursive lets in expressions
+ * beta reduction
+
+It takes
+ * An unsimplified (binder, rhs) pair
+ * The env for the RHS. It may not be the same as the
+ current env because the bind might occur via (\x.E) arg
+
+It uses the CPS form because the binding might be strict, in which
+case we might discard the continuation:
+ let x* = error "foo" in (...x...)
+
+It needs to turn unlifted bindings into a @case@. They can arise
+from, say: (\x -> e) (4# + 3#)
+
+\begin{code}
+simplNonRecBind :: SimplEnv
+ -> InId -- Binder
+ -> InExpr -> SimplEnv -- Arg, with its subst-env
+ -> OutType -- Type of thing computed by the context
+ -> (SimplEnv -> SimplM FloatsWithExpr) -- The body
+ -> SimplM FloatsWithExpr
+#ifdef DEBUG
+simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
+ | isTyVar bndr
+ = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs)
+#endif
+
+simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
+ | preInlineUnconditionally env NotTopLevel bndr
+ = tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ thing_inside (extendSubst env bndr (ContEx (getSubstEnv rhs_se) rhs))
+
+
+ | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let
+ = -- Don't use simplBinder because that doesn't keep
+ -- fragile occurrence in the substitution
+ simplLetId env bndr `thenSmpl` \ (env, bndr') ->
+ simplStrictArg env AnRhs rhs rhs_se cont_ty $ \ env rhs1 ->
+
+ -- Make the arguments atomic if necessary,
+ -- adding suitable bindings
+ mkAtomicArgs True True rhs1 `thenSmpl` \ (aux_binds, rhs2) ->
+ addAtomicBindsE env aux_binds $ \ env ->
+
+ -- Now complete the binding and simplify the body
+ completeNonRecX env bndr bndr' rhs2 thing_inside
+
+ | otherwise -- Normal, lazy case
+ = -- Don't use simplBinder because that doesn't keep
+ -- fragile occurrence in the substitution
+ simplLetId env bndr `thenSmpl` \ (env, bndr') ->
+ simplLazyBind env NotTopLevel NonRecursive
+ bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
+ addFloats env floats thing_inside
+\end{code}
+
+A specialised variant of simplNonRec used when the RHS is already simplified, notably
+in knownCon. It uses case-binding where necessary.
+
+\begin{code}
+simplNonRecX :: SimplEnv
+ -> InId -- Old binder
+ -> OutExpr -- Simplified RHS
+ -> (SimplEnv -> SimplM FloatsWithExpr)
+ -> SimplM FloatsWithExpr
+
+simplNonRecX env bndr new_rhs thing_inside
+ | preInlineUnconditionally env NotTopLevel bndr
+ -- This happens; for example, the case_bndr during case of
+ -- known constructor: case (a,b) of x { (p,q) -> ... }
+ -- Here x isn't mentioned in the RHS, so we don't want to
+ -- create the (dead) let-binding let x = (a,b) in ...
+ --
+ -- Similarly, single occurrences can be inlined vigourously
+ -- e.g. case (f x, g y) of (a,b) -> ....
+ -- If a,b occur once we can avoid constructing the let binding for them.
+ = thing_inside (extendSubst env bndr (ContEx emptySubstEnv new_rhs))
+
+ | otherwise
+ = simplBinder env bndr `thenSmpl` \ (env, bndr') ->
+ completeNonRecX env bndr bndr' new_rhs thing_inside
+
+completeNonRecX env old_bndr new_bndr new_rhs thing_inside
+ | needsCaseBinding (idType new_bndr) new_rhs
+ = thing_inside env `thenSmpl` \ (floats, body) ->
+ returnSmpl (emptyFloats env, Case new_rhs new_bndr [(DEFAULT, [], wrapFloats floats body)])
+
+ | otherwise
+ = completeLazyBind env NotTopLevel
+ old_bndr new_bndr new_rhs `thenSmpl` \ (floats, env) ->
+ addFloats env floats thing_inside
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Lazy bindings}
+%* *
+%************************************************************************
+
+simplRecBind is used for
+ * recursive bindings only
+
+\begin{code}
+simplRecBind :: SimplEnv -> TopLevelFlag
+ -> [(InId, InExpr)] -> [OutId]
+ -> SimplM (FloatsWith SimplEnv)
+simplRecBind env top_lvl pairs bndrs'
+ = go env pairs bndrs' `thenSmpl` \ (floats, env) ->
+ returnSmpl (flattenFloats floats, env)
where
- go [] _ = thing_inside `thenSmpl` \ stuff ->
- returnOutStuff stuff
+ go env [] _ = returnSmpl (emptyFloats env, env)
- go ((bndr, rhs) : pairs) (bndr' : bndrs')
- = simplLazyBind top_lvl bndr bndr' rhs (go pairs bndrs')
- -- Don't float unboxed bindings out,
- -- because we can't "rec" them
+ go env ((bndr, rhs) : pairs) (bndr' : bndrs')
+ = simplRecOrTopPair env top_lvl bndr bndr' rhs `thenSmpl` \ (floats, env) ->
+ addFloats env floats (\env -> go env pairs bndrs')
+\end{code}
+
+
+simplRecOrTopPair is used for
+ * recursive bindings (whether top level or not)
+ * top-level non-recursive bindings
+
+It assumes the binder has already been simplified, but not its IdInfo.
+
+\begin{code}
+simplRecOrTopPair :: SimplEnv
+ -> TopLevelFlag
+ -> InId -> OutId -- Binder, both pre-and post simpl
+ -> InExpr -- The RHS and its environment
+ -> SimplM (FloatsWith SimplEnv)
+
+simplRecOrTopPair env top_lvl bndr bndr' rhs
+ | preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
+ = tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ returnSmpl (emptyFloats env, extendSubst env bndr (ContEx (getSubstEnv env) rhs))
+
+ | otherwise
+ = simplLazyBind env top_lvl Recursive bndr bndr' rhs env
+ -- May not actually be recursive, but it doesn't matter
+\end{code}
+
+
+simplLazyBind is used for
+ * recursive bindings (whether top level or not)
+ * top-level non-recursive bindings
+ * non-top-level *lazy* non-recursive bindings
+
+[Thus it deals with the lazy cases from simplNonRecBind, and all cases
+from SimplRecOrTopBind]
+
+Nota bene:
+ 1. It assumes that the binder is *already* simplified,
+ and is in scope, but not its IdInfo
+
+ 2. It assumes that the binder type is lifted.
+
+ 3. It does not check for pre-inline-unconditionallly;
+ that should have been done already.
+
+\begin{code}
+simplLazyBind :: SimplEnv
+ -> TopLevelFlag -> RecFlag
+ -> InId -> OutId -- Binder, both pre-and post simpl
+ -> InExpr -> SimplEnv -- The RHS and its environment
+ -> SimplM (FloatsWith SimplEnv)
+
+simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
+ = -- Substitute IdInfo on binder, in the light of earlier
+ -- substitutions in this very letrec, and extend the
+ -- in-scope env, so that the IdInfo for this binder extends
+ -- over the RHS for the binder itself.
+ --
+ -- This is important. Manuel found cases where he really, really
+ -- wanted a RULE for a recursive function to apply in that function's
+ -- own right-hand side.
+ --
+ -- NB: does no harm for non-recursive bindings
+ let
+ bndr_ty' = idType bndr'
+ bndr'' = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr'
+ env1 = modifyInScope env bndr'' bndr''
+ rhs_env = setInScope rhs_se env1
+ ok_float_unlifted = isNotTopLevel top_lvl && isNonRec is_rec
+ rhs_cont = mkStop bndr_ty' AnRhs
+ in
+ -- Simplify the RHS; note the mkStop, which tells
+ -- the simplifier that this is the RHS of a let.
+ simplExprF rhs_env rhs rhs_cont `thenSmpl` \ (floats, rhs1) ->
+
+ -- If any of the floats can't be floated, give up now
+ -- (The allLifted predicate says True for empty floats.)
+ if (not ok_float_unlifted && not (allLifted floats)) then
+ completeLazyBind env1 top_lvl bndr bndr''
+ (wrapFloats floats rhs1)
+ else
+
+ -- ANF-ise a constructor or PAP rhs
+ mkAtomicArgs False {- Not strict -}
+ ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) ->
+
+ -- If the result is a PAP, float the floats out, else wrap them
+ -- By this time it's already been ANF-ised (if necessary)
+ if isEmptyFloats floats && null aux_binds then -- Shortcut a common case
+ completeLazyBind env1 top_lvl bndr bndr'' rhs2
+
+ -- We use exprIsTrivial here because we want to reveal lone variables.
+ -- E.g. let { x = letrec { y = E } in y } in ...
+ -- Here we definitely want to float the y=E defn.
+ -- exprIsValue definitely isn't right for that.
+ --
+ -- BUT we can't use "exprIsCheap", because that causes a strictness bug.
+ -- x = let y* = E in case (scc y) of { T -> F; F -> T}
+ -- The case expression is 'cheap', but it's wrong to transform to
+ -- y* = E; x = case (scc y) of {...}
+ -- Either we must be careful not to float demanded non-values, or
+ -- we must use exprIsValue for the test, which ensures that the
+ -- thing is non-strict. I think. The WARN below tests for this
+ else if exprIsTrivial rhs2 || exprIsValue rhs2 then
+ -- There's a subtlety here. There may be a binding (x* = e) in the
+ -- floats, where the '*' means 'will be demanded'. So is it safe
+ -- to float it out? Answer no, but it won't matter because
+ -- we only float if arg' is a WHNF,
+ -- and so there can't be any 'will be demanded' bindings in the floats.
+ -- Hence the assert
+ WARN( any demanded_float (floatBinds floats),
+ ppr (filter demanded_float (floatBinds floats)) )
+
+ tick LetFloatFromLet `thenSmpl_` (
+ addFloats env1 floats $ \ env2 ->
+ addAtomicBinds env2 aux_binds $ \ env3 ->
+ completeLazyBind env3 top_lvl bndr bndr'' rhs2)
+
+ else
+ completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1)
+
+#ifdef DEBUG
+demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
+ -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
+demanded_float (Rec _) = False
+#endif
\end{code}
%************************************************************************
%* *
+\subsection{Completing a lazy binding}
+%* *
+%************************************************************************
+
+completeLazyBind
+ * deals only with Ids, not TyVars
+ * takes an already-simplified binder and RHS
+ * is used for both recursive and non-recursive bindings
+ * is used for both top-level and non-top-level bindings
+
+It does the following:
+ - tries discarding a dead binding
+ - tries PostInlineUnconditionally
+ - add unfolding [this is the only place we add an unfolding]
+ - add arity
+
+It does *not* attempt to do let-to-case. Why? Because it is used for
+ - top-level bindings (when let-to-case is impossible)
+ - many situations where the "rhs" is known to be a WHNF
+ (so let-to-case is inappropriate).
+
+\begin{code}
+completeLazyBind :: SimplEnv
+ -> TopLevelFlag -- Flag stuck into unfolding
+ -> InId -- Old binder
+ -> OutId -- New binder
+ -> OutExpr -- Simplified RHS
+ -> SimplM (FloatsWith SimplEnv)
+-- We return a new SimplEnv, because completeLazyBind may choose to do its work
+-- by extending the substitution (e.g. let x = y in ...)
+-- The new binding (if any) is returned as part of the floats.
+-- NB: the returned SimplEnv has the right SubstEnv, but you should
+-- (as usual) use the in-scope-env from the floats
+
+completeLazyBind env top_lvl old_bndr new_bndr new_rhs
+ | postInlineUnconditionally env new_bndr loop_breaker new_rhs
+ = -- Drop the binding
+ tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
+ returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs))
+ -- Use the substitution to make quite, quite sure that the substitution
+ -- will happen, since we are going to discard the binding
+
+ | otherwise
+ = let
+ -- Add arity info
+ new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
+
+ -- Add the unfolding *only* for non-loop-breakers
+ -- Making loop breakers not have an unfolding at all
+ -- means that we can avoid tests in exprIsConApp, for example.
+ -- This is important: if exprIsConApp says 'yes' for a recursive
+ -- thing, then we can get into an infinite loop
+ info_w_unf | loop_breaker = new_bndr_info
+ | otherwise = new_bndr_info `setUnfoldingInfo` unfolding
+ unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs
+
+ final_id = new_bndr `setIdInfo` info_w_unf
+ in
+ -- These seqs forces the Id, and hence its IdInfo,
+ -- and hence any inner substitutions
+ final_id `seq`
+ returnSmpl (unitFloat env final_id new_rhs, env)
+
+ where
+ loop_breaker = isLoopBreaker occ_info
+ old_info = idInfo old_bndr
+ occ_info = occInfo old_info
+\end{code}
+
+
+
+%************************************************************************
+%* *
\subsection[Simplify-simplExpr]{The main function: simplExpr}
%* *
%************************************************************************
\begin{code}
-simplExpr :: CoreExpr -> SimplM CoreExpr
-simplExpr expr = getSubst `thenSmpl` \ subst ->
- simplExprC expr (mkStop (substTy subst (exprType expr)))
- -- The type in the Stop continuation is usually not used
+simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
+simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
+ where
+ expr_ty' = substTy (getSubst env) (exprType expr)
+ -- The type in the Stop continuation, expr_ty', is usually not used
-- It's only needed when discarding continuations after finding
-- a function that returns bottom.
-- Hence the lazy substitution
-simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr
- -- Simplify an expression, given a continuation
-simplExprC expr cont = simplExprF expr cont `thenSmpl` \ (floats, (_, body)) ->
- returnSmpl (wrapFloats floats body)
+simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
+ -- Simplify an expression, given a continuation
+simplExprC env expr cont
+ = simplExprF env expr cont `thenSmpl` \ (floats, expr) ->
+ returnSmpl (wrapFloats floats expr)
-simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff
+simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM FloatsWithExpr
-- Simplify an expression, returning floated binds
-simplExprF (Var v) cont = simplVar v cont
-simplExprF (Lit lit) cont = simplLit lit cont
-simplExprF expr@(Lam _ _) cont = simplLam expr cont
-simplExprF (Note note expr) cont = simplNote note expr cont
-
-simplExprF (App fun arg) cont
- = getSubstEnv `thenSmpl` \ se ->
- simplExprF fun (ApplyTo NoDup arg se cont)
+simplExprF env (Var v) cont = simplVar env v cont
+simplExprF env (Lit lit) cont = rebuild env (Lit lit) cont
+simplExprF env expr@(Lam _ _) cont = simplLam env expr cont
+simplExprF env (Note note expr) cont = simplNote env note expr cont
+simplExprF env (App fun arg) cont = simplExprF env fun (ApplyTo NoDup arg env cont)
-simplExprF (Type ty) cont
- = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } )
- simplType ty `thenSmpl` \ ty' ->
- rebuild (Type ty') cont
+simplExprF env (Type ty) cont
+ = ASSERT( contIsRhsOrArg cont )
+ simplType env ty `thenSmpl` \ ty' ->
+ rebuild env (Type ty') cont
-simplExprF (Case scrut bndr alts) cont
- = getSubstEnv `thenSmpl` \ subst_env ->
- getSwitchChecker `thenSmpl` \ chkr ->
- if not (switchIsOn chkr NoCaseOfCase) then
- -- Simplify the scrutinee with a Select continuation
- simplExprF scrut (Select NoDup bndr alts subst_env cont)
+simplExprF env (Case scrut bndr alts) cont
+ | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
+ = -- Simplify the scrutinee with a Select continuation
+ simplExprF env scrut (Select NoDup bndr alts env cont)
- else
- -- If case-of-case is off, simply simplify the case expression
+ | otherwise
+ = -- If case-of-case is off, simply simplify the case expression
-- in a vanilla Stop context, and rebuild the result around it
- simplExprC scrut (Select NoDup bndr alts subst_env
- (mkStop (contResultType cont))) `thenSmpl` \ case_expr' ->
- rebuild case_expr' cont
+ simplExprC env scrut case_cont `thenSmpl` \ case_expr' ->
+ rebuild env case_expr' cont
+ where
+ case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont))
-simplExprF (Let (Rec pairs) body) cont
- = simplRecIds (map fst pairs) $ \ bndrs' ->
+simplExprF env (Let (Rec pairs) body) cont
+ = simplRecIds env (map fst pairs) `thenSmpl` \ (env, bndrs') ->
-- NB: bndrs' don't have unfoldings or spec-envs
-- We add them as we go down, using simplPrags
- simplRecBind False pairs bndrs' (simplExprF body cont)
+ simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) ->
+ addFloats env floats $ \ env ->
+ simplExprF env body cont
-- A non-recursive let is dealt with by simplNonRecBind
-simplExprF (Let (NonRec bndr rhs) body) cont
- = getSubstEnv `thenSmpl` \ se ->
- simplNonRecBind bndr rhs se (contResultType cont) $
- simplExprF body cont
+simplExprF env (Let (NonRec bndr rhs) body) cont
+ = simplNonRecBind env bndr rhs env (contResultType cont) $ \ env ->
+ simplExprF env body cont
---------------------------------
-simplType :: InType -> SimplM OutType
-simplType ty
- = getSubst `thenSmpl` \ subst ->
- let
- new_ty = substTy subst ty
- in
- seqType new_ty `seq`
- returnSmpl new_ty
-
----------------------------------
-simplLit :: Literal -> SimplCont -> SimplM OutExprStuff
-
-simplLit lit (Select _ bndr alts se cont)
- = knownCon (Lit lit) (LitAlt lit) [] bndr alts se cont
-
-simplLit lit cont = rebuild (Lit lit) cont
+simplType :: SimplEnv -> InType -> SimplM OutType
+ -- Kept monadic just so we can do the seqType
+simplType env ty
+ = seqType new_ty `seq` returnSmpl new_ty
+ where
+ new_ty = substTy (getSubst env) ty
\end{code}
%************************************************************************
\begin{code}
-simplLam fun cont
- = go fun cont
+simplLam env fun cont
+ = go env fun cont
where
zap_it = mkLamBndrZapper fun cont
cont_ty = contResultType cont
-- Type-beta reduction
- go (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
+ go env (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont)
= ASSERT( isTyVar bndr )
- tick (BetaReduction bndr) `thenSmpl_`
- simplTyArg ty_arg arg_se `thenSmpl` \ ty_arg' ->
- extendSubst bndr (DoneTy ty_arg')
- (go body body_cont)
+ tick (BetaReduction bndr) `thenSmpl_`
+ simplType (setInScope arg_se env) ty_arg `thenSmpl` \ ty_arg' ->
+ go (extendSubst env bndr (DoneTy ty_arg')) body body_cont
-- Ordinary beta reduction
- go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
- = tick (BetaReduction bndr) `thenSmpl_`
- simplNonRecBind zapped_bndr arg arg_se cont_ty
- (go body body_cont)
+ go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
+ = tick (BetaReduction bndr) `thenSmpl_`
+ simplNonRecBind env zapped_bndr arg arg_se cont_ty $ \ env ->
+ go env body body_cont
where
zapped_bndr = zap_it bndr
- -- Not enough args
- go lam@(Lam _ _) cont = completeLam [] lam cont
+ -- Not enough args, so there are real lambdas left to put in the result
+ go env lam@(Lam _ _) cont
+ = simplLamBinders env bndrs `thenSmpl` \ (env, bndrs') ->
+ simplExpr env body `thenSmpl` \ body' ->
+ mkLam env bndrs' body' cont `thenSmpl` \ (floats, new_lam) ->
+ addFloats env floats $ \ env ->
+ rebuild env new_lam cont
+ where
+ (bndrs,body) = collectBinders lam
-- Exactly enough args
- go expr cont = simplExprF expr cont
-
--- completeLam deals with the case where a lambda doesn't have an ApplyTo
--- continuation, so there are real lambdas left to put in the result
-
--- We try for eta reduction here, but *only* if we get all the
--- way to an exprIsTrivial expression.
--- We don't want to remove extra lambdas unless we are going
--- to avoid allocating this thing altogether
-
-completeLam rev_bndrs (Lam bndr body) cont
- = simplLamBinder bndr $ \ bndr' ->
- completeLam (bndr':rev_bndrs) body cont
-
-completeLam rev_bndrs body cont
- = simplExpr body `thenSmpl` \ body' ->
- case try_eta body' of
- Just etad_lam -> tick (EtaReduction (head rev_bndrs)) `thenSmpl_`
- rebuild etad_lam cont
-
- Nothing -> rebuild (foldl (flip Lam) body' rev_bndrs) cont
- where
- -- We don't use CoreUtils.etaReduce, because we can be more
- -- efficient here:
- -- (a) we already have the binders,
- -- (b) we can do the triviality test before computing the free vars
- -- [in fact I take the simple path and look for just a variable]
- -- (c) we don't want to eta-reduce a data con worker or primop
- -- because we only have to eta-expand them later when we saturate
- try_eta body | not opt_SimplDoEtaReduction = Nothing
- | otherwise = go rev_bndrs body
-
- go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
- go [] body | ok_body body = Just body -- Success!
- go _ _ = Nothing -- Failure!
-
- ok_body (Var v) = not (v `elem` rev_bndrs) && not (hasNoBinding v)
- ok_body other = False
- ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
+ go env expr cont = simplExprF env expr cont
mkLamBndrZapper :: CoreExpr -- Function
-> SimplCont -- The context
%************************************************************************
\begin{code}
-simplNote (Coerce to from) body cont
- = getInScope `thenSmpl` \ in_scope ->
- let
+simplNote env (Coerce to from) body cont
+ = let
+ in_scope = getInScope env
+
addCoerce s1 k1 (CoerceIt t1 cont)
-- coerce T1 S1 (coerce S1 K1 e)
-- ==>
--
-- When we build the ApplyTo we can't mix the out-types
-- with the InExpr in the argument, so we simply substitute
- -- to make it all consistent. This isn't a common case.
+ -- to make it all consistent. It's a bit messy.
+ -- But it isn't a common case.
= let
(t1,t2) = splitFunTy t1t2
- new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope arg_se) arg)
+ new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
in
- ApplyTo dup new_arg emptySubstEnv (addCoerce t2 s2 cont)
+ ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
addCoerce to' _ cont = CoerceIt to' cont
in
- simplType to `thenSmpl` \ to' ->
- simplType from `thenSmpl` \ from' ->
- simplExprF body (addCoerce to' from' cont)
+ simplType env to `thenSmpl` \ to' ->
+ simplType env from `thenSmpl` \ from' ->
+ simplExprF env body (addCoerce to' from' cont)
-- Hack: we only distinguish subsumed cost centre stacks for the purposes of
-- inlining. All other CCCSs are mapped to currentCCS.
-simplNote (SCC cc) e cont
- = setEnclosingCC currentCCS $
- simplExpr e `thenSmpl` \ e ->
- rebuild (mkSCC cc e) cont
-
-simplNote InlineCall e cont
- = simplExprF e (InlinePlease cont)
-
--- Comments about the InlineMe case
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Don't inline in the RHS of something that has an
--- inline pragma. But be careful that the InScopeEnv that
--- we return does still have inlinings on!
---
--- It really is important to switch off inlinings. This function
--- may be inlinined in other modules, so we don't want to remove
--- (by inlining) calls to functions that have specialisations, or
--- that may have transformation rules in an importing scope.
--- E.g. {-# INLINE f #-}
--- f x = ...g...
--- and suppose that g is strict *and* has specialisations.
--- If we inline g's wrapper, we deny f the chance of getting
--- the specialised version of g when f is inlined at some call site
--- (perhaps in some other module).
-
--- It's also important not to inline a worker back into a wrapper.
--- A wrapper looks like
--- wraper = inline_me (\x -> ...worker... )
--- Normally, the inline_me prevents the worker getting inlined into
--- the wrapper (initially, the worker's only call site!). But,
--- if the wrapper is sure to be called, the strictness analyser will
--- mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
--- continuation. That's why the keep_inline predicate returns True for
--- ArgOf continuations. It shouldn't do any harm not to dissolve the
--- inline-me note under these circumstances
-
-simplNote InlineMe e cont
- | keep_inline cont -- Totally boring continuation
+simplNote env (SCC cc) e cont
+ = simplExpr (setEnclosingCC env currentCCS) e `thenSmpl` \ e' ->
+ rebuild env (mkSCC cc e') cont
+
+simplNote env InlineCall e cont
+ = simplExprF env e (InlinePlease cont)
+
+-- See notes with SimplMonad.inlineMode
+simplNote env InlineMe e cont
+ | contIsRhsOrArg cont -- Totally boring continuation; see notes above
= -- Don't inline inside an INLINE expression
- noInlineBlackList `thenSmpl` \ bl ->
- setBlackList bl (simplExpr e) `thenSmpl` \ e' ->
- rebuild (mkInlineMe e') cont
+ simplExpr (setMode inlineMode env ) e `thenSmpl` \ e' ->
+ rebuild env (mkInlineMe e') cont
| otherwise -- Dissolve the InlineMe note if there's
-- an interesting context of any kind to combine with
-- (even a type application -- anything except Stop)
- = simplExprF e cont
- where
- keep_inline (Stop _ _) = True -- See notes above
- keep_inline (ArgOf _ _ _) = True -- about this predicate
- keep_inline other = False
+ = simplExprF env e cont
\end{code}
%************************************************************************
%* *
-\subsection{Binding}
+\subsection{Dealing with calls}
%* *
%************************************************************************
-@simplNonRecBind@ is used for non-recursive lets in expressions,
-as well as true beta reduction.
-
-Very similar to @simplLazyBind@, but not quite the same.
-
-\begin{code}
-simplNonRecBind :: InId -- Binder
- -> InExpr -> SubstEnv -- Arg, with its subst-env
- -> OutType -- Type of thing computed by the context
- -> SimplM OutExprStuff -- The body
- -> SimplM OutExprStuff
-#ifdef DEBUG
-simplNonRecBind bndr rhs rhs_se cont_ty thing_inside
- | isTyVar bndr
- = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs)
-#endif
-
-simplNonRecBind bndr rhs rhs_se cont_ty thing_inside
- | preInlineUnconditionally False {- not black listed -} bndr
- = tick (PreInlineUnconditionally bndr) `thenSmpl_`
- extendSubst bndr (ContEx rhs_se rhs) thing_inside
-
- | otherwise
- = -- Simplify the binder.
- -- Don't use simplBinder because that doesn't keep
- -- fragile occurrence in the substitution
- simplLetId bndr $ \ bndr' ->
- getSubst `thenSmpl` \ bndr_subst ->
- let
- -- Substitute its IdInfo (which simplLetId does not)
- -- The appropriate substitution env is the one right here,
- -- not rhs_se. Often they are the same, when all this
- -- has arisen from an application (\x. E) RHS, perhaps they aren't
- bndr'' = simplIdInfo bndr_subst (idInfo bndr) bndr'
- bndr_ty' = idType bndr'
- is_strict = isStrictDmd (idNewDemandInfo bndr) || isStrictType bndr_ty'
- in
- modifyInScope bndr'' bndr'' $
-
- -- Simplify the argument
- simplValArg bndr_ty' is_strict rhs rhs_se cont_ty $ \ rhs' ->
-
- -- Now complete the binding and simplify the body
- if needsCaseBinding bndr_ty' rhs' then
- addCaseBind bndr'' rhs' thing_inside
- else
- completeBinding bndr bndr'' False False rhs' thing_inside
-\end{code}
-
-
\begin{code}
-simplTyArg :: InType -> SubstEnv -> SimplM OutType
-simplTyArg ty_arg se
- = getInScope `thenSmpl` \ in_scope ->
- let
- ty_arg' = substTy (mkSubst in_scope se) ty_arg
- in
- seqType ty_arg' `seq`
- returnSmpl ty_arg'
-
-simplValArg :: OutType -- rhs_ty: Type of arg; used only occasionally
- -> Bool -- True <=> evaluate eagerly
- -> InExpr -> SubstEnv
- -> OutType -- cont_ty: Type of thing computed by the context
- -> (OutExpr -> SimplM OutExprStuff)
- -- Takes an expression of type rhs_ty,
- -- returns an expression of type cont_ty
- -> SimplM OutExprStuff -- An expression of type cont_ty
-
-simplValArg arg_ty is_strict arg arg_se cont_ty thing_inside
- | is_strict
- = getEnv `thenSmpl` \ env ->
- setSubstEnv arg_se $
- simplExprF arg (ArgOf NoDup cont_ty $ \ rhs' ->
- setAllExceptInScope env $
- thing_inside rhs')
-
- | otherwise
- = simplRhs False {- Not top level -}
- True {- OK to float unboxed -}
- arg_ty arg arg_se
- thing_inside
-\end{code}
-
-
-completeBinding
- - deals only with Ids, not TyVars
- - take an already-simplified RHS
-
-It does *not* attempt to do let-to-case. Why? Because they are used for
-
- - top-level bindings
- (when let-to-case is impossible)
-
- - many situations where the "rhs" is known to be a WHNF
- (so let-to-case is inappropriate).
-
-\begin{code}
-completeBinding :: InId -- Binder
- -> OutId -- New binder
- -> Bool -- True <=> top level
- -> Bool -- True <=> black-listed; don't inline
- -> OutExpr -- Simplified RHS
- -> SimplM (OutStuff a) -- Thing inside
- -> SimplM (OutStuff a)
-
-completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside
- | isDeadOcc occ_info -- This happens; for example, the case_bndr during case of
- -- known constructor: case (a,b) of x { (p,q) -> ... }
- -- Here x isn't mentioned in the RHS, so we don't want to
- -- create the (dead) let-binding let x = (a,b) in ...
- = thing_inside
-
- | trivial_rhs && not must_keep_binding
- -- We're looking at a binding with a trivial RHS, so
- -- perhaps we can discard it altogether!
- --
- -- NB: a loop breaker has must_keep_binding = True
- -- and non-loop-breakers only have *forward* references
- -- Hence, it's safe to discard the binding
- --
- -- NOTE: This isn't our last opportunity to inline.
- -- We're at the binding site right now, and
- -- we'll get another opportunity when we get to the ocurrence(s)
-
- -- Note that we do this unconditional inlining only for trival RHSs.
- -- Don't inline even WHNFs inside lambdas; doing so may
- -- simply increase allocation when the function is called
- -- This isn't the last chance; see NOTE above.
- --
- -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here
- -- Why? Because we don't even want to inline them into the
- -- RHS of constructor arguments. See NOTE above
- --
- -- NB: Even NOINLINEis ignored here: if the rhs is trivial
- -- it's best to inline it anyway. We often get a=E; b=a
- -- from desugaring, with both a and b marked NOINLINE.
- = -- Drop the binding
- extendSubst old_bndr (DoneEx new_rhs) $
- -- Use the substitution to make quite, quite sure that the substitution
- -- will happen, since we are going to discard the binding
- tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
- thing_inside
-
- | Note coercion@(Coerce _ inner_ty) inner_rhs <- new_rhs,
- not trivial_rhs && not (isUnLiftedType inner_ty)
- -- x = coerce t e ==> c = e; x = inline_me (coerce t c)
- -- Now x can get inlined, which moves the coercion
- -- to the usage site. This is a bit like worker/wrapper stuff,
- -- but it's useful to do it very promptly, so that
- -- x = coerce T (I# 3)
- -- get's w/wd to
- -- c = I# 3
- -- x = coerce T c
- -- This in turn means that
- -- case (coerce Int x) of ...
- -- will inline x.
- -- Also the full-blown w/w thing isn't set up for non-functions
- --
- -- The (not (isUnLiftedType inner_ty)) avoids the nasty case of
- -- x::Int = coerce Int Int# (foo y)
- -- ==>
- -- v::Int# = foo y
- -- x::Int = coerce Int Int# v
- -- which would be bogus because then v will be evaluated strictly.
- -- How can this arise? Via
- -- x::Int = case (foo y) of { ... }
- -- followed by case elimination.
- --
- -- The inline_me note is so that the simplifier doesn't
- -- just substitute c back inside x's rhs! (Typically, x will
- -- get substituted away, but not if it's exported.)
- = newId SLIT("c") inner_ty $ \ c_id ->
- completeBinding c_id c_id top_lvl False inner_rhs $
- completeBinding old_bndr new_bndr top_lvl black_listed
- (Note InlineMe (Note coercion (Var c_id))) $
- thing_inside
-
- | otherwise
- = let
- -- We make new IdInfo for the new binder by starting from the old binder,
- -- doing appropriate substitutions.
- -- Then we add arity and unfolding info to get the new binder
- new_bndr_info = idInfo new_bndr `setArityInfo` arity
-
- -- Add the unfolding *only* for non-loop-breakers
- -- Making loop breakers not have an unfolding at all
- -- means that we can avoid tests in exprIsConApp, for example.
- -- This is important: if exprIsConApp says 'yes' for a recursive
- -- thing, then we can get into an infinite loop
- info_w_unf | loop_breaker = new_bndr_info
- | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
-
- final_id = new_bndr `setIdInfo` info_w_unf
- in
- -- These seqs forces the Id, and hence its IdInfo,
- -- and hence any inner substitutions
- final_id `seq`
- addLetBind (NonRec final_id new_rhs) $
- modifyInScope new_bndr final_id thing_inside
-
- where
- old_info = idInfo old_bndr
- occ_info = occInfo old_info
- loop_breaker = isLoopBreaker occ_info
- trivial_rhs = exprIsTrivial new_rhs
- must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr
- arity = exprArity new_rhs
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{simplLazyBind}
-%* *
-%************************************************************************
-
-simplLazyBind basically just simplifies the RHS of a let(rec).
-It does two important optimisations though:
-
- * It floats let(rec)s out of the RHS, even if they
- are hidden by big lambdas
-
- * It does eta expansion
-
-\begin{code}
-simplLazyBind :: Bool -- True <=> top level
- -> InId -> OutId
- -> InExpr -- The RHS
- -> SimplM (OutStuff a) -- The body of the binding
- -> SimplM (OutStuff a)
--- When called, the subst env is correct for the entire let-binding
--- and hence right for the RHS.
--- Also the binder has already been simplified, and hence is in scope
-
-simplLazyBind top_lvl bndr bndr' rhs thing_inside
- = getBlackList `thenSmpl` \ black_list_fn ->
- let
- black_listed = black_list_fn bndr
- in
-
- if preInlineUnconditionally black_listed bndr then
- -- Inline unconditionally
- tick (PreInlineUnconditionally bndr) `thenSmpl_`
- getSubstEnv `thenSmpl` \ rhs_se ->
- (extendSubst bndr (ContEx rhs_se rhs) thing_inside)
- else
-
- -- Simplify the RHS
- getSubst `thenSmpl` \ rhs_subst ->
- let
- -- Substitute IdInfo on binder, in the light of earlier
- -- substitutions in this very letrec, and extend the in-scope
- -- env so that it can see the new thing
- bndr'' = simplIdInfo rhs_subst (idInfo bndr) bndr'
- in
- modifyInScope bndr'' bndr'' $
-
- simplRhs top_lvl False {- Not ok to float unboxed (conservative) -}
- (idType bndr')
- rhs (substEnv rhs_subst) $ \ rhs' ->
-
- -- Now compete the binding and simplify the body
- completeBinding bndr bndr'' top_lvl black_listed rhs' thing_inside
-\end{code}
-
-
-
-\begin{code}
-simplRhs :: Bool -- True <=> Top level
- -> Bool -- True <=> OK to float unboxed (speculative) bindings
- -- False for (a) recursive and (b) top-level bindings
- -> OutType -- Type of RHS; used only occasionally
- -> InExpr -> SubstEnv
- -> (OutExpr -> SimplM (OutStuff a))
- -> SimplM (OutStuff a)
-simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside
- = -- Simplify it
- setSubstEnv rhs_se (simplExprF rhs (mkRhsStop rhs_ty)) `thenSmpl` \ (floats1, (rhs_in_scope, rhs1)) ->
- let
- (floats2, rhs2) = splitFloats float_ubx floats1 rhs1
- in
- -- Transform the RHS
- -- It's important that we do eta expansion on function *arguments* (which are
- -- simplified with simplRhs), as well as let-bound right-hand sides.
- -- Otherwise we find that things like
- -- f (\x -> case x of I# x' -> coerce T (\ y -> ...))
- -- get right through to the code generator as two separate lambdas,
- -- which is a Bad Thing
- tryRhsTyLam rhs2 `thenSmpl` \ (floats3, rhs3) ->
- tryEtaExpansion rhs3 rhs_ty `thenSmpl` \ (floats4, rhs4) ->
-
- -- Float lets if (a) we're at the top level
- -- or (b) the resulting RHS is one we'd like to expose
- --
- -- NB: the test used to say "exprIsCheap", but that caused a strictness bug.
- -- x = let y* = E in case (scc y) of { T -> F; F -> T}
- -- The case expression is 'cheap', but it's wrong to transform to
- -- y* = E; x = case (scc y) of {...}
- -- Either we must be careful not to float demanded non-values, or
- -- we must use exprIsValue for the test, which ensures that the
- -- thing is non-strict. I think. The WARN below tests for this
- if (top_lvl || exprIsValue rhs4) then
-
- -- There's a subtlety here. There may be a binding (x* = e) in the
- -- floats, where the '*' means 'will be demanded'. So is it safe
- -- to float it out? Answer no, but it won't matter because
- -- we only float if arg' is a WHNF,
- -- and so there can't be any 'will be demanded' bindings in the floats.
- -- Hence the assert
- WARN( any demanded_float (fromOL floats2),
- ppr (filter demanded_float (fromOL floats2)) )
-
- (if (isNilOL floats2 && null floats3 && null floats4) then
- returnSmpl ()
- else
- tick LetFloatFromLet) `thenSmpl_`
-
- addFloats floats2 rhs_in_scope $
- addAuxiliaryBinds floats3 $
- addAuxiliaryBinds floats4 $
- thing_inside rhs4
- else
- -- Don't do the float
- thing_inside (wrapFloats floats1 rhs1)
-
-demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
- -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them
-demanded_float (Rec _) = False
-
--- If float_ubx is true we float all the bindings, otherwise
--- we just float until we come across an unlifted one.
--- Remember that the unlifted bindings in the floats are all for
--- guaranteed-terminating non-exception-raising unlifted things,
--- which we are happy to do speculatively. However, we may still
--- not be able to float them out, because the context
--- is either a Rec group, or the top level, neither of which
--- can tolerate them.
-splitFloats float_ubx floats rhs
- | float_ubx = (floats, rhs) -- Float them all
- | otherwise = go (fromOL floats)
- where
- go [] = (nilOL, rhs)
- go (f:fs) | must_stay f = (nilOL, mkLets (f:fs) rhs)
- | otherwise = case go fs of
- (out, rhs') -> (f `consOL` out, rhs')
-
- must_stay (Rec prs) = False -- No unlifted bindings in here
- must_stay (NonRec b r) = isUnLiftedType (idType b)
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{Variables}
-%* *
-%************************************************************************
-
-\begin{code}
-simplVar var cont
- = getSubst `thenSmpl` \ subst ->
- case lookupIdSubst subst var of
- DoneEx e -> zapSubstEnv (simplExprF e cont)
- ContEx env1 e -> setSubstEnv env1 (simplExprF e cont)
- DoneId var1 occ -> WARN( not (isInScope var1 subst) && mustHaveLocalBinding var1,
+simplVar env var cont
+ = case lookupIdSubst (getSubst env) var of
+ DoneEx e -> simplExprF (zapSubstEnv env) e cont
+ ContEx se e -> simplExprF (setSubstEnv env se) e cont
+ DoneId var1 occ -> WARN( not (isInScope var1 (getSubst env)) && mustHaveLocalBinding var1,
text "simplVar:" <+> ppr var )
- zapSubstEnv (completeCall var1 occ cont)
+ completeCall (zapSubstEnv env) var1 occ cont
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
-- let x = e in
---------------------------------------------------------
-- Dealing with a call
-completeCall var occ_info cont
- = getBlackList `thenSmpl` \ black_list_fn ->
- getInScope `thenSmpl` \ in_scope ->
- getContArgs var cont `thenSmpl` \ (args, call_cont, inline_call) ->
- getDOptsSmpl `thenSmpl` \ dflags ->
+completeCall env var occ_info cont
+ = getDOptsSmpl `thenSmpl` \ dflags ->
let
- black_listed = black_list_fn var
- arg_infos = [ interestingArg in_scope arg subst
- | (arg, subst, _) <- args, isValArg arg]
+ in_scope = getInScope env
+ chkr = getSwitchChecker env
+
+ (args, call_cont, inline_call) = getContArgs chkr var cont
+
+ arg_infos = [ interestingArg in_scope arg (getSubstEnv arg_env)
+ | (arg, arg_env, _) <- args, isValArg arg]
interesting_cont = interestingCallContext (not (null args))
(not (null arg_infos))
inline_cont | inline_call = discardInline cont
| otherwise = cont
- maybe_inline = callSiteInline dflags black_listed inline_call occ_info
+ active_inline = activeInline env var
+ maybe_inline = callSiteInline dflags active_inline inline_call occ_info
var arg_infos interesting_cont
in
-- First, look for an inlining
case maybe_inline of {
Just unfolding -- There is an inlining!
-> tick (UnfoldingDone var) `thenSmpl_`
- simplExprF unfolding inline_cont
+ simplExprF env unfolding inline_cont
;
Nothing -> -- No inlining!
- simplifyArgs (isDataConId var) args (contResultType call_cont) $ \ args' ->
+ simplifyArgs env args (contResultType call_cont) $ \ env args' ->
-- Next, look for rules or specialisations that match
--
-- foldr k z (build g) = g k z
-- So it's up to the programmer: rules can cause divergence
- getSwitchChecker `thenSmpl` \ chkr ->
let
- maybe_rule | switchIsOn chkr DontApplyRules = Nothing
- | otherwise = lookupRule in_scope var args'
+ maybe_rule = case activeRule env of
+ Nothing -> Nothing -- No rules apply
+ Just act_fn -> lookupRule act_fn in_scope var args'
in
case maybe_rule of {
Just (rule_name, rule_rhs) ->
tick (RuleFired rule_name) `thenSmpl_`
-#ifdef DEBUG
(if dopt Opt_D_dump_inlinings dflags then
pprTrace "Rule fired" (vcat [
text "Rule:" <+> ptext rule_name,
text "After: " <+> pprCoreExpr rule_rhs])
else
id) $
-#endif
- simplExprF rule_rhs call_cont ;
+ simplExprF env rule_rhs call_cont ;
Nothing -> -- No rules
-- Done
- rebuild (mkApps (Var var) args') call_cont
+ rebuild env (mkApps (Var var) args') call_cont
}}
+\end{code}
+%************************************************************************
+%* *
+\subsection{Arguments}
+%* *
+%************************************************************************
+
+\begin{code}
---------------------------------------------------------
-- Simplifying the arguments of a call
-simplifyArgs :: Bool -- It's a data constructor
- -> [(InExpr, SubstEnv, Bool)] -- Details of the arguments
+simplifyArgs :: SimplEnv
+ -> [(InExpr, SimplEnv, Bool)] -- Details of the arguments
-> OutType -- Type of the continuation
- -> ([OutExpr] -> SimplM OutExprStuff)
- -> SimplM OutExprStuff
+ -> (SimplEnv -> [OutExpr] -> SimplM FloatsWithExpr)
+ -> SimplM FloatsWithExpr
+
+-- [CPS-like because of strict arguments]
-- Simplify the arguments to a call.
-- This part of the simplifier may break the no-shadowing invariant
-- discard the entire application and replace it with (error "foo"). Getting
-- all this at once is TOO HARD!
-simplifyArgs is_data_con args cont_ty thing_inside
- | not is_data_con
- = go args thing_inside
-
- | otherwise -- It's a data constructor, so we want
- -- to switch off inlining in the arguments
- -- If we don't do this, consider:
- -- let x = +# p q in C {x}
- -- Even though x get's an occurrence of 'many', its RHS looks cheap,
- -- and there's a good chance it'll get inlined back into C's RHS. Urgh!
- = getBlackList `thenSmpl` \ old_bl ->
- noInlineBlackList `thenSmpl` \ ni_bl ->
- setBlackList ni_bl $
- go args $ \ args' ->
- setBlackList old_bl $
- thing_inside args'
-
+simplifyArgs env args cont_ty thing_inside
+ = go env args thing_inside
where
- go [] thing_inside = thing_inside []
- go (arg:args) thing_inside = simplifyArg is_data_con arg cont_ty $ \ arg' ->
- go args $ \ args' ->
- thing_inside (arg':args')
+ go env [] thing_inside = thing_inside env []
+ go env (arg:args) thing_inside = simplifyArg env arg cont_ty $ \ env arg' ->
+ go env args $ \ env args' ->
+ thing_inside env (arg':args')
-simplifyArg is_data_con (Type ty_arg, se, _) cont_ty thing_inside
- = simplTyArg ty_arg se `thenSmpl` \ new_ty_arg ->
- thing_inside (Type new_ty_arg)
+simplifyArg env (Type ty_arg, se, _) cont_ty thing_inside
+ = simplType (setInScope se env) ty_arg `thenSmpl` \ new_ty_arg ->
+ thing_inside env (Type new_ty_arg)
-simplifyArg is_data_con (val_arg, se, is_strict) cont_ty thing_inside
- = getInScope `thenSmpl` \ in_scope ->
- let
- arg_ty = substTy (mkSubst in_scope se) (exprType val_arg)
- in
- if not is_data_con then
- -- An ordinary function
- simplValArg arg_ty is_strict val_arg se cont_ty thing_inside
- else
- -- A data constructor
- -- simplifyArgs has already switched off inlining, so
- -- all we have to do here is to let-bind any non-trivial argument
-
- -- It's not always the case that new_arg will be trivial
- -- Consider f x
- -- where, in one pass, f gets substituted by a constructor,
- -- but x gets substituted by an expression (assume this is the
- -- unique occurrence of x). It doesn't really matter -- it'll get
- -- fixed up next pass. And it happens for dictionary construction,
- -- which mentions the wrapper constructor to start with.
- simplValArg arg_ty is_strict val_arg se cont_ty $ \ arg' ->
-
- if exprIsTrivial arg' then
- thing_inside arg'
- else
- newId SLIT("a") (exprType arg') $ \ arg_id ->
- addNonRecBind arg_id arg' $
- thing_inside (Var arg_id)
-\end{code}
+simplifyArg env (val_arg, arg_se, is_strict) cont_ty thing_inside
+ | is_strict
+ = simplStrictArg env AnArg val_arg arg_se cont_ty thing_inside
-
-%************************************************************************
-%* *
-\subsection{Decisions about inlining}
-%* *
-%************************************************************************
-
-NB: At one time I tried not pre/post-inlining top-level things,
-even if they occur exactly once. Reason:
- (a) some might appear as a function argument, so we simply
- replace static allocation with dynamic allocation:
- l = <...>
- x = f l
- becomes
- x = f <...>
-
- (b) some top level things might be black listed
-
-HOWEVER, I found that some useful foldr/build fusion was lost (most
-notably in spectral/hartel/parstof) because the foldr didn't see the build.
-
-Doing the dynamic allocation isn't a big deal, in fact, but losing the
-fusion can be.
-
-\begin{code}
-preInlineUnconditionally :: Bool {- Black listed -} -> InId -> Bool
- -- Examines a bndr to see if it is used just once in a
- -- completely safe way, so that it is safe to discard the binding
- -- inline its RHS at the (unique) usage site, REGARDLESS of how
- -- big the RHS might be. If this is the case we don't simplify
- -- the RHS first, but just inline it un-simplified.
- --
- -- This is much better than first simplifying a perhaps-huge RHS
- -- and then inlining and re-simplifying it.
- --
- -- NB: we don't even look at the RHS to see if it's trivial
- -- We might have
- -- x = y
- -- where x is used many times, but this is the unique occurrence
- -- of y. We should NOT inline x at all its uses, because then
- -- we'd do the same for y -- aargh! So we must base this
- -- pre-rhs-simplification decision solely on x's occurrences, not
- -- on its rhs.
- --
- -- Evne RHSs labelled InlineMe aren't caught here, because
- -- there might be no benefit from inlining at the call site.
-
-preInlineUnconditionally black_listed bndr
- | black_listed || opt_SimplNoPreInlining = False
- | otherwise = case idOccInfo bndr of
- OneOcc in_lam once -> not in_lam && once
- -- Not inside a lambda, one occurrence ==> safe!
- other -> False
+ | otherwise
+ = let
+ arg_env = setInScope arg_se env
+ in
+ simplType arg_env (exprType val_arg) `thenSmpl` \ arg_ty ->
+ simplExprF arg_env val_arg (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) ->
+ addFloats env floats $ \ env ->
+ thing_inside env arg1
+
+
+simplStrictArg :: SimplEnv -- The env of the call
+ -> LetRhsFlag
+ -> InExpr -> SimplEnv -- The arg plus its env
+ -> OutType -- cont_ty: Type of thing computed by the context
+ -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
+ -- Takes an expression of type rhs_ty,
+ -- returns an expression of type cont_ty
+ -- The env passed to this continuation is the
+ -- env of the call, plus any new in-scope variables
+ -> SimplM FloatsWithExpr -- An expression of type cont_ty
+
+simplStrictArg call_env is_rhs arg arg_env cont_ty thing_inside
+ = simplExprF (setInScope arg_env call_env) arg
+ (ArgOf NoDup is_rhs cont_ty (\ new_env -> thing_inside (setInScope call_env new_env)))
+ -- Notice the way we use arg_env (augmented with in-scope vars from call_env)
+ -- to simplify the argument
+ -- and call-env (augmented with in-scope vars from the arg) to pass to the continuation
\end{code}
-
%************************************************************************
%* *
-\subsection{The main rebuilder}
+\subsection{mkAtomicArgs}
%* *
%************************************************************************
-\begin{code}
--------------------------------------------------------------------
--- Finish rebuilding
-rebuild_done expr = returnOutStuff expr
-
----------------------------------------------------------
-rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
-
--- Stop continuation
-rebuild expr (Stop _ _) = rebuild_done expr
+mkAtomicArgs takes a putative RHS, checks whether it's a PAP or
+constructor application and, if so, converts it to ANF, so that the
+resulting thing can be inlined more easily. Thus
+ x = (f a, g b)
+becomes
+ t1 = f a
+ t2 = g b
+ x = (t1,t2)
--- ArgOf continuation
-rebuild expr (ArgOf _ _ cont_fn) = cont_fn expr
+There are three sorts of binding context, specified by the two
+boolean arguments
--- ApplyTo continuation
-rebuild expr cont@(ApplyTo _ arg se cont')
- = setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' ->
- rebuild (App expr arg') cont'
+Strict
+ OK-unlifted
--- Coerce continuation
-rebuild expr (CoerceIt to_ty cont)
- = rebuild (mkCoerce to_ty (exprType expr) expr) cont
+N N Top-level or recursive Only bind args of lifted type
--- Inline continuation
-rebuild expr (InlinePlease cont)
- = rebuild (Note InlineCall expr) cont
+N Y Non-top-level and non-recursive, Bind args of lifted type, or
+ but lazy unlifted-and-ok-for-speculation
-rebuild scrut (Select _ bndr alts se cont)
- = rebuild_case scrut bndr alts se cont
-\end{code}
-
-Case elimination [see the code above]
-~~~~~~~~~~~~~~~~
-Start with a simple situation:
-
- case x# of ===> e[x#/y#]
- y# -> e
-
-(when x#, y# are of primitive type, of course). We can't (in general)
-do this for algebraic cases, because we might turn bottom into
-non-bottom!
-
-Actually, we generalise this idea to look for a case where we're
-scrutinising a variable, and we know that only the default case can
-match. For example:
-\begin{verbatim}
- case x of
- 0# -> ...
- other -> ...(case x of
- 0# -> ...
- other -> ...) ...
-\end{code}
-Here the inner case can be eliminated. This really only shows up in
-eliminating error-checking code.
+Y Y Non-top-level, non-recursive, Bind all args
+ and strict (demanded)
+
-We also make sure that we deal with this very common case:
+For example, given
- case e of
- x -> ...x...
+ x = MkC (y div# z)
-Here we are using the case as a strict let; if x is used only once
-then we want to inline it. We have to be careful that this doesn't
-make the program terminate when it would have diverged before, so we
-check that
- - x is used strictly, or
- - e is already evaluated (it may so if e is a variable)
+there is no point in transforming to
-Lastly, we generalise the transformation to handle this:
+ x = case (y div# z) of r -> MkC r
- case e of ===> r
- True -> r
- False -> r
+because the (y div# z) can't float out of the let. But if it was
+a *strict* let, then it would be a good thing to do. Hence the
+context information.
-We only do this for very cheaply compared r's (constructors, literals
-and variables). If pedantic bottoms is on, we only do it when the
-scrutinee is a PrimOp which can't fail.
+\begin{code}
+mkAtomicArgs :: Bool -- A strict binding
+ -> Bool -- OK to float unlifted args
+ -> OutExpr
+ -> SimplM ([(OutId,OutExpr)], -- The floats (unusually) may include
+ OutExpr) -- things that need case-binding,
+ -- if the strict-binding flag is on
+
+mkAtomicArgs is_strict ok_float_unlifted rhs
+ = mk_atomic_args rhs `thenSmpl` \ maybe_stuff ->
+ case maybe_stuff of
+ Nothing -> returnSmpl ([], rhs)
+ Just (ol_binds, rhs') -> returnSmpl (fromOL ol_binds, rhs')
-We do it *here*, looking at un-simplified alternatives, because we
-have to check that r doesn't mention the variables bound by the
-pattern in each alternative, so the binder-info is rather useful.
+ where
+ mk_atomic_args :: OutExpr -> SimplM (Maybe (OrdList (Id,OutExpr), OutExpr))
+ -- Nothing => no change
+ mk_atomic_args rhs
+ | (Var fun, args) <- collectArgs rhs, -- It's an application
+ isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
+ = -- Worth a try
+ go nilOL [] args `thenSmpl` \ maybe_stuff ->
+ case maybe_stuff of
+ Nothing -> returnSmpl Nothing
+ Just (aux_binds, args') -> returnSmpl (Just (aux_binds, mkApps (Var fun) args'))
+
+ | otherwise
+ = returnSmpl Nothing
+
+ go binds rev_args []
+ = returnSmpl (Just (binds, reverse rev_args))
+ go binds rev_args (arg : args)
+ | exprIsTrivial arg -- Easy case
+ = go binds (arg:rev_args) args
+
+ | not can_float_arg -- Can't make this arg atomic
+ = returnSmpl Nothing -- ... so give up
+
+ | otherwise -- Don't forget to do it recursively
+ -- E.g. x = a:b:c:[]
+ = mk_atomic_args arg `thenSmpl` \ maybe_anf ->
+ case maybe_anf of {
+ Nothing -> returnSmpl Nothing ;
+ Just (arg_binds,arg') ->
+
+ newId SLIT("a") arg_ty `thenSmpl` \ arg_id ->
+ go ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds)
+ (Var arg_id : rev_args) args
+ }
+ where
+ arg_ty = exprType arg
+ can_float_arg = is_strict
+ || not (isUnLiftedType arg_ty)
+ || (ok_float_unlifted && exprOkForSpeculation arg)
+
+addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)]
+ -> (SimplEnv -> SimplM (FloatsWith a))
+ -> SimplM (FloatsWith a)
+addAtomicBinds env [] thing_inside = thing_inside env
+addAtomicBinds env ((v,r):bs) thing_inside = addAuxiliaryBind env (NonRec v r) $ \ env ->
+ addAtomicBinds env bs thing_inside
+
+addAtomicBindsE :: SimplEnv -> [(OutId,OutExpr)]
+ -> (SimplEnv -> SimplM FloatsWithExpr)
+ -> SimplM FloatsWithExpr
+-- Same again, but this time we're in an expression context,
+-- and may need to do some case bindings
+
+addAtomicBindsE env [] thing_inside
+ = thing_inside env
+addAtomicBindsE env ((v,r):bs) thing_inside
+ | needsCaseBinding (idType v) r
+ = addAtomicBindsE (addNewInScopeIds env [v]) bs thing_inside `thenSmpl` \ (floats, expr) ->
+ WARN( exprIsTrivial expr, ppr v <+> pprCoreExpr expr )
+ returnSmpl (emptyFloats env, Case r v [(DEFAULT,[], wrapFloats floats expr)])
-So the case-elimination algorithm is:
+ | otherwise
+ = addAuxiliaryBind env (NonRec v r) $ \ env ->
+ addAtomicBindsE env bs thing_inside
+\end{code}
- 1. Eliminate alternatives which can't match
- 2. Check whether all the remaining alternatives
- (a) do not mention in their rhs any of the variables bound in their pattern
- and (b) have equal rhss
+%************************************************************************
+%* *
+\subsection{The main rebuilder}
+%* *
+%************************************************************************
- 3. Check we can safely ditch the case:
- * PedanticBottoms is off,
- or * the scrutinee is an already-evaluated variable
- or * the scrutinee is a primop which is ok for speculation
- -- ie we want to preserve divide-by-zero errors, and
- -- calls to error itself!
+\begin{code}
+rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
- or * [Prim cases] the scrutinee is a primitive variable
+rebuild env expr (Stop _ _ _) = rebuildDone env expr
+rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr
+rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty (exprType expr) expr) cont
+rebuild env expr (InlinePlease cont) = rebuild env (Note InlineCall expr) cont
+rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
+rebuild env expr (ApplyTo _ arg se cont) = rebuildApp (setInScope se env) expr arg cont
- or * [Alg cases] the scrutinee is a variable and
- either * the rhs is the same variable
- (eg case x of C a b -> x ===> x)
- or * there is only one alternative, the default alternative,
- and the binder is used strictly in its scope.
- [NB this is helped by the "use default binder where
- possible" transformation; see below.]
+rebuildApp env fun arg cont
+ = simplExpr env arg `thenSmpl` \ arg' ->
+ rebuild env (App fun arg') cont
+rebuildDone env expr = returnSmpl (emptyFloats env, expr)
+\end{code}
-If so, then we can replace the case with one of the rhss.
+%************************************************************************
+%* *
+\subsection{Functions dealing with a case}
+%* *
+%************************************************************************
Blob of helper functions for the "case-of-something-else" situation.
---------------------------------------------------------
-- Eliminate the case if possible
-rebuild_case scrut bndr alts se cont
- | maybeToBool maybe_con_app
- = knownCon scrut (DataAlt con) args bndr alts se cont
-
- | canEliminateCase scrut bndr alts
- = tick (CaseElim bndr) `thenSmpl_` (
- setSubstEnv se $
- simplBinder bndr $ \ bndr' ->
- -- Remember to bind the case binder!
- completeBinding bndr bndr' False False scrut $
- simplExprF (head (rhssOfAlts alts)) cont)
+rebuildCase :: SimplEnv
+ -> OutExpr -- Scrutinee
+ -> InId -- Case binder
+ -> [InAlt] -- Alternatives
+ -> SimplCont
+ -> SimplM FloatsWithExpr
- | otherwise
- = complete_case scrut bndr alts se cont
-
- where
- maybe_con_app = exprIsConApp_maybe scrut
- Just (con, args) = maybe_con_app
-
- -- See if we can get rid of the case altogether
- -- See the extensive notes on case-elimination above
-canEliminateCase scrut bndr alts
- = -- Check that the RHSs are all the same, and
- -- don't use the binders in the alternatives
- -- This test succeeds rapidly in the common case of
- -- a single DEFAULT alternative
- all (cheapEqExpr rhs1) other_rhss && all binders_unused alts
-
- -- Check that the scrutinee can be let-bound instead of case-bound
- && ( exprOkForSpeculation scrut
- -- OK not to evaluate it
- -- This includes things like (==# a# b#)::Bool
- -- so that we simplify
- -- case ==# a# b# of { True -> x; False -> x }
- -- to just
- -- x
- -- This particular example shows up in default methods for
- -- comparision operations (e.g. in (>=) for Int.Int32)
- || exprIsValue scrut -- It's already evaluated
- || var_demanded_later scrut -- It'll be demanded later
-
--- || not opt_SimplPedanticBottoms) -- Or we don't care!
--- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
--- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
--- its argument: case x of { y -> dataToTag# y }
--- Here we must *not* discard the case, because dataToTag# just fetches the tag from
--- the info pointer. So we'll be pedantic all the time, and see if that gives any
--- other problems
- )
-
- where
- (rhs1:other_rhss) = rhssOfAlts alts
- binders_unused (_, bndrs, _) = all isDeadBinder bndrs
-
- var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo bndr) -- It's going to be evaluated later
- var_demanded_later other = False
+rebuildCase env scrut case_bndr alts cont
+ | Just (con,args) <- exprIsConApp_maybe scrut
+ -- Works when the scrutinee is a variable with a known unfolding
+ -- as well as when it's an explicit constructor application
+ = knownCon env (DataAlt con) args case_bndr alts cont
+ | Lit lit <- scrut -- No need for same treatment as constructors
+ -- because literals are inlined more vigorously
+ = knownCon env (LitAlt lit) [] case_bndr alts cont
----------------------------------------------------------
--- Case of something else
-
-complete_case scrut case_bndr alts se cont
+ | otherwise
= -- Prepare case alternatives
- prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr))
- impossible_cons alts `thenSmpl` \ better_alts ->
-
- -- Set the new subst-env in place (before dealing with the case binder)
- setSubstEnv se $
+ -- Filter out alternatives that can't possibly match
+ let
+ impossible_cons = case scrut of
+ Var v -> otherCons (idUnfolding v)
+ other -> []
+ better_alts = case impossible_cons of
+ [] -> alts
+ other -> [alt | alt@(con,_,_) <- alts,
+ not (con `elem` impossible_cons)]
+ in
-- Deal with the case binder, and prepare the continuation;
-- The new subst_env is in place
- prepareCaseCont better_alts cont $ \ cont' ->
-
+ prepareCaseCont env better_alts cont `thenSmpl` \ (floats, cont') ->
+ addFloats env floats $ \ env ->
-- Deal with variable scrutinee
- (
- getSwitchChecker `thenSmpl` \ chkr ->
- simplCaseBinder (switchIsOn chkr NoCaseOfCase)
- scrut case_bndr $ \ case_bndr' zap_occ_info ->
+ simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
-- Deal with the case alternatives
- simplAlts zap_occ_info impossible_cons
- case_bndr' better_alts cont' `thenSmpl` \ alts' ->
-
- mkCase scrut case_bndr' alts'
- ) `thenSmpl` \ case_expr ->
-
- -- Notice that the simplBinder, prepareCaseCont, etc, do *not* scope
- -- over the rebuild_done; rebuild_done returns the in-scope set, and
- -- that should not include these chaps!
- rebuild_done case_expr
- where
- impossible_cons = case scrut of
- Var v -> otherCons (idUnfolding v)
- other -> []
+ simplAlts alt_env zap_occ_info impossible_cons
+ case_bndr' better_alts cont' `thenSmpl` \ alts' ->
+ -- Put the case back together
+ mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr ->
-knownCon :: OutExpr -> AltCon -> [OutExpr]
- -> InId -> [InAlt] -> SubstEnv -> SimplCont
- -> SimplM OutExprStuff
-
-knownCon expr con args bndr alts se cont
- = -- Arguments should be atomic;
- -- yell if not
- WARN( not (all exprIsTrivial args),
- text "knownCon" <+> ppr expr )
- tick (KnownBranch bndr) `thenSmpl_`
- setSubstEnv se (
- simplBinder bndr $ \ bndr' ->
- completeBinding bndr bndr' False False expr $
- -- Don't use completeBeta here. The expr might be
- -- an unboxed literal, like 3, or a variable
- -- whose unfolding is an unboxed literal... and
- -- completeBeta will just construct another case
- -- expression!
- case findAlt con alts of
- (DEFAULT, bs, rhs) -> ASSERT( null bs )
- simplExprF rhs cont
-
- (LitAlt lit, bs, rhs) -> ASSERT( null bs )
- simplExprF rhs cont
-
- (DataAlt dc, bs, rhs) -> ASSERT( length bs == length real_args )
- extendSubstList bs (map mk real_args) $
- simplExprF rhs cont
- where
- real_args = drop (dataConNumInstArgs dc) args
- mk (Type ty) = DoneTy ty
- mk other = DoneEx other
- )
-\end{code}
-
-\begin{code}
-prepareCaseCont :: [InAlt] -> SimplCont
- -> (SimplCont -> SimplM (OutStuff a))
- -> SimplM (OutStuff a)
- -- Polymorphic recursion here!
-
-prepareCaseCont [alt] cont thing_inside = thing_inside cont
-prepareCaseCont alts cont thing_inside = simplType (coreAltsType alts) `thenSmpl` \ alts_ty ->
- mkDupableCont alts_ty cont thing_inside
- -- At one time I passed in the un-simplified type, and simplified
- -- it only if we needed to construct a join binder, but that
- -- didn't work because we have to decompse function types
- -- (using funResultTy) in mkDupableCont.
+ -- Notice that rebuildDone returns the in-scope set from env, not alt_env
+ -- The case binder *not* scope over the whole returned case-expression
+ rebuildDone env case_expr
\end{code}
simplCaseBinder checks whether the scrutinee is a variable, v. If so,
way, there's a chance that v will now only be used once, and hence
inlined.
+Note 1
+~~~~~~
There is a time we *don't* want to do that, namely when
-fno-case-of-case is on. This happens in the first simplifier pass,
and enhances full laziness. Here's the bad case:
which might prevent some full laziness happening. I've seen this
in action in spectral/cichelli/Prog.hs:
[(m,n) | m <- [1..max], n <- [1..max]]
-Hence the no_case_of_case argument
+Hence the check for NoCaseOfCase.
+
+Note 2
+~~~~~~
+There is another situation when we don't want to do it. If we have
+
+ case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
+ ...other cases .... }
+
+We'll perform the binder-swap for the outer case, giving
+
+ case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
+ ...other cases .... }
+
+But there is no point in doing it for the inner case,
+because w1 can't be inlined anyway. Furthermore, doing the case-swapping
+involves zapping w2's occurrence info (see paragraphs that follow),
+and that forces us to bind w2 when doing case merging. So we get
+
+ case x of w1 { A -> let w2 = w1 in e1
+ B -> let w2 = w1 in e2
+ ...other cases .... }
+
+This is plain silly in the common case where w2 is dead.
+
+Even so, I can't see a good way to implement this idea. I tried
+not doing the binder-swap if the scrutinee was already evaluated
+but that failed big-time:
+
+ data T = MkT !Int
+ case v of w { MkT x ->
+ case x of x1 { I# y1 ->
+ case x of x2 { I# y2 -> ...
-If we do this, then we have to nuke any occurrence info (eg IAmDead)
-in the case binder, because the case-binder now effectively occurs
-whenever v does. AND we have to do the same for the pattern-bound
-variables! Example:
+Notice that because MkT is strict, x is marked "evaluated". But to
+eliminate the last case, we must either make sure that x (as well as
+x1) has unfolding MkT y1. THe straightforward thing to do is to do
+the binder-swap. So this whole note is a no-op.
+
+Note 3
+~~~~~~
+If we replace the scrutinee, v, by tbe case binder, then we have to nuke
+any occurrence info (eg IAmDead) in the case binder, because the
+case-binder now effectively occurs whenever v does. AND we have to do
+the same for the pattern-bound variables! Example:
(case x of { (a,b) -> a }) (case x of { (p,q) -> q })
happened. Hence the zap_occ_info function returned by simplCaseBinder
\begin{code}
-simplCaseBinder no_case_of_case (Var v) case_bndr thing_inside
- | not no_case_of_case
- = simplBinder (zap case_bndr) $ \ case_bndr' ->
- modifyInScope v case_bndr' $
+simplCaseBinder env (Var v) case_bndr
+ | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
+
+-- Failed try [see Note 2 above]
+-- not (isEvaldUnfolding (idUnfolding v))
+
+ = simplBinder env (zap case_bndr) `thenSmpl` \ (env, case_bndr') ->
+ returnSmpl (modifyInScope env v case_bndr', case_bndr', zap)
-- We could extend the substitution instead, but it would be
-- a hack because then the substitution wouldn't be idempotent
-- any more (v is an OutId). And this just just as well.
- thing_inside case_bndr' zap
where
zap b = b `setIdOccInfo` NoOccInfo
-simplCaseBinder add_eval_info other_scrut case_bndr thing_inside
- = simplBinder case_bndr $ \ case_bndr' ->
- thing_inside case_bndr' (\ bndr -> bndr) -- NoOp on bndr
+simplCaseBinder env other_scrut case_bndr
+ = simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') ->
+ returnSmpl (env, case_bndr', \ bndr -> bndr) -- NoOp on bndr
\end{code}
-prepareCaseAlts does two things:
-
-1. Remove impossible alternatives
-2. If the DEFAULT alternative can match only one possible constructor,
- then make that constructor explicit.
- e.g.
- case e of x { DEFAULT -> rhs }
- ===>
- case e of x { (a,b) -> rhs }
- where the type is a single constructor type. This gives better code
- when rhs also scrutinises x or e.
\begin{code}
-prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts
- | isDataTyCon tycon
- = case (findDefault filtered_alts, missing_cons) of
-
- ((alts_no_deflt, Just rhs), [data_con]) -- Just one missing constructor!
- -> tick (FillInCaseDefault bndr) `thenSmpl_`
- let
- (_,_,ex_tyvars,_,_,_) = dataConSig data_con
- in
- getUniquesSmpl `thenSmpl` \ tv_uniqs ->
- let
- ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
- mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
- arg_tys = dataConArgTys data_con
- (inst_tys ++ mkTyVarTys ex_tyvars')
- in
- newIds SLIT("a") arg_tys $ \ bndrs ->
- returnSmpl ((DataAlt data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
-
- other -> returnSmpl filtered_alts
- where
- -- Filter out alternatives that can't possibly match
- filtered_alts = case scrut_cons of
- [] -> alts
- other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
-
- missing_cons = [data_con | data_con <- tyConDataConsIfAvailable tycon,
- not (data_con `elem` handled_data_cons)]
- handled_data_cons = [data_con | DataAlt data_con <- scrut_cons] ++
- [data_con | (DataAlt data_con, _, _) <- filtered_alts]
-
--- The default case
-prepareCaseAlts _ _ scrut_cons alts
- = returnSmpl alts -- Functions
-
-
-----------------------
-simplAlts zap_occ_info scrut_cons case_bndr' alts cont'
+simplAlts :: SimplEnv
+ -> (InId -> InId) -- Occ-info zapper
+ -> [AltCon] -- Alternatives the scrutinee can't be
+ -> OutId -- Case binder
+ -> [InAlt] -> SimplCont
+ -> SimplM [OutAlt] -- Includes the continuation
+
+simplAlts env zap_occ_info impossible_cons case_bndr' alts cont'
= mapSmpl simpl_alt alts
where
inst_tys' = tyConAppArgs (idType case_bndr')
-- handled_cons is all the constructors that are dealt
-- with, either by being impossible, or by there being an alternative
(con_alts,_) = findDefault alts
- handled_cons = scrut_cons ++ [con | (con,_,_) <- con_alts]
+ handled_cons = impossible_cons ++ [con | (con,_,_) <- con_alts]
simpl_alt (DEFAULT, _, rhs)
- = -- In the default case we record the constructors that the
+ = let
+ -- In the default case we record the constructors that the
-- case-binder *can't* be.
-- We take advantage of any OtherCon info in the case scrutinee
- modifyInScope case_bndr' (case_bndr' `setIdUnfolding` mkOtherCon handled_cons) $
- simplExprC rhs cont' `thenSmpl` \ rhs' ->
+ case_bndr_w_unf = case_bndr' `setIdUnfolding` mkOtherCon handled_cons
+ env_with_unf = modifyInScope env case_bndr' case_bndr_w_unf
+ in
+ simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (DEFAULT, [], rhs')
simpl_alt (con, vs, rhs)
-- NB: it happens that simplBinders does *not* erase the OtherCon
-- form of unfolding, so it's ok to add this info before
-- doing simplBinders
- simplBinders (add_evals con vs) $ \ vs' ->
+ simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') ->
-- Bind the case-binder to (con args)
let
- unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys')
+ unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys')
+ env_with_unf = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` unfolding)
in
- modifyInScope case_bndr' (case_bndr' `setIdUnfolding` unfolding) $
- simplExprC rhs cont' `thenSmpl` \ rhs' ->
+ simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (con, vs', rhs')
%************************************************************************
%* *
+\subsection{Known constructor}
+%* *
+%************************************************************************
+
+We are a bit careful with occurrence info. Here's an example
+
+ (\x* -> case x of (a*, b) -> f a) (h v, e)
+
+where the * means "occurs once". This effectively becomes
+ case (h v, e) of (a*, b) -> f a)
+and then
+ let a* = h v; b = e in f a
+and then
+ f (h v)
+
+All this should happen in one sweep.
+
+\begin{code}
+knownCon :: SimplEnv -> AltCon -> [OutExpr]
+ -> InId -> [InAlt] -> SimplCont
+ -> SimplM FloatsWithExpr
+
+knownCon env con args bndr alts cont
+ = tick (KnownBranch bndr) `thenSmpl_`
+ case findAlt con alts of
+ (DEFAULT, bs, rhs) -> ASSERT( null bs )
+ simplNonRecX env bndr scrut $ \ env ->
+ -- This might give rise to a binding with non-atomic args
+ -- like x = Node (f x) (g x)
+ -- but no harm will be done
+ simplExprF env rhs cont
+ where
+ scrut = case con of
+ LitAlt lit -> Lit lit
+ DataAlt dc -> mkConApp dc args
+
+ (LitAlt lit, bs, rhs) -> ASSERT( null bs )
+ simplNonRecX env bndr (Lit lit) $ \ env ->
+ simplExprF env rhs cont
+
+ (DataAlt dc, bs, rhs) -> ASSERT( length bs + n_tys == length args )
+ bind_args env bs (drop n_tys args) $ \ env ->
+ let
+ con_app = mkConApp dc (take n_tys args ++ con_args)
+ con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs]
+ -- args are aready OutExprs, but bs are InIds
+ in
+ simplNonRecX env bndr con_app $ \ env ->
+ simplExprF env rhs cont
+ where
+ n_tys = dataConNumInstArgs dc -- Non-existential type args
+-- Ugh!
+bind_args env [] _ thing_inside = thing_inside env
+
+bind_args env (b:bs) (Type ty : args) thing_inside
+ = bind_args (extendSubst env b (DoneTy ty)) bs args thing_inside
+
+bind_args env (b:bs) (arg : args) thing_inside
+ = simplNonRecX env b arg $ \ env ->
+ bind_args env bs args thing_inside
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Duplicating continuations}
%* *
%************************************************************************
\begin{code}
-mkDupableCont :: OutType -- Type of the thing to be given to the continuation
+prepareCaseCont :: SimplEnv
+ -> [InAlt] -> SimplCont
+ -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
+ -- plus some extra bindings
+
+prepareCaseCont env [alt] cont = returnSmpl (emptyFloats env, cont)
+ -- No need to make it duplicatable if there's only one alternative
+
+prepareCaseCont env alts cont = simplType env (coreAltsType alts) `thenSmpl` \ alts_ty ->
+ mkDupableCont env alts_ty cont
+ -- At one time I passed in the un-simplified type, and simplified
+ -- it only if we needed to construct a join binder, but that
+ -- didn't work because we have to decompse function types
+ -- (using funResultTy) in mkDupableCont.
+\end{code}
+
+\begin{code}
+mkDupableCont :: SimplEnv
+ -> OutType -- Type of the thing to be given to the continuation
-> SimplCont
- -> (SimplCont -> SimplM (OutStuff a))
- -> SimplM (OutStuff a)
-mkDupableCont ty cont thing_inside
+ -> SimplM (FloatsWith SimplCont) -- Return a duplicatable continuation,
+ -- plus some extra bindings
+
+mkDupableCont env ty cont
| contIsDupable cont
- = thing_inside cont
-
-mkDupableCont _ (CoerceIt ty cont) thing_inside
- = mkDupableCont ty cont $ \ cont' ->
- thing_inside (CoerceIt ty cont')
-
-mkDupableCont ty (InlinePlease cont) thing_inside
- = mkDupableCont ty cont $ \ cont' ->
- thing_inside (InlinePlease cont')
-
-mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside
- = -- Build the RHS of the join point
- newId SLIT("a") join_arg_ty ( \ arg_id ->
- cont_fn (Var arg_id) `thenSmpl` \ (floats, (_, rhs)) ->
- returnSmpl (Lam (setOneShotLambda arg_id) (wrapFloats floats rhs))
- ) `thenSmpl` \ join_rhs ->
-
+ = returnSmpl (emptyFloats env, cont)
+
+mkDupableCont env _ (CoerceIt ty cont)
+ = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
+ returnSmpl (floats, CoerceIt ty cont')
+
+mkDupableCont env ty (InlinePlease cont)
+ = mkDupableCont env ty cont `thenSmpl` \ (floats, cont') ->
+ returnSmpl (floats, InlinePlease cont')
+
+mkDupableCont env join_arg_ty (ArgOf _ is_rhs cont_ty cont_fn)
+ = -- e.g. (...strict-fn...) [...hole...]
+ -- ==>
+ -- let $j = \a -> ...strict-fn...
+ -- in $j [...hole...]
+
-- Build the join Id and continuation
-- We give it a "$j" name just so that for later amusement
-- we can identify any join points that don't end up as let-no-escapes
-- [NOTE: the type used to be exprType join_rhs, but this seems more elegant.]
- newId SLIT("$j") (mkFunTy join_arg_ty cont_ty) $ \ join_id ->
+ newId SLIT("$j") (mkFunTy join_arg_ty cont_ty) `thenSmpl` \ join_id ->
+ newId SLIT("a") join_arg_ty `thenSmpl` \ arg_id ->
+
+ cont_fn (addNewInScopeIds env [arg_id]) (Var arg_id) `thenSmpl` \ (floats, rhs) ->
let
- new_cont = ArgOf OkToDup cont_ty
- (\arg' -> rebuild_done (App (Var join_id) arg'))
+ cont_fn env arg' = rebuildDone env (App (Var join_id) arg')
+ join_rhs = Lam (setOneShotLambda arg_id) (wrapFloats floats rhs)
in
tick (CaseOfCase join_id) `thenSmpl_`
-- Want to tick here so that we go round again,
-- and maybe copy or inline the code;
-- not strictly CaseOf Case
- addLetBind (NonRec join_id join_rhs) $
- thing_inside new_cont
-mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
- = mkDupableCont (funResultTy ty) cont $ \ cont' ->
- setSubstEnv se (simplExpr arg) `thenSmpl` \ arg' ->
+ returnSmpl (unitFloat env join_id join_rhs,
+ ArgOf OkToDup is_rhs cont_ty cont_fn)
+
+mkDupableCont env ty (ApplyTo _ arg se cont)
+ = -- e.g. [...hole...] (...arg...)
+ -- ==>
+ -- let a = ...arg...
+ -- in [...hole...] a
+ mkDupableCont env (funResultTy ty) cont `thenSmpl` \ (floats, cont') ->
+ addFloats env floats $ \ env ->
+
+ simplExpr (setInScope se env) arg `thenSmpl` \ arg' ->
if exprIsDupable arg' then
- thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
+ returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont')
else
- newId SLIT("a") (exprType arg') $ \ bndr ->
+ newId SLIT("a") (exprType arg') `thenSmpl` \ arg_id ->
- tick (CaseOfCase bndr) `thenSmpl_`
+ tick (CaseOfCase arg_id) `thenSmpl_`
-- Want to tick here so that we go round again,
- -- and maybe copy or inline the code;
- -- not strictly CaseOf Case
+ -- and maybe copy or inline the code.
+ -- Not strictly CaseOfCase, but never mind
- addLetBind (NonRec bndr arg') $
- -- But what if the arg should be case-bound? We can't use
- -- addNonRecBind here because its type is too specific.
+ returnSmpl (unitFloat env arg_id arg',
+ ApplyTo OkToDup (Var arg_id) (zapSubstEnv se) cont')
+ -- But what if the arg should be case-bound?
-- This has been this way for a long time, so I'll leave it,
-- but I can't convince myself that it's right.
- thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont')
-
-
-mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
- = tick (CaseOfCase case_bndr) `thenSmpl_`
- setSubstEnv se (
- simplBinder case_bndr $ \ case_bndr' ->
- prepareCaseCont alts cont $ \ cont' ->
- mkDupableAlts case_bndr case_bndr' cont' alts $ \ alts' ->
- returnOutStuff alts'
- ) `thenSmpl` \ (alt_binds, (in_scope, alts')) ->
-
- addFloats alt_binds in_scope $
-
- -- NB that the new alternatives, alts', are still InAlts, using the original
- -- binders. That means we can keep the case_bndr intact. This is important
- -- because another case-of-case might strike, and so we want to keep the
- -- info that the case_bndr is dead (if it is, which is often the case).
- -- This is VITAL when the type of case_bndr is an unboxed pair (often the
- -- case in I/O rich code. We aren't allowed a lambda bound
- -- arg of unboxed tuple type, and indeed such a case_bndr is always dead
- thing_inside (Select OkToDup case_bndr alts' se (mkStop (contResultType cont)))
-
-mkDupableAlts :: InId -> OutId -> SimplCont -> [InAlt]
- -> ([InAlt] -> SimplM (OutStuff a))
- -> SimplM (OutStuff a)
-mkDupableAlts case_bndr case_bndr' cont [] thing_inside
- = thing_inside []
-mkDupableAlts case_bndr case_bndr' cont (alt:alts) thing_inside
- = mkDupableAlt case_bndr case_bndr' cont alt $ \ alt' ->
- mkDupableAlts case_bndr case_bndr' cont alts $ \ alts' ->
- thing_inside (alt' : alts')
-
-mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) thing_inside
- = simplBinders bndrs $ \ bndrs' ->
- simplExprC rhs cont `thenSmpl` \ rhs' ->
-
- if (case cont of { Stop _ _ -> exprIsDupable rhs'; other -> False}) then
+
+mkDupableCont env ty (Select _ case_bndr alts se cont)
+ = -- e.g. (case [...hole...] of { pi -> ei })
+ -- ===>
+ -- let ji = \xij -> ei
+ -- in case [...hole...] of { pi -> ji xij }
+ tick (CaseOfCase case_bndr) `thenSmpl_`
+ let
+ alt_env = setInScope se env
+ in
+ prepareCaseCont alt_env alts cont `thenSmpl` \ (floats1, dupable_cont) ->
+ addFloats alt_env floats1 $ \ alt_env ->
+
+ simplBinder alt_env case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
+ -- NB: simplBinder does not zap deadness occ-info, so
+ -- a dead case_bndr' will still advertise its deadness
+ -- This is really important because in
+ -- case e of b { (# a,b #) -> ... }
+ -- b is always dead, and indeed we are not allowed to bind b to (# a,b #),
+ -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
+ -- In the new alts we build, we have the new case binder, so it must retain
+ -- its deadness.
+
+ mkDupableAlts alt_env case_bndr' alts dupable_cont `thenSmpl` \ (floats2, alts') ->
+ addFloats alt_env floats2 $ \ alt_env ->
+ returnSmpl (emptyFloats alt_env, Select OkToDup case_bndr' alts' (zapSubstEnv se)
+ (mkBoringStop (contResultType cont)))
+
+mkDupableAlts :: SimplEnv -> OutId -> [InAlt] -> SimplCont
+ -> SimplM (FloatsWith [InAlt])
+-- Absorbs the continuation into the new alternatives
+
+mkDupableAlts env case_bndr' alts dupable_cont
+ = go env alts
+ where
+ go env [] = returnSmpl (emptyFloats env, [])
+ go env (alt:alts)
+ = mkDupableAlt env case_bndr' dupable_cont alt `thenSmpl` \ (floats1, alt') ->
+ addFloats env floats1 $ \ env ->
+ go env alts `thenSmpl` \ (floats2, alts') ->
+ returnSmpl (floats2, alt' : alts')
+
+mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs)
+ = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
+ simplExprC env rhs cont `thenSmpl` \ rhs' ->
+
+ if exprIsDupable rhs' then
+ returnSmpl (emptyFloats env, (con, bndrs', rhs'))
-- It is worth checking for a small RHS because otherwise we
-- get extra let bindings that may cause an extra iteration of the simplifier to
-- inline back in place. Quite often the rhs is just a variable or constructor.
-- inlined, but after the join points had been inlined it looked smaller, and so
-- was inlined.
--
- -- But since the continuation is absorbed into the rhs, we only do this
- -- for a Stop continuation.
- --
-- NB: we have to check the size of rhs', not rhs.
-- Duplicating a small InAlt might invalidate occurrence information
-- However, if it *is* dupable, we return the *un* simplified alternative,
- -- because otherwise we'd need to pair it up with an empty subst-env.
+ -- because otherwise we'd need to pair it up with an empty subst-env....
+ -- but we only have one env shared between all the alts.
-- (Remember we must zap the subst-env before re-simplifying something).
-- Rather than do this we simply agree to re-simplify the original (small) thing later.
- thing_inside alt
else
let
- rhs_ty' = exprType rhs'
- (used_bndrs, used_bndrs')
- = unzip [pr | pr@(bndr,bndr') <- zip (case_bndr : bndrs)
- (case_bndr' : bndrs'),
- not (isDeadBinder bndr)]
- -- The new binders have lost their occurrence info,
- -- so we have to extract it from the old ones
+ rhs_ty' = exprType rhs'
+ used_bndrs' = filter (not . isDeadBinder) (case_bndr' : bndrs')
+ -- The deadness info on the new binders is unscathed
in
- ( if null used_bndrs'
-- If we try to lift a primitive-typed something out
-- for let-binding-purposes, we will *caseify* it (!),
-- with potentially-disastrous strictness results. So
-- True -> $j s
-- (the \v alone is enough to make CPR happy) but I think it's rare
- then newId SLIT("w") realWorldStatePrimTy $ \ rw_id ->
+ ( if null used_bndrs'
+ then newId SLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
else
- returnSmpl (used_bndrs', map varToCoreExpr used_bndrs)
- )
- `thenSmpl` \ (final_bndrs', final_args) ->
+ returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
+ ) `thenSmpl` \ (final_bndrs', final_args) ->
-- See comment about "$j" name above
- newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') $ \ join_bndr ->
+ newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') `thenSmpl` \ join_bndr ->
-- Notice the funky mkPiType. If the contructor has existentials
-- it's possible that the join point will be abstracted over
-- type varaibles as well as term variables.
-- join point is sure to be applied at most once, and doing so
-- prevents the body of the join point being floated out by
-- the full laziness pass
- really_final_bndrs = map one_shot final_bndrs'
+ really_final_bndrs = map one_shot final_bndrs'
one_shot v | isId v = setOneShotLambda v
| otherwise = v
+ join_rhs = mkLams really_final_bndrs rhs'
+ join_call = mkApps (Var join_bndr) final_args
in
- addLetBind (NonRec join_bndr (mkLams really_final_bndrs rhs')) $
- thing_inside (con, bndrs, mkApps (Var join_bndr) final_args)
+ returnSmpl (unitFloat env join_bndr join_rhs, (con, bndrs', join_call))
\end{code}
\section[TcIfaceSig]{Type checking of type signatures in interface files}
\begin{code}
-module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
+module TcIfaceSig ( tcInterfaceSigs, tcDelay, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
#include "HsVersions.h"
\begin{code}
tcPragExpr unf_env name in_scope_vars expr
- = tcDelay unf_env doc $
+ = tcDelay unf_env doc Nothing $
tcCoreExpr expr `thenTc` \ core_expr' ->
-- Check for type consistency in the unfolding
tcGetSrcLoc `thenNF_Tc` \ src_loc ->
getDOptsTc `thenTc` \ dflags ->
case lintUnfolding dflags src_loc in_scope_vars core_expr' of
- (Nothing,_) -> returnTc core_expr' -- ignore warnings
+ (Nothing,_) -> returnTc (Just core_expr') -- ignore warnings
(Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
where
doc = text "unfolding of" <+> ppr name
-tcDelay :: RecTcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a)
-tcDelay unf_env doc thing_inside
+tcDelay :: RecTcEnv -> SDoc -> a -> TcM a -> NF_TcM a
+tcDelay unf_env doc bad_ans thing_inside
= forkNF_Tc (
recoverNF_Tc bad_value (
- tcSetEnv unf_env thing_inside `thenTc` \ r ->
- returnTc (Just r)
+ tcSetEnv unf_env thing_inside
))
where
-- The trace tells what wasn't available, for the benefit of
bad_value = getErrsTc `thenNF_Tc` \ (warns,errs) ->
returnNF_Tc (pprTrace "Failed:"
(hang doc 4 (pprBagOfErrors errs))
- Nothing)
+ bad_ans)
\end{code}
tcExtendGlobalValEnv sig_ids $
- tcIfaceRules (pcs_rules pcs) this_mod iface_rules `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
+ tcIfaceRules unf_env (pcs_rules pcs) this_mod iface_rules `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
-- When relinking this module from its interface-file decls
-- we'll have IfaceRules that are in fact local to this module
-- That's the reason we we get any local_rules out here
import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck )
import TcMType ( newTyVarTy )
import TcType ( tyVarsOfTypes, openTypeKind )
-import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
+import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar, tcDelay )
import TcMonoType ( kcHsSigTypes, tcHsSigType, UserTypeCtxt(..), tcScopedTyVars )
import TcExpr ( tcExpr )
-import TcEnv ( tcExtendLocalValEnv, isLocalThing )
+import TcEnv ( RecTcEnv, tcExtendLocalValEnv, isLocalThing )
import Rules ( extendRuleBase )
import Inst ( LIE, plusLIEs, instToId )
import Id ( idName, idType, mkLocalId )
\end{code}
\begin{code}
-tcIfaceRules :: PackageRuleBase -> Module -> [RenamedRuleDecl]
+tcIfaceRules :: RecTcEnv -> PackageRuleBase -> Module -> [RenamedRuleDecl]
-> TcM (PackageRuleBase, [TypecheckedRuleDecl])
-tcIfaceRules pkg_rule_base mod decls
- = mapTc tcIfaceRule decls `thenTc` \ new_rules ->
+tcIfaceRules unf_env pkg_rule_base mod decls
+ = tcDelay unf_env doc [] (
+ -- We need the recursive env because the built-in rules show up as
+ -- IfaceOut rules, sot they get typechecked by tcIfaceRules
+ mapTc tcIfaceRule decls
+ ) `thenTc` \ new_rules ->
let
(local_rules, imported_rules) = partition is_local new_rules
new_rule_base = foldl add pkg_rule_base imported_rules
in
returnTc (new_rule_base, local_rules)
where
+ doc = text "tcIfaceRules"
add rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
-- When relinking this module from its interface-file decls
projects / ghc-hetmet.git / commitdiff