import CoreUtils ( exprIsValue, exprArity )
import DataCon ( dataConTyCon )
import TyCon ( isProductTyCon, isRecursiveTyCon )
-import Id ( Id, idType, idDemandInfo, idArity,
- isDataConId, isImplicitId, isGlobalId,
+import Id ( Id, idType, idDemandInfo, idInlinePragma,
+ isDataConId, isGlobalId, idArity,
idNewStrictness, idNewStrictness_maybe, getNewStrictness, setIdNewStrictness,
idNewDemandInfo, setIdNewDemandInfo, newStrictnessFromOld )
import IdInfo ( newDemand )
import Type ( isUnLiftedType )
import CoreLint ( showPass, endPass )
import Util ( mapAndUnzip, mapAccumL, mapAccumR )
-import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel )
+import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive )
import Maybes ( orElse, expectJust )
import Outputable
\end{code}
-> CoreBind
-> (SigEnv, CoreBind)
dmdAnalTopBind sigs (NonRec id rhs)
- | isImplicitId id -- Don't touch the info on constructors, selectors etc
- = (sigs, NonRec id rhs) -- It's pre-computed in MkId.lhs
- | otherwise
= let
- (sigs', _, (id', rhs')) = dmdAnalRhs TopLevel sigs (id, rhs)
+ ( _, _, (_, rhs1)) = dmdAnalRhs TopLevel sigs (id, rhs)
+ (sigs2, _, (id2, rhs2)) = dmdAnalRhs TopLevel sigs (id, rhs1)
+ -- Do two passes to improve CPR information
+ -- See the comments with mkSigTy.ignore_cpr_info below
in
- (sigs', NonRec id' rhs')
+ (sigs2, NonRec id2 rhs2)
dmdAnalTopBind sigs (Rec pairs)
= let
(sigs', _, pairs') = dmdFix TopLevel sigs pairs
+ -- We get two iterations automatically
in
(sigs', Rec pairs')
\end{code}
where
arity = exprArity rhs
(rhs_ty, rhs') = dmdAnal emptySigEnv (vanillaCall arity) rhs
- (_, sig) = mkSigTy rhs rhs_ty
+ sig = mkTopSigTy rhs rhs_ty
\end{code}
%************************************************************************
-- Lots of the other code is there to make this
-- beautiful, compositional, application rule :-)
-dmdAnal sigs dmd (App fun arg) -- Non-type arguments
+dmdAnal sigs dmd e@(App fun arg) -- Non-type arguments
= let -- [Type arg handled above]
(fun_ty, fun') = dmdAnal sigs (Call dmd) fun
(arg_ty, arg') = dmdAnal sigs arg_dmd arg
isProductTyCon tycon,
not (isRecursiveTyCon tycon)
= let
- (alt_ty, alt') = dmdAnalAlt sigs dmd alt
- (alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr
- (_, bndrs', _) = alt'
+ sigs_alt = extendSigEnv NotTopLevel sigs case_bndr case_bndr_sig
+ (alt_ty, alt') = dmdAnalAlt sigs_alt dmd alt
+ (alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr
+ (_, bndrs', _) = alt'
+ case_bndr_sig = StrictSig (mkDmdType emptyVarEnv [] RetCPR)
+ -- Inside the alternative, the case binder has the CPR property.
+ -- Meaning that a case on it will successfully cancel.
+ -- Example:
+ -- f True x = case x of y { I# x' -> if x' ==# 3 then y else I# 8 }
+ -- f False x = I# 3
+ --
+ -- We want f to have the CPR property:
+ -- f b x = case fw b x of { r -> I# r }
+ -- fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
+ -- fw False x = 3
-- Figure out whether the demand on the case binder is used, and use
-- that to set the scrut_dmd. This is utterly essential.
-- The insight is, of course, that a demand on y is a demand on the
-- scrutinee, so we need to `both` it with the scrut demand
- scrut_dmd = mkSeq Drop [idNewDemandInfo b | b <- bndrs', isId b]
+ scrut_dmd = mkSeq Drop [idNewDemandInfo b | b <- bndrs', isId b]
`both`
- idNewDemandInfo case_bndr'
+ idNewDemandInfo case_bndr'
- (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
+ (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
in
(alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' [alt'])
dmdAnalRhs top_lvl sigs (id, rhs)
= (sigs', lazy_fv, (id', rhs'))
where
- arity = exprArity rhs -- The idArity may not be up to date
- (rhs_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs
- (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_ty, ppr id )
- mkSigTy rhs rhs_ty
- id' = id `setIdNewStrictness` sig_ty
- sigs' = extendSigEnv top_lvl sigs id sig_ty
+ arity = idArity id -- The idArity should be up to date
+ -- The simplifier was run just beforehand
+ (rhs_dmd_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs
+ (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty, ppr id )
+ mkSigTy id rhs rhs_dmd_ty
+ id' = id `setIdNewStrictness` sig_ty
+ sigs' = extendSigEnv top_lvl sigs id sig_ty
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-mkSigTy :: CoreExpr -> DmdType -> (DmdEnv, StrictSig)
--- Take a DmdType and turn it into a StrictSig
-mkSigTy rhs (DmdType fv dmds res)
+mkTopSigTy :: CoreExpr -> DmdType -> StrictSig
+ -- Take a DmdType and turn it into a StrictSig
+ -- NB: not used for never-inline things; hence False
+mkTopSigTy rhs dmd_ty = snd (mk_sig_ty False False rhs dmd_ty)
+
+mkSigTy :: Id -> CoreExpr -> DmdType -> (DmdEnv, StrictSig)
+mkSigTy id rhs dmd_ty = mk_sig_ty (isNeverActive (idInlinePragma id))
+ (isStrictDmd (idNewDemandInfo id))
+ rhs dmd_ty
+
+mk_sig_ty never_inline strictly_demanded rhs (DmdType fv dmds res)
+ | never_inline && not (isBotRes res)
+ -- HACK ALERT
+ -- Don't strictness-analyse NOINLINE things. Why not? Because
+ -- the NOINLINE says "don't expose any of the inner workings at the call
+ -- site" and the strictness is certainly an inner working.
+ --
+ -- More concretely, the demand analyser discovers the following strictness
+ -- for unsafePerformIO: C(U(AV))
+ -- But then consider
+ -- unsafePerformIO (\s -> let r = f x in
+ -- case writeIORef v r s of (# s1, _ #) ->
+ -- (# s1, r #)
+ -- The strictness analyser will find that the binding for r is strict,
+ -- (becuase of uPIO's strictness sig), and so it'll evaluate it before
+ -- doing the writeIORef. This actually makes tests/lib/should_run/memo002
+ -- get a deadlock!
+ --
+ -- Solution: don't expose the strictness of unsafePerformIO.
+ --
+ -- But we do want to expose the strictness of error functions,
+ -- which are also often marked NOINLINE
+ -- {-# NOINLINE foo #-}
+ -- foo x = error ("wubble buggle" ++ x)
+ -- So (hack, hack) we only drop the strictness for non-bottom things
+ -- This is all very unsatisfactory.
+ = (deferEnv fv, topSig)
+
+ | otherwise
= (lazy_fv, mkStrictSig dmd_ty)
where
dmd_ty = DmdType strict_fv final_dmds res'
-- DmdType, because that makes fixpointing very slow --- the
-- DmdType gets full of lazy demands that are slow to converge.
- lazified_dmds = map funArgDemand dmds
- -- Get rid of defers in the arguments
- final_dmds = setUnpackStrategy lazified_dmds
+ final_dmds = setUnpackStrategy dmds
-- Set the unpacking strategy
res' = case res of
- RetCPR | not (exprIsValue rhs) -> TopRes
- other -> res
+ RetCPR | ignore_cpr_info -> TopRes
+ other -> res
+ ignore_cpr_info = is_thunk && not strictly_demanded
+ is_thunk = not (exprIsValue rhs)
-- If the rhs is a thunk, we forget the CPR info, because
-- it is presumably shared (else it would have been inlined, and
-- so we'd lose sharing if w/w'd it into a function.
--
- -- DONE IN OLD CPR ANALYSER, BUT NOT YET HERE
- -- Also, if the strictness analyser has figured out that it's strict,
- -- the let-to-case transformation will happen, so again it's good.
- -- (CPR analysis runs before the simplifier has had a chance to do
- -- the let-to-case transform.)
+ -- Also, if the strictness analyser has figured out (in a previous iteration)
+ -- that it's strict, the let-to-case transformation will happen, so again
+ -- it's good.
-- This made a big difference to PrelBase.modInt, which had something like
-- modInt = \ x -> let r = ... -> I# v in
-- ...body strict in r...
-- r's RHS isn't a value yet; but modInt returns r in various branches, so
-- if r doesn't have the CPR property then neither does modInt
+ -- Another case I found in practice (in Complex.magnitude), looks like this:
+ -- let k = if ... then I# a else I# b
+ -- in ... body strict in k ....
+ -- (For this example, it doesn't matter whether k is returned as part of
+ -- the overall result.) Left to itself, the simplifier will make a join
+ -- point thus:
+ -- let $j k = ...body strict in k...
+ -- if ... then $j (I# a) else $j (I# b)
+ --
+ --
+ -- The difficulty with this is that we need the strictness type to
+ -- look at the body... but we now need the body to calculate the demand
+ -- on the variable, so we can decide whether its strictness type should
+ -- have a CPR in it or not. Simple solution:
+ -- a) use strictness info from the previous iteration
+ -- b) make sure we do at least 2 iterations, by doing a second
+ -- round for top-level non-recs. Top level recs will get at
+ -- least 2 iterations except for totally-bottom functions
+ -- which aren't very interesting anyway.
+ --
+ -- NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.
\end{code}
The unpack strategy determines whether we'll *really* unpack the argument,
splitDmdTy ty@(DmdType fv [] TopRes) = (Lazy, ty)
splitDmdTy ty@(DmdType fv [] BotRes) = (Bot, ty)
-- NB: Bot not Abs
-splitDmdTy (DmdType fv [] RetCPR) = panic "splitDmdTy"
+splitDmdTy ty@(DmdType fv [] RetCPR) = panic "splitDmdTy"
-- We should not be applying a product as a function!
\end{code}
-- No effect on the argument demands
annotateBndr dmd_ty@(DmdType fv ds res) var
| isTyVar var = (dmd_ty, var)
- | otherwise = (DmdType fv' ds res, setIdNewDemandInfo var hacked_dmd)
+ | otherwise = (DmdType fv' ds res,
+ setIdNewDemandInfo var (argDemand var dmd))
where
(fv', dmd) = removeFV fv var res
- hacked_dmd | isUnLiftedType (idType var) = unliftedDemand dmd
- | otherwise = dmd
annotateBndrs = mapAccumR annotateBndr
(DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd)
where
(fv', dmd) = removeFV fv id res
- hacked_dmd | isUnLiftedType (idType id) = unliftedDemand dmd
- | otherwise = funArgDemand dmd
- -- This call to funArgDemand is vital, because otherwise we label
+ hacked_dmd = argDemand id dmd
+ -- This call to argDemand is vital, because otherwise we label
-- a lambda binder with demand 'B'. But in terms of calling
-- conventions that's Abs, because we don't pass it. But
-- when we do a w/w split we get
------ DATA CONSTRUCTOR
| isDataConId var, -- Data constructor
- Seq k ds <- res_dmd, -- and the demand looks inside its fields
- let StrictSig dmd_ty = idNewStrictness var, -- It must have a strictness sig
- let DmdType _ _ con_res = dmd_ty
- = if idArity var == call_depth then -- Saturated, so unleash the demand
- -- ds can be empty, when we are just seq'ing the thing
+ Seq k ds <- res_dmd -- and the demand looks inside its fields
+ = let
+ StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig
+ DmdType _ _ con_res = dmd_ty
+ arity = idArity var
+ in
+ if arity == call_depth then -- Saturated, so unleash the demand
let
+ -- ds can be empty, when we are just seq'ing the thing
+ -- If so we must make up a suitable bunch of demands
+ dmd_ds | null ds = replicate arity Abs
+ | otherwise = ASSERT( length ds == arity ) ds
+
arg_ds = case k of
- Keep -> bothLazy_s ds
- Drop -> ds
+ Keep -> bothLazy_s dmd_ds
+ Drop -> dmd_ds
Defer -> pprTrace "dmdTransform: surprising!" (ppr var)
-- I don't think this can happen
- ds
+ dmd_ds
-- Important! If we Keep the constructor application, then
-- we need the demands the constructor places (always lazy)
-- If not, we don't need to. For example:
vanillaCall n = Call (vanillaCall (n-1))
deferType :: DmdType -> DmdType
-deferType (DmdType fv _ _) = DmdType (mapVarEnv defer fv) [] TopRes
+deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] TopRes
-- Notice that we throw away info about both arguments and results
-- For example, f = let ... in \x -> x
-- We don't want to get a stricness type V->T for f.
-- Peter??
+deferEnv :: DmdEnv -> DmdEnv
+deferEnv fv = mapVarEnv defer fv
+
---------------
bothLazy :: Demand -> Demand
bothLazy = both Lazy
bothLazy_s :: [Demand] -> [Demand]
bothLazy_s = map bothLazy
-funArgDemand :: Demand -> Demand
+
+----------------
+argDemand :: Id -> Demand -> Demand
+argDemand id dmd | isUnLiftedType (idType id) = unliftedArgDemand dmd
+ | otherwise = liftedArgDemand dmd
+
+liftedArgDemand :: Demand -> Demand
-- The 'Defer' demands are just Lazy at function boundaries
-- Ugly! Ask John how to improve it.
-funArgDemand (Seq Defer ds) = Lazy
-funArgDemand (Seq k ds) = Seq k (map funArgDemand ds)
-funArgDemand Err = Eval -- Args passed to a bottoming function
-funArgDemand Bot = Abs -- Don't pass args that are consumed by bottom/err
-funArgDemand d = d
-
-unliftedDemand :: Demand -> Demand
+liftedArgDemand (Seq Defer ds) = Lazy
+liftedArgDemand (Seq k ds) = Seq k (map liftedArgDemand ds)
+ -- Urk! Don't have type info here
+liftedArgDemand Err = Eval -- Args passed to a bottoming function
+liftedArgDemand Bot = Abs -- Don't pass args that are consumed by bottom/err
+liftedArgDemand d = d
+
+unliftedArgDemand :: Demand -> Demand
-- Same idea, but for unlifted types the domain is much simpler:
-- Either we use it (Lazy) or we don't (Abs)
-unliftedDemand Bot = Abs
-unliftedDemand Abs = Abs
-unliftedDemand other = Lazy
+unliftedArgDemand Bot = Abs
+unliftedArgDemand Abs = Abs
+unliftedArgDemand other = Lazy
\end{code}
\begin{code}
lub Bot d = d
lub Err Bot = Err
+lub Err Abs = Lazy -- E.g. f x = if ... then True else error x
lub Err d = d
lub Lazy d = Lazy
lub_ds k1 ds1 k2 ds2 = ds1 `lubs` ds2
------------------
+ -- Note that (Keep `lub` Drop) is Drop, not Keep
+ -- Why not? See the example above with (lub Eval d).
lub_keep Keep k = k
lub_keep Drop Defer = Defer
get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
get_changes_pr (id,rhs)
- | isImplicitId id = empty -- We don't look inside these
- | otherwise = get_changes_var id $$ get_changes_expr rhs
+ = get_changes_var id $$ get_changes_expr rhs
get_changes_var var
| isId var = get_changes_str var $$ get_changes_dmd var
where
message word = text word <+> text "demand for" <+> ppr id <+> info
info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
- new = funArgDemand (idNewDemandInfo id) -- FunArgDemand to avoid spurious improvements
+ new = liftedArgDemand (idNewDemandInfo id) -- To avoid spurious improvements
old = newDemand (idDemandInfo id)
new_better = new `betterDemand` old
old_better = old `betterDemand` new
projects / ghc-hetmet.git / blobdiff