#include "HsVersions.h"
+import PrelNames ( lazyIdKey, hasKey )
import CoreUtils
import CoreArity
import CoreFVs
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.
-> UniqSM (Floats, Id, CoreExpr)
-- 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
+ ; 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
+ then return (floats2, cpeEtaExpand arity rhs2)
+ else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
+ (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
; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
| otherwise = bndr
- ; return (floats, bndr', rhs') }
+ ; 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
-
+{- 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, [])
= 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)
emptyFloats :: Floats
emptyFloats = Floats OkToSpec nilOL
+isEmptyFloats :: Floats -> Bool
+isEmptyFloats (Floats _ bs) = isNilOL bs
+
wrapBinds :: Floats -> CoreExpr -> CoreExpr
wrapBinds (Floats _ binds) body
= foldrOL mk_bind body binds
-------------------------------------------
wantFloatTop :: Id -> Floats -> Bool
-- Note [CafInfo and floating]
-wantFloatTop bndr floats = mayHaveCafRefs (idCafInfo bndr)
- && allLazyTop floats
+wantFloatTop bndr floats = isEmptyFloats floats
+ || (mayHaveCafRefs (idCafInfo bndr)
+ && allLazyTop floats)
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)