import CoreUtils
import CoreArity
import CoreFVs
-import CoreMonad ( endPass )
+import CoreMonad ( endPass, CoreToDo(..) )
import CoreSyn
+import CoreSubst
+import OccurAnal ( occurAnalyseExpr )
import Type
import Coercion
import TyCon
import ErrUtils
import DynFlags
import Util
+import Pair
import Outputable
import MonadUtils
import FastString
+import Data.List ( mapAccumL )
import Control.Monad
\end{code}
weaker guarantee of no clashes which the simplifier provides.
And that is what the code generator needs.
- We don't clone TyVars. The code gen doesn't need that,
+ We don't clone TyVars or CoVars. The code gen doesn't need that,
and doing so would be tiresome because then we'd need
- to substitute in types.
+ to substitute in types and coercions.
7. Give each dynamic CCall occurrence a fresh unique; this is
Here is the syntax of the Core produced by CorePrep:
Trivial expressions
- triv ::= lit | var | triv ty | /\a. triv | triv |> co
+ triv ::= lit | var
+ | triv ty | /\a. triv
+ | truv co | /\c. triv | triv |> co
Applications
- app ::= lit | var | app triv | app ty | app |> co
+ app ::= lit | var | app triv | app ty | app co | app |> co
Expressions
body ::= app
| let(rec) x = rhs in body -- Boxed only
| case body of pat -> body
- | /\a. body
+ | /\a. body | /\c. body
| body |> co
- Right hand sides (only place where lambdas can occur)
+ Right hand sides (only place where value lambdas can occur)
rhs ::= /\a.rhs | \x.rhs | body
We define a synonym for each of these non-terminals. Functions
floats2 <- corePrepTopBinds implicit_binds
return (deFloatTop (floats1 `appendFloats` floats2))
- endPass dflags "CorePrep" Opt_D_dump_prep binds_out []
+ endPass dflags CorePrep binds_out []
return binds_out
corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
Note [CafInfo and floating]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What happens to the CafInfo on the floated bindings? By default, all
-the CafInfos will be set to MayHaveCafRefs, which is safe.
-
-This might be pessimistic, because the floated binding might not refer
-to any CAFs and the GC will end up doing more traversal than is
-necessary, but it's still better than not floating the bindings at
-all, because then the GC would have to traverse the structure in the
-heap instead. Given this, we decided not to try to get the CafInfo on
-the floated bindings correct, because it looks difficult.
-
-But that means we can't float anything out of a NoCafRefs binding.
-Consider f = g (h x)
-If f is NoCafRefs, we don't want to convert to
- sat = h x
- f = g sat
-where sat conservatively says HasCafRefs, because now f's info
-is wrong. I don't think this is common, so we simply switch off
-floating in this case.
+What happens when we try to float bindings to the top level? At this
+point all the CafInfo is supposed to be correct, and we must make certain
+that is true of the new top-level bindings. There are two cases
+to consider
+
+a) The top-level binding is marked asCafRefs. In that case we are
+ basically fine. The floated bindings had better all be lazy lets,
+ so they can float to top level, but they'll all have HasCafRefs
+ (the default) which is safe.
+
+b) The top-level binding is marked NoCafRefs. This really happens
+ Example. CoreTidy produces
+ $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...
+ Now CorePrep has to eta-expand to
+ $fApplicativeSTM = let sat = \xy. retry x y
+ in D:Alternative sat ...blah...
+ So what we *want* is
+ sat [NoCafRefs] = \xy. retry x y
+ $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...
+
+ So, gruesomely, we must set the NoCafRefs flag on the sat bindings,
+ *and* substutite the modified 'sat' into the old RHS.
+
+ It should be the case that 'sat' is itself [NoCafRefs] (a value, no
+ cafs) else the original top-level binding would not itself have been
+ marked [NoCafRefs]. The DEBUG check in CoreToStg for
+ consistentCafInfo will find this.
+
+This is all very gruesome and horrible. It would be better to figure
+out CafInfo later, after CorePrep. We'll do that in due course.
+Meanwhile this horrible hack works.
+
Note [Data constructor workers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
partial applications. But it's easier to let them through.
+Note [Dead code in CorePrep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Imagine that we got an input program like this:
+
+ f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
+ f x = (g True (Just x) + g () (Just x), g)
+ where
+ g :: Show a => a -> Maybe Int -> Int
+ g _ Nothing = x
+ g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown
+
+After specialisation and SpecConstr, we would get something like this:
+
+ f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
+ f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)
+ where
+ {-# RULES g $dBool = g$Bool
+ g $dUnit = g$Unit #-}
+ g = ...
+ {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}
+ g$Bool = ...
+ {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}
+ g$Unit = ...
+ g$Bool_True_Just = ...
+ g$Unit_Unit_Just = ...
+
+Note that the g$Bool and g$Unit functions are actually dead code: they are only kept
+alive by the occurrence analyser because they are referred to by the rules of g,
+which is being kept alive by the fact that it is used (unspecialised) in the returned pair.
+
+However, at the CorePrep stage there is no way that the rules for g will ever fire,
+and it really seems like a shame to produce an output program that goes to the trouble
+of allocating a closure for the unreachable g$Bool and g$Unit functions.
+
+The way we fix this is to:
+ * In cloneBndr, drop all unfoldings/rules
+ * In deFloatTop, run the occurrence analyser on each top-level RHS to drop
+ the dead local bindings
+
+The reason we don't just OccAnal the whole output of CorePrep is that the tidier
+ensures that all top-level binders are GlobalIds, so they don't show up in the free
+variables any longer. So if you run the occurrence analyser on the output of CoreTidy
+(or later) you e.g. turn this program:
+
+ Rec {
+ f = ... f ...
+ }
+
+Into this one:
+
+ f = ... f ...
+
+(Since f is not considered to be free in its own RHS.)
+
+
%************************************************************************
%* *
The main code
; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
; let (floats_s, bndrs2, rhss2) = unzip3 stuff
- all_pairs = foldrOL add_float (bndrs1 `zip` rhss2)
+ all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)
(concatFloats floats_s)
; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
unitFloat (FloatLet (Rec all_pairs))) }
---------------
cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
-> CorePrepEnv -> Id -> CoreExpr
- -> UniqSM (Floats, Id, CoreExpr)
+ -> UniqSM (Floats, Id, CpeRhs)
-- Used for all bindings
cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
= do { (floats1, rhs1) <- cpeRhsE env rhs
- ; let (rhs1_bndrs, _) = collectBinders rhs1
- ; (floats2, rhs2)
- <- if want_float floats1 rhs1
- then return (floats1, rhs1)
- else -- Non-empty floats will wrap rhs1
- -- But: rhs1 might have lambdas, and we can't
- -- put them inside a wrapBinds
- if valBndrCount rhs1_bndrs <= arity
- then -- Lambdas in rhs1 will be nuked by eta expansion
- return (emptyFloats, wrapBinds floats1 rhs1)
-
- else do { body1 <- rhsToBodyNF rhs1
- ; return (emptyFloats, wrapBinds floats1 body1) }
-
- ; (floats3, rhs') -- Note [Silly extra arguments]
- <- if manifestArity rhs2 <= arity
+
+ -- See if we are allowed to float this stuff out of the RHS
+ ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
+
+ -- Make the arity match up
+ ; (floats3, rhs')
+ <- if manifestArity rhs1 <= arity
then return (floats2, cpeEtaExpand arity rhs2)
else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
+ -- Note [Silly extra arguments]
(do { v <- newVar (idType bndr)
; let float = mkFloat False False v rhs2
; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
- -- Record if the binder is evaluated
+ -- Record if the binder is evaluated
+ -- and otherwise trim off the unfolding altogether
+ -- It's not used by the code generator; getting rid of it reduces
+ -- heap usage and, since we may be changing uniques, we'd have
+ -- to substitute to keep it right
; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
- | otherwise = bndr
+ | otherwise = bndr `setIdUnfolding` noUnfolding
; return (floats3, bndr', rhs') }
where
arity = idArity bndr -- We must match this arity
- want_float floats rhs
- | isTopLevel top_lvl = wantFloatTop bndr floats
- | otherwise = wantFloatNested is_rec is_strict_or_unlifted floats rhs
+
+ ---------------------
+ float_from_rhs floats rhs
+ | isEmptyFloats floats = return (emptyFloats, rhs)
+ | isTopLevel top_lvl = float_top floats rhs
+ | otherwise = float_nested floats rhs
+
+ ---------------------
+ float_nested floats rhs
+ | wantFloatNested is_rec is_strict_or_unlifted floats rhs
+ = return (floats, rhs)
+ | otherwise = dont_float floats rhs
+
+ ---------------------
+ float_top floats rhs -- Urhgh! See Note [CafInfo and floating]
+ | mayHaveCafRefs (idCafInfo bndr)
+ , allLazyTop floats
+ = return (floats, rhs)
+
+ -- So the top-level binding is marked NoCafRefs
+ | Just (floats', rhs') <- canFloatFromNoCaf floats rhs
+ = return (floats', rhs')
+
+ | otherwise
+ = dont_float floats rhs
+
+ ---------------------
+ dont_float floats rhs
+ -- Non-empty floats, but do not want to float from rhs
+ -- So wrap the rhs in the floats
+ -- But: rhs1 might have lambdas, and we can't
+ -- put them inside a wrapBinds
+ = do { body <- rhsToBodyNF rhs
+ ; return (emptyFloats, wrapBinds floats body) }
{- Note [Silly extra arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- For example
-- f (g x) ===> ([v = g x], f v)
-cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
-cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr)
-cpeRhsE env expr@(Var {}) = cpeApp env expr
+cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)
+cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
+cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
+cpeRhsE env expr@(Var {}) = cpeApp env expr
cpeRhsE env (Var f `App` _ `App` arg)
| f `hasKey` lazyIdKey -- Replace (lazy a) by a
; return (floats, Cast e' co) }
rhsToBody expr@(Lam {})
- | Just no_lam_result <- tryEtaReduce bndrs body
+ | Just no_lam_result <- tryEtaReducePrep bndrs body
= return (emptyFloats, no_lam_result)
| all isTyVar bndrs -- Type lambdas are ok
= return (emptyFloats, expr)
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
+ collect_args (App fun arg@(Coercion arg_co)) depth
+ = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
+ ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) }
+
collect_args (App fun arg) depth
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
; let
-- partial application might be seq'd
collect_args (Cast fun co) depth
- = do { let (_ty1,ty2) = coercionKind co
+ = do { let Pair _ty1 ty2 = coercionKind co
; (fun', hd, _, floats, ss) <- collect_args fun depth
; return (Cast fun' co, hd, ty2, floats, ss) }
cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
-> UniqSM (Floats, CpeTriv)
cpeArg env is_strict arg arg_ty
- | cpe_ExprIsTrivial arg -- Do not eta expand etc a trivial argument
- = cpeBody env arg -- Must still do substitution though
- | otherwise
- = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda
+ = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda
; (floats2, arg2) <- if want_float floats1 arg1
then return (floats1, arg1)
else do { body1 <- rhsToBodyNF arg1
-- Else case: arg1 might have lambdas, and we can't
-- put them inside a wrapBinds
- ; v <- newVar arg_ty
+ ; if cpe_ExprIsTrivial arg2 -- Do not eta expand a trivial argument
+ then return (floats2, arg2)
+ else do
+ { v <- newVar arg_ty
; let arg3 = cpeEtaExpand (exprArity arg2) arg2
arg_float = mkFloat is_strict is_unlifted v arg3
- ; return (addFloat floats2 arg_float, Var v) }
+ ; return (addFloat floats2 arg_float, Var v) } }
where
is_unlifted = isUnLiftedType arg_ty
want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
-------------
saturateDataToTag :: CpeApp -> UniqSM CpeApp
--- Horrid: ensure that the arg of data2TagOp is evaluated
--- (data2tag x) --> (case x of y -> data2tag y)
--- (yuk yuk) take into account the lambdas we've now introduced
+-- See Note [dataToTag magic]
saturateDataToTag sat_expr
= do { let (eta_bndrs, eta_body) = collectBinders sat_expr
; eta_body' <- eval_data2tag_arg eta_body
= pprPanic "eval_data2tag" (ppr other)
\end{code}
+Note [dataToTag magic]
+~~~~~~~~~~~~~~~~~~~~~~
+Horrid: we must ensure that the arg of data2TagOp is evaluated
+ (data2tag x) --> (case x of y -> data2tag y)
+(yuk yuk) take into account the lambdas we've now introduced
+How might it not be evaluated? Well, we might have floated it out
+of the scope of a `seq`, or dropped the `seq` altogether.
%************************************************************************
-- Version that doesn't consider an scc annotation to be trivial.
cpe_ExprIsTrivial (Var _) = True
cpe_ExprIsTrivial (Type _) = True
+cpe_ExprIsTrivial (Coercion _) = True
cpe_ExprIsTrivial (Lit _) = True
cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e
-cpe_ExprIsTrivial (Note (SCC _) _) = False
-cpe_ExprIsTrivial (Note _ e) = cpe_ExprIsTrivial e
+cpe_ExprIsTrivial (Note n e) = notSccNote n && cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
cpe_ExprIsTrivial _ = False
f = /\a -> \y -> let s = h 3 in g s y
\begin{code}
-cpeEtaExpand :: Arity -> CoreExpr -> CoreExpr
+cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
cpeEtaExpand arity expr
| arity == 0 = expr
| otherwise = etaExpand arity expr
==> case x of { p -> map f }
\begin{code}
-tryEtaReduce :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
-tryEtaReduce bndrs expr@(App _ _)
+tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
+tryEtaReducePrep bndrs expr@(App _ _)
| ok_to_eta_reduce f &&
n_remaining >= 0 &&
and (zipWith ok bndrs last_args) &&
ok_to_eta_reduce (Var f) = not (hasNoBinding f)
ok_to_eta_reduce _ = False --safe. ToDo: generalise
-tryEtaReduce bndrs (Let bind@(NonRec _ r) body)
+tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
| not (any (`elemVarSet` fvs) bndrs)
- = case tryEtaReduce bndrs body of
+ = case tryEtaReducePrep bndrs body of
Just e -> Just (Let bind e)
Nothing -> Nothing
where
fvs = exprFreeVars r
-tryEtaReduce _ _ = Nothing
+tryEtaReducePrep _ _ = Nothing
\end{code}
\begin{code}
data FloatingBind
- = FloatLet CoreBind -- Rhs of bindings are CpeRhss
- | FloatCase Id CpeBody Bool -- The bool indicates "ok-for-speculation"
+ = FloatLet CoreBind -- Rhs of bindings are CpeRhss
+ -- They are always of lifted type;
+ -- unlifted ones are done with FloatCase
+
+ | FloatCase
+ Id CpeBody
+ Bool -- The bool indicates "ok-for-speculation"
data Floats = Floats OkToSpec (OrdList FloatingBind)
+instance Outputable FloatingBind where
+ ppr (FloatLet b) = ppr b
+ ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
+
+instance Outputable Floats where
+ ppr (Floats flag fs) = ptext (sLit "Floats") <> brackets (ppr flag) <+>
+ braces (vcat (map ppr (fromOL fs)))
+
+instance Outputable OkToSpec where
+ ppr OkToSpec = ptext (sLit "OkToSpec")
+ ppr IfUnboxedOk = ptext (sLit "IfUnboxedOk")
+ ppr NotOkToSpec = ptext (sLit "NotOkToSpec")
+
-- Can we float these binds out of the rhs of a let? We cache this decision
-- to avoid having to recompute it in a non-linear way when there are
-- deeply nested lets.
data OkToSpec
- = NotOkToSpec -- definitely not
- | OkToSpec -- yes
- | IfUnboxedOk -- only if floating an unboxed binding is ok
+ = OkToSpec -- Lazy bindings of lifted type
+ | IfUnboxedOk -- A mixture of lazy lifted bindings and n
+ -- ok-to-speculate unlifted bindings
+ | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings
mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind
mkFloat is_strict is_unlifted bndr rhs
isEmptyFloats :: Floats -> Bool
isEmptyFloats (Floats _ bs) = isNilOL bs
-wrapBinds :: Floats -> CoreExpr -> CoreExpr
+wrapBinds :: Floats -> CpeBody -> CpeBody
wrapBinds (Floats _ binds) body
= foldrOL mk_bind body binds
where
combine _ IfUnboxedOk = IfUnboxedOk
combine _ _ = OkToSpec
-instance Outputable FloatingBind where
- ppr (FloatLet bind) = text "FloatLet" <+> ppr bind
- ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
-
deFloatTop :: Floats -> [CoreBind]
-- For top level only; we don't expect any FloatCases
deFloatTop (Floats _ floats)
= foldrOL get [] floats
where
- get (FloatLet b) bs = b:bs
+ get (FloatLet b) bs = occurAnalyseRHSs b : bs
get b _ = pprPanic "corePrepPgm" (ppr b)
+
+ -- See Note [Dead code in CorePrep]
+ occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr e)
+ occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes]
-------------------------------------------
-wantFloatTop :: Id -> Floats -> Bool
+canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
-- Note [CafInfo and floating]
-wantFloatTop bndr floats = isEmptyFloats floats
- || (mayHaveCafRefs (idCafInfo bndr)
- && allLazyTop floats)
+canFloatFromNoCaf (Floats ok_to_spec fs) rhs
+ | OkToSpec <- ok_to_spec -- Worth trying
+ , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
+ = Just (Floats OkToSpec fs', subst_expr subst rhs)
+ | otherwise
+ = Nothing
+ where
+ subst_expr = substExpr (text "CorePrep")
+
+ go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
+ -> Maybe (Subst, OrdList FloatingBind)
+
+ go (subst, fbs_out) [] = Just (subst, fbs_out)
+
+ go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
+ | rhs_ok r
+ = go (subst', fbs_out `snocOL` new_fb) fbs_in
+ where
+ (subst', b') = set_nocaf_bndr subst b
+ new_fb = FloatLet (NonRec b' (subst_expr subst r))
+
+ go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
+ | all rhs_ok rs
+ = go (subst', fbs_out `snocOL` new_fb) fbs_in
+ where
+ (bs,rs) = unzip prs
+ (subst', bs') = mapAccumL set_nocaf_bndr subst bs
+ rs' = map (subst_expr subst') rs
+ new_fb = FloatLet (Rec (bs' `zip` rs'))
+
+ go _ _ = Nothing -- Encountered a caffy binding
+
+ ------------
+ set_nocaf_bndr subst bndr
+ = (extendIdSubst subst bndr (Var bndr'), bndr')
+ where
+ bndr' = bndr `setIdCafInfo` NoCafRefs
+
+ ------------
+ rhs_ok :: CoreExpr -> Bool
+ -- We can only float to top level from a NoCaf thing if
+ -- the new binding is static. However it can't mention
+ -- any non-static things or it would *already* be Caffy
+ rhs_ok = rhsIsStatic (\_ -> False)
wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
wantFloatNested is_rec strict_or_unlifted floats rhs
cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
cloneBndr env bndr
- | isLocalId bndr
+ | isLocalId bndr, not (isCoVar bndr)
= do bndr' <- setVarUnique bndr <$> getUniqueM
- return (extendCorePrepEnv env bndr bndr', bndr')
+
+ -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
+ -- so that we can drop more stuff as dead code.
+ -- See also Note [Dead code in CorePrep]
+ let bndr'' = bndr' `setIdUnfolding` noUnfolding
+ `setIdSpecialisation` emptySpecInfo
+ return (extendCorePrepEnv env bndr bndr'', bndr'')
| otherwise -- Top level things, which we don't want
-- to clone, have become GlobalIds by now
- -- And we don't clone tyvars
+ -- And we don't clone tyvars, or coercion variables
= return (env, bndr)
projects / ghc-hetmet.git / blobdiff