Core pass to saturate constructors and PrimOps
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module CorePrep (
corePrepPgm, corePrepExpr
) where
import Util
import Outputable
import MonadUtils
+import FastString
\end{code}
-- ---------------------------------------------------------------------------
partial applications. But it's easier to let them through.
\begin{code}
+mkDataConWorkers :: [TyCon] -> [CoreBind]
mkDataConWorkers data_tycons
= [ NonRec id (Var id) -- The ice is thin here, but it works
| tycon <- data_tycons, -- CorePrep will eta-expand it
addFloat (Floats ok_to_spec floats) new_float
= Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
where
- check (FloatLet _) = OkToSpec
+ check (FloatLet _) = OkToSpec
check (FloatCase _ _ ok_for_spec)
| ok_for_spec = IfUnboxedOk
| otherwise = NotOkToSpec
concatFloats :: [Floats] -> Floats
concatFloats = foldr appendFloats emptyFloats
+combine :: OkToSpec -> OkToSpec -> OkToSpec
combine NotOkToSpec _ = NotOkToSpec
combine _ NotOkToSpec = NotOkToSpec
combine IfUnboxedOk _ = IfUnboxedOk
= foldrOL get [] floats
where
get (FloatLet b) bs = b:bs
- get b bs = pprPanic "corePrepPgm" (ppr b)
+ get b _ = pprPanic "corePrepPgm" (ppr b)
allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
allLazy top_lvl is_rec (Floats ok_to_spec _)
corePrepTopBinds binds
= go emptyCorePrepEnv binds
where
- go env [] = return emptyFloats
+ go _ [] = return emptyFloats
go env (bind : binds) = do (env', bind') <- corePrepTopBind env bind
binds' <- go env' binds
return (bind' `appendFloats` binds')
corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)
-- This one is used for *local* bindings
corePrepBind env (NonRec bndr rhs) = do
- rhs1 <- etaExpandRhs bndr rhs
- (floats, rhs2) <- corePrepExprFloat env rhs1
+ (floats, rhs2) <- corePrepExprFloat env rhs
(_, bndr') <- cloneBndr env bndr
(floats', bndr'') <- mkLocalNonRec bndr' (bdrDem bndr) floats rhs2
-- We want bndr'' in the envt, because it records
get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2
- get b prs2 = pprPanic "corePrepRecPairs" (ppr b)
+ get b _ = pprPanic "corePrepRecPairs" (ppr b)
--------------------------------
corePrepRhs :: TopLevelFlag -> RecFlag
-> UniqSM (Floats, CoreExpr)
-- Used for top-level bindings, and local recursive bindings
corePrepRhs top_lvl is_rec env (bndr, rhs) = do
- rhs' <- etaExpandRhs bndr rhs
- floats_w_rhs <- corePrepExprFloat env rhs'
+ floats_w_rhs <- corePrepExprFloat env rhs
floatRhs top_lvl is_rec bndr floats_w_rhs
-- This is where we arrange that a non-trivial argument is let-bound
corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
-> UniqSM (Floats, CoreArg)
-corePrepArg env arg dem = do
- (floats, arg') <- corePrepExprFloat env arg
- if exprIsTrivial arg'
- then return (floats, arg')
- else do v <- newVar (exprType arg')
- (floats', v') <- mkLocalNonRec v dem floats arg'
- return (floats', Var v')
+corePrepArg env arg dem
+ = do { (floats, arg') <- corePrepExprFloat env arg
+ ; if exprIsTrivial arg' && allLazy NotTopLevel NonRecursive floats
+ -- Note [Floating unlifted arguments]
+ then return (floats, arg')
+ else do { v <- newVar (exprType arg')
+ -- Note [Eta expand arguments]
+ ; (floats', v') <- mkLocalNonRec v dem floats arg'
+ ; return (floats', Var v') } }
-- version that doesn't consider an scc annotation to be trivial.
-exprIsTrivial (Var v) = True
+exprIsTrivial :: CoreExpr -> Bool
+exprIsTrivial (Var _) = True
exprIsTrivial (Type _) = True
-exprIsTrivial (Lit lit) = True
+exprIsTrivial (Lit _) = True
exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
-exprIsTrivial (Note (SCC _) e) = False
+exprIsTrivial (Note (SCC _) _) = False
exprIsTrivial (Note _ e) = exprIsTrivial e
-exprIsTrivial (Cast e co) = exprIsTrivial e
+exprIsTrivial (Cast e _) = exprIsTrivial e
exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
-exprIsTrivial other = False
+exprIsTrivial _ = False
+\end{code}
+
+Note [Floating unlifted arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider C (let v* = expensive in v)
+
+where the "*" indicates "will be demanded". Usually v will have been
+inlined by now, but let's suppose it hasn't (see Trac #2756). Then we
+do *not* want to get
+
+ let v* = expensive in C v
+
+because that has different strictness. Hence the use of 'allLazy'.
+(NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
+
+\begin{code}
-- ---------------------------------------------------------------------------
-- Dealing with expressions
-- ---------------------------------------------------------------------------
v2 = lookupCorePrepEnv env v1
maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
-corePrepExprFloat env expr@(Type _)
+corePrepExprFloat _env expr@(Type _)
= return (emptyFloats, expr)
-corePrepExprFloat env expr@(Lit lit)
+corePrepExprFloat _env expr@(Lit _)
= return (emptyFloats, expr)
corePrepExprFloat env (Let bind body) = do
collect_args (Cast fun co) depth = do
let (_ty1,ty2) = coercionKind co
- (fun', hd, fun_ty, floats, ss) <- collect_args fun depth
+ (fun', hd, _, floats, ss) <- collect_args fun depth
return (Cast fun' co, hd, ty2, floats, ss)
collect_args (Note note fun) depth
ty = exprType fun
ignore_note (CoreNote _) = True
- ignore_note InlineMe = True
ignore_note _other = False
-- We don't ignore SCCs, since they require some code generation
-- v = f (x `divInt#` y)
-- we don't want to float the case, even if f has arity 2,
-- because floating the case would make it evaluated too early
- return (floats, rhs)
+ do { us <- getUniquesM
+ ; let eta_rhs = etaExpand arity us rhs (idType bndr)
+ -- For a GlobalId, take the Arity from the Id.
+ -- It was set in CoreTidy and must not change
+ -- For all others, just expand at will
+ -- See Note [Eta expansion]
+ arity | isGlobalId bndr = idArity bndr
+ | otherwise = exprArity rhs
+ ; return (floats, eta_rhs) }
| otherwise = do
-- Don't float; the RHS isn't a value
rhs' <- mkBinds floats rhs
return (emptyFloats, rhs')
+\end{code}
+Note [Eta expansion]
+~~~~~~~~~~~~~~~~~~~~~
+Eta expand to match the arity claimed by the binder Remember,
+CorePrep must not change arity
+
+Eta expansion might not have happened already, because it is done by
+the simplifier only when there at least one lambda already.
+
+NB1:we could refrain when the RHS is trivial (which can happen
+ for exported things). This would reduce the amount of code
+ generated (a little) and make things a little words for
+ code compiled without -O. The case in point is data constructor
+ wrappers.
+
+NB2: we have to be careful that the result of etaExpand doesn't
+ invalidate any of the assumptions that CorePrep is attempting
+ to establish. One possible cause is eta expanding inside of
+ an SCC note - we're now careful in etaExpand to make sure the
+ SCC is pushed inside any new lambdas that are generated.
+
+NB3: It's important to do eta expansion, and *then* ANF-ising
+ f = /\a -> g (h 3) -- h has arity 2
+If we ANF first we get
+ f = /\a -> let s = h 3 in g s
+and now eta expansion gives
+ f = /\a -> \ y -> (let s = h 3 in g s) y
+which is horrible.
+Eta expanding first gives
+ f = /\a -> \y -> let s = h 3 in g s y
+
+\begin{code}
-- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
-> Floats -> CoreExpr -- Rhs: let binds in body
| isStrict dem
-- It's a strict let so we definitely float all the bindings
- = let -- Don't make a case for a value binding,
+ = let -- Don't make a case for a value binding,
-- even if it's strict. Otherwise we get
-- case (\x -> e) of ...!
float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
- | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
+ | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
in
return (addFloat floats float, evald_bndr)
mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
-etaExpandRhs bndr rhs = do
- -- Eta expand to match the arity claimed by the binder
- -- Remember, after CorePrep we must not change arity
- --
- -- Eta expansion might not have happened already,
- -- because it is done by the simplifier only when
- -- there at least one lambda already.
- --
- -- NB1:we could refrain when the RHS is trivial (which can happen
- -- for exported things). This would reduce the amount of code
- -- generated (a little) and make things a little words for
- -- code compiled without -O. The case in point is data constructor
- -- wrappers.
- --
- -- NB2: we have to be careful that the result of etaExpand doesn't
- -- invalidate any of the assumptions that CorePrep is attempting
- -- to establish. One possible cause is eta expanding inside of
- -- an SCC note - we're now careful in etaExpand to make sure the
- -- SCC is pushed inside any new lambdas that are generated.
- --
- -- NB3: It's important to do eta expansion, and *then* ANF-ising
- -- f = /\a -> g (h 3) -- h has arity 2
- -- If we ANF first we get
- -- f = /\a -> let s = h 3 in g s
- -- and now eta expansion gives
- -- f = /\a -> \ y -> (let s = h 3 in g s) y
- -- which is horrible.
- -- Eta expanding first gives
- -- f = /\a -> \y -> let s = h 3 in g s y
- --
- us <- getUniquesM
- return (etaExpand arity us rhs (idType bndr))
- where
- -- For a GlobalId, take the Arity from the Id.
- -- It was set in CoreTidy and must not change
- -- For all others, just expand at will
- arity | isGlobalId bndr = idArity bndr
- | otherwise = exprArity rhs
-- ---------------------------------------------------------------------------
-- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
-- get to a partial application:
-- \xs. map f xs ==> map f
+tryEta :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
tryEta bndrs expr@(App _ _)
| ok_to_eta_reduce f &&
n_remaining >= 0 &&
n_remaining = length args - length bndrs
ok bndr (Var arg) = bndr == arg
- ok bndr other = False
+ ok _ _ = False
-- we can't eta reduce something which must be saturated.
ok_to_eta_reduce (Var f) = not (hasNoBinding f)
ok_to_eta_reduce _ = False --safe. ToDo: generalise
-tryEta bndrs (Let bind@(NonRec b r) body)
+tryEta bndrs (Let bind@(NonRec _ r) body)
| not (any (`elemVarSet` fvs) bndrs)
= case tryEta bndrs body of
Just e -> Just (Let bind e)
where
fvs = exprFreeVars r
-tryEta bndrs _ = Nothing
+tryEta _ _ = Nothing
\end{code}
\begin{code}
data RhsDemand
- = RhsDemand { isStrict :: Bool, -- True => used at least once
- isOnceDem :: Bool -- True => used at most once
+ = RhsDemand { isStrict :: Bool, -- True => used at least once
+ _isOnceDem :: Bool -- True => used at most once
}
mkDem :: Demand -> Bool -> RhsDemand
mkDem strict once = RhsDemand (isStrictDmd strict) once
mkDemTy :: Demand -> Type -> RhsDemand
-mkDemTy strict ty = RhsDemand (isStrictDmd strict)
- False {- For now -}
+mkDemTy strict _ty = RhsDemand (isStrictDmd strict)
+ False {- For now -}
bdrDem :: Id -> RhsDemand
bdrDem id = mkDem (idNewDemandInfo id)
newVar ty
= seqType ty `seq` do
uniq <- getUniqueM
- return (mkSysLocal FSLIT("sat") uniq ty)
+ return (mkSysLocal (fsLit "sat") uniq ty)
\end{code}
projects / ghc-hetmet.git / blobdiff