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
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
Note [CafInfo and floating]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What happense when we try to float bindings to the top level. At this
+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
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 top_lvl is_rec is_strict_or_unlifted env bndr rhs
= do { (floats1, rhs1) <- cpeRhsE env rhs
- ; (floats2, rhs2)
+ -- 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 (floats1, cpeEtaExpand arity rhs1)
+ 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 rhs1
- ; return (addFloat floats1 float, cpeEtaExpand arity (Var v)) })
-
- ; (floats3, rhs') <- float_from_rhs floats2 rhs2
-
- -- Record if the binder is evaluated
+ ; let float = mkFloat False False v rhs2
+ ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
+
+ -- 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
---------------------
- float_from_rhs floats2 rhs2
- | isEmptyFloats floats2 = return (emptyFloats, rhs2)
- | isTopLevel top_lvl = float_top floats2 rhs2
- | otherwise = float_nested floats2 rhs2
+ float_from_rhs floats rhs
+ | isEmptyFloats floats = return (emptyFloats, rhs)
+ | isTopLevel top_lvl = float_top floats rhs
+ | otherwise = float_nested floats rhs
---------------------
- float_nested floats2 rhs2
- | wantFloatNested is_rec is_strict_or_unlifted floats2 rhs2
- = return (floats2, rhs2)
- | otherwise = dont_float floats2 rhs2
+ float_nested floats rhs
+ | wantFloatNested is_rec is_strict_or_unlifted floats rhs
+ = return (floats, rhs)
+ | otherwise = dont_float floats rhs
---------------------
- float_top floats2 rhs2 -- Urhgh! See Note [CafInfo and floating]
+ float_top floats rhs -- Urhgh! See Note [CafInfo and floating]
| mayHaveCafRefs (idCafInfo bndr)
- = if allLazyTop floats2
- then return (floats2, rhs2)
- else dont_float floats2 rhs2
+ , allLazyTop floats
+ = return (floats, rhs)
+
+ -- So the top-level binding is marked NoCafRefs
+ | Just (floats', rhs') <- canFloatFromNoCaf floats rhs
+ = return (floats', rhs')
| otherwise
- = case canFloatFromNoCaf floats2 rhs2 of
- Just (floats2', rhs2') -> return (floats2', rhs2')
- Nothing -> pprPanic "cpePair" (ppr bndr $$ ppr rhs2 $$ ppr floats2)
+ = dont_float floats rhs
---------------------
- dont_float floats2 rhs2
+ 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 { body2 <- rhsToBodyNF rhs2
- ; return (emptyFloats, wrapBinds floats2 body2) }
+ = 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
rhsToBody expr@(Lam {})
| Just no_lam_result <- tryEtaReducePrep bndrs body
= return (emptyFloats, no_lam_result)
- | all isTyCoVar bndrs -- Type lambdas are ok
+ | all isTyVar bndrs -- Type lambdas are ok
= return (emptyFloats, expr)
| otherwise -- Some value lambdas
= do { fn <- newVar (exprType 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) | isTyCoVar b = cpe_ExprIsTrivial body
+cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
cpe_ExprIsTrivial _ = False
\end{code}
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]
-------------------------------------------
canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
-- Note [CafInfo and floating]
canFloatFromNoCaf (Floats ok_to_spec fs) rhs
- | OkToSpec <- ok_to_spec
- = Just (Floats OkToSpec (toOL fs'), subst_expr subst 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, fs') = mapAccumL set_nocaf emptySubst (fromOL fs)
-
subst_expr = substExpr (text "CorePrep")
- set_nocaf _ (FloatCase {})
- = panic "canFloatFromNoCaf"
+ go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
+ -> Maybe (Subst, OrdList FloatingBind)
- set_nocaf subst (FloatLet (NonRec b r))
- = (subst', FloatLet (NonRec b' (subst_expr subst r)))
+ 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))
- set_nocaf subst (FloatLet (Rec prs))
- = (subst', FloatLet (Rec (bs' `zip` rs')))
+ 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
= isEmptyFloats floats
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