#include "HsVersions.h"
+import PrelNames ( lazyIdKey, hasKey )
import CoreUtils
import CoreArity
import CoreFVs
-import CoreLint
+import CoreMonad ( endPass, CoreToDo(..) )
import CoreSyn
+import CoreSubst
import Type
import Coercion
import TyCon
-import NewDemand
+import Demand
import Var
import VarSet
import VarEnv
import Outputable
import MonadUtils
import FastString
+import Data.List ( mapAccumL )
import Control.Monad
\end{code}
8. Inject bindings for the "implicit" Ids:
* Constructor wrappers
* Constructor workers
- * Record selectors
We want curried definitions for all of these in case they
aren't inlined by some caller.
+9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs
+
This is all done modulo type applications and abstractions, so that
when type erasure is done for conversion to STG, we don't end up with
any trivial or useless bindings.
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 happense 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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-> UniqSM (CorePrepEnv, Floats)
cpeBind top_lvl env (NonRec bndr rhs)
= do { (_, bndr1) <- cloneBndr env bndr
- ; let is_strict = isStrictDmd (idNewDemandInfo bndr)
+ ; let is_strict = isStrictDmd (idDemandInfo bndr)
is_unlifted = isUnLiftedType (idType bndr)
; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
(is_strict || is_unlifted)
---------------
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 { (floats, rhs') <- cpeRhs want_float (idArity bndr) env rhs
+ = do { (floats1, rhs1) <- cpeRhsE env rhs
+
+ ; (floats2, rhs2)
+ <- if manifestArity rhs1 <= arity
+ then return (floats1, cpeEtaExpand arity rhs1)
+ 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 bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
| otherwise = bndr
- ; return (floats, bndr', rhs') }
+ ; return (floats3, bndr', rhs') }
where
- want_float floats rhs
- | isTopLevel top_lvl = wantFloatTop bndr floats
- | otherwise = wantFloatNested is_rec is_strict_or_unlifted floats rhs
-
-
+ 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_nested floats2 rhs2
+ | wantFloatNested is_rec is_strict_or_unlifted floats2 rhs2
+ = return (floats2, rhs2)
+ | otherwise = dont_float floats2 rhs2
+
+ ---------------------
+ float_top floats2 rhs2 -- Urhgh! See Note [CafInfo and floating]
+ | mayHaveCafRefs (idCafInfo bndr)
+ = if allLazyTop floats2
+ then return (floats2, rhs2)
+ else dont_float floats2 rhs2
+
+ | otherwise
+ = case canFloatFromNoCaf floats2 rhs2 of
+ Just (floats2', rhs2') -> return (floats2', rhs2')
+ Nothing -> pprPanic "cpePair" (ppr bndr $$ ppr rhs2 $$ ppr floats2)
+
+ ---------------------
+ dont_float floats2 rhs2
+ -- 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) }
+
+{- Note [Silly extra arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we had this
+ f{arity=1} = \x\y. e
+We *must* match the arity on the Id, so we have to generate
+ f' = \x\y. e
+ f = \x. f' x
+
+It's a bizarre case: why is the arity on the Id wrong? Reason
+(in the days of __inline_me__):
+ f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
+When InlineMe notes go away this won't happen any more. But
+it seems good for CorePrep to be robust.
+-}
-- ---------------------------------------------------------------------------
-- CpeRhs: produces a result satisfying CpeRhs
-- ---------------------------------------------------------------------------
-cpeRhs :: (Floats -> CpeRhs -> Bool) -- Float the floats out
- -> Arity -- Guarantees an Rhs with this manifest arity
- -> CorePrepEnv
- -> CoreExpr -- Expression and its type
- -> UniqSM (Floats, CpeRhs)
-cpeRhs want_float arity env expr
- = do { (floats, rhs) <- cpeRhsE env expr
- ; if want_float floats rhs
- then return (floats, cpeEtaExpand arity rhs)
- else return (emptyFloats, cpeEtaExpand arity (wrapBinds floats rhs)) }
-
cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
-- If
-- e ===> (bs, e')
cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr)
-cpeRhsE env expr@(App {}) = cpeApp env expr
cpeRhsE env expr@(Var {}) = cpeApp env expr
+cpeRhsE env (Var f `App` _ `App` arg)
+ | f `hasKey` lazyIdKey -- Replace (lazy a) by a
+ = cpeRhsE env arg -- See Note [lazyId magic] in MkId
+
+cpeRhsE env expr@(App {}) = cpeApp env expr
+
cpeRhsE env (Let bind expr)
= do { (env', new_binds) <- cpeBind NotTopLevel env bind
; (floats, body) <- cpeRhsE env' expr
; return (floats1 `appendFloats` floats2, body) }
--------
+rhsToBodyNF :: CpeRhs -> UniqSM CpeBody
+rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
+ ; return (wrapBinds floats body) }
+
+--------
rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
--- Remove top level lambdas by let-bindinig
+-- Remove top level lambdas by let-binding
rhsToBody (Note n expr)
-- You can get things like
collect_args (App fun arg) depth
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
- ; let
+ ; let
(ss1, ss_rest) = case ss of
(ss1:ss_rest) -> (ss1, ss_rest)
[] -> (lazyDmd, [])
; let v2 = lookupCorePrepEnv env v1
; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
where
- stricts = case idNewStrictness v of
+ stricts = case idStrictness v of
StrictSig (DmdType _ demands _)
| listLengthCmp demands depth /= GT -> demands
-- length demands <= depth
= collect_args fun depth -- They aren't used by the code generator
-- N-variable fun, better let-bind it
- -- ToDo: perhaps we can case-bind rather than let-bind this closure,
- -- since it is sure to be evaluated.
collect_args fun depth
= do { (fun_floats, fun') <- cpeArg env True fun ty
+ -- The True says that it's sure to be evaluated,
+ -- so we'll end up case-binding it
; return (fun', (fun', depth), ty, fun_floats, []) }
where
ty = exprType fun
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
+ | cpe_ExprIsTrivial arg -- Do not eta expand etc a trivial argument
+ = cpeBody env arg -- Must still do substitution though
| otherwise
- = do { (floats, arg') <- cpeRhs want_float
- (exprArity arg) env arg
+ = 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
+ ; return (emptyFloats, wrapBinds floats1 body1) }
+ -- Else case: arg1 might have lambdas, and we can't
+ -- put them inside a wrapBinds
+
; v <- newVar arg_ty
- ; let arg_float = mkFloat is_strict is_unlifted v arg'
- ; return (addFloat floats arg_float, Var v) }
+ ; let arg3 = cpeEtaExpand (exprArity arg2) arg2
+ arg_float = mkFloat is_strict is_unlifted v arg3
+ ; return (addFloat floats2 arg_float, Var v) }
where
is_unlifted = isUnLiftedType arg_ty
want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
-- want to get this:
-- unzip = /\ab \xs. (__inline_me__ ...) a b xs
ignoreNote (CoreNote _) = True
-ignoreNote InlineMe = True
ignoreNote _other = 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
\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
emptyFloats :: Floats
emptyFloats = Floats OkToSpec nilOL
-wrapBinds :: Floats -> CoreExpr -> CoreExpr
+isEmptyFloats :: Floats -> Bool
+isEmptyFloats (Floats _ bs) = isNilOL bs
+
+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)
get b _ = pprPanic "corePrepPgm" (ppr b)
-------------------------------------------
-wantFloatTop :: Id -> Floats -> Bool
+canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
-- Note [CafInfo and floating]
-wantFloatTop bndr floats = mayHaveCafRefs (idCafInfo bndr)
- && allLazyTop floats
+canFloatFromNoCaf (Floats ok_to_spec fs) rhs
+ | OkToSpec <- ok_to_spec
+ = Just (Floats OkToSpec (toOL 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"
+
+ set_nocaf subst (FloatLet (NonRec b r))
+ = (subst', FloatLet (NonRec b' (subst_expr subst r)))
+ where
+ (subst', b') = set_nocaf_bndr subst b
+
+ set_nocaf subst (FloatLet (Rec prs))
+ = (subst', FloatLet (Rec (bs' `zip` rs')))
+ where
+ (bs,rs) = unzip prs
+ (subst', bs') = mapAccumL set_nocaf_bndr subst bs
+ rs' = map (subst_expr subst') rs
+
+ set_nocaf_bndr subst bndr
+ = (extendIdSubst subst bndr (Var bndr'), bndr')
+ where
+ bndr' = bndr `setIdCafInfo` NoCafRefs
wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
wantFloatNested is_rec strict_or_unlifted floats rhs
- = strict_or_unlifted
+ = isEmptyFloats floats
+ || strict_or_unlifted
|| (allLazyNested is_rec floats && exprIsHNF rhs)
-- Why the test for allLazyNested?
-- v = f (x `divInt#` y)