import CoreUnfold ( certainlyWillInline )
import CoreLint ( showPass, endPass )
import CoreUtils ( exprType, exprIsValue )
-import Id ( Id, idType, isOneShotLambda,
+import Id ( Id, idType, isOneShotLambda,
setIdNewStrictness, mkWorkerId,
setIdWorkerInfo, setInlinePragma,
idInfo )
+import MkId ( lazyIdKey, lazyIdUnfolding )
import Type ( Type )
import IdInfo ( WorkerInfo(..), arityInfo,
newDemandInfo, newStrictnessInfo, unfoldingInfo, inlinePragInfo
)
-import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), Keepity(..),
- mkTopDmdType, isBotRes, returnsCPR, topSig
+import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
+ Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
)
import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
+import Unique ( hasKey )
import BasicTypes ( RecFlag(..), isNonRec, Activation(..) )
+import VarEnv ( isEmptyVarEnv )
import Maybes ( orElse )
import CmdLineOpts
import WwLib
-import Util ( lengthIs )
+import Util ( lengthIs, notNull )
import Outputable
\end{code}
\begin{code}
wwExpr :: CoreExpr -> UniqSM CoreExpr
-wwExpr e@(Type _) = returnUs e
-wwExpr e@(Var _) = returnUs e
-wwExpr e@(Lit _) = returnUs e
+wwExpr e@(Type _) = returnUs e
+wwExpr e@(Lit _) = returnUs e
+wwExpr e@(Note InlineMe expr) = returnUs e
+ -- Don't w/w inside InlineMe's
+
+wwExpr e@(Var v)
+ | v `hasKey` lazyIdKey = returnUs lazyIdUnfolding
+ | otherwise = returnUs e
+ -- Inline 'lazy' after strictness analysis
+ -- (but not inside InlineMe's)
wwExpr (Lam binder expr)
= wwExpr expr `thenUs` \ new_expr ->
wwExpr expr `thenUs` \ new_expr ->
returnUs (mkLets intermediate_bind new_expr)
-wwExpr (Case expr binder alts)
+wwExpr (Case expr binder ty alts)
= wwExpr expr `thenUs` \ new_expr ->
mapUs ww_alt alts `thenUs` \ new_alts ->
- returnUs (Case new_expr binder new_alts)
+ returnUs (Case new_expr binder ty new_alts)
where
ww_alt (con, binders, rhs)
= wwExpr rhs `thenUs` \ new_rhs ->
-- fw = \ab -> (__inline (\x -> E)) (a,b)
-- and the original __inline now vanishes, so E is no longer
-- inside its __inline wrapper. Death! Disaster!
- = returnUs [ (fn_id, rhs) ]
+ = returnUs [ (new_fn_id, rhs) ]
- | is_thunk && worthSplittingThunk fn_dmd res_info
- = ASSERT( isNonRec is_rec ) -- The thunk must be non-recursive
- splitThunk fn_id rhs
+ | is_thunk && worthSplittingThunk maybe_fn_dmd res_info
+ = ASSERT2( isNonRec is_rec, ppr new_fn_id ) -- The thunk must be non-recursive
+ splitThunk new_fn_id rhs
| is_fun && worthSplittingFun wrap_dmds res_info
- = splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
+ = splitFun new_fn_id fn_info wrap_dmds res_info inline_prag rhs
| otherwise
- = returnUs [ (fn_id, rhs) ]
+ = returnUs [ (new_fn_id, rhs) ]
where
- fn_info = idInfo fn_id
- fn_dmd = newDemandInfo fn_info
- unfolding = unfoldingInfo fn_info
- inline_prag = inlinePragInfo fn_info
- strict_sig = newStrictnessInfo fn_info `orElse` topSig
-
- StrictSig (DmdType _ wrap_dmds res_info) = strict_sig
+ fn_info = idInfo fn_id
+ maybe_fn_dmd = newDemandInfo fn_info
+ unfolding = unfoldingInfo fn_info
+ inline_prag = inlinePragInfo fn_info
- is_fun = not (null wrap_dmds)
+ -- In practice it always will have a strictness
+ -- signature, even if it's a uninformative one
+ strict_sig = newStrictnessInfo fn_info `orElse` topSig
+ StrictSig (DmdType env wrap_dmds res_info) = strict_sig
+
+ -- new_fn_id has the DmdEnv zapped.
+ -- (a) it is never used again
+ -- (b) it wastes space
+ -- (c) it becomes incorrect as things are cloned, because
+ -- we don't push the substitution into it
+ new_fn_id | isEmptyVarEnv env = fn_id
+ | otherwise = fn_id `setIdNewStrictness`
+ StrictSig (mkTopDmdType wrap_dmds res_info)
+
+ is_fun = notNull wrap_dmds
is_thunk = not is_fun && not (exprIsValue rhs)
---------------------
-- [We don't do reboxing now, but in general it's better to pass
-- an unboxed thing to f, and have it reboxed in the error cases....]
where
- worth_it Abs = True -- Absent arg
- worth_it (Seq _ ds) = True -- Arg to evaluate
- worth_it other = False
+ worth_it Abs = True -- Absent arg
+ worth_it (Eval (Prod ds)) = True -- Product arg to evaluate
+ worth_it other = False
-worthSplittingThunk :: Demand -- Demand on the thunk
+worthSplittingThunk :: Maybe Demand -- Demand on the thunk
-> DmdResult -- CPR info for the thunk
-> Bool
-worthSplittingThunk dmd res
- = worth_it dmd || returnsCPR res
+worthSplittingThunk maybe_dmd res
+ = worth_it maybe_dmd || returnsCPR res
where
-- Split if the thing is unpacked
- worth_it (Seq Defer ds) = False
- worth_it (Seq _ ds) = any not_abs ds
- worth_it other = False
-
- not_abs Abs = False
- not_abs other = True
+ worth_it (Just (Eval (Prod ds))) = not (all isAbsent ds)
+ worth_it other = False
\end{code}
projects / ghc-hetmet.git / blobdiff