-----------------
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs,
both {- needed by WwLib -}
) where
import DynFlags ( DynFlags, DynFlag(..) )
import StaticFlags ( opt_MaxWorkerArgs )
-import NewDemand -- All of it
+import Demand -- All of it
import CoreSyn
import PprCore
-import CoreUtils ( exprIsHNF, exprIsTrivial, exprArity )
+import CoreUtils ( exprIsHNF, exprIsTrivial )
+import CoreArity ( exprArity )
import DataCon ( dataConTyCon )
import TyCon ( isProductTyCon, isRecursiveTyCon )
-import Id ( Id, idType, idInlinePragma,
+import Id ( Id, idType, idInlineActivation,
isDataConWorkId, isGlobalId, idArity,
-#ifdef OLD_STRICTNESS
- idDemandInfo, idStrictness, idCprInfo, idName,
-#endif
- idNewStrictness, idNewStrictness_maybe,
- setIdNewStrictness, idNewDemandInfo,
- idNewDemandInfo_maybe,
- setIdNewDemandInfo
+ idStrictness, idStrictness_maybe,
+ setIdStrictness, idDemandInfo,
+ idDemandInfo_maybe,
+ setIdDemandInfo
)
-#ifdef OLD_STRICTNESS
-import IdInfo ( newStrictnessFromOld, newDemand )
-#endif
import Var ( Var )
import VarEnv
import TysWiredIn ( unboxedPairDataCon )
keysUFM, minusUFM, ufmToList, filterUFM )
import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe )
import Coercion ( coercionKind )
-import CoreLint ( showPass, endPass )
import Util ( mapAndUnzip, lengthIs )
import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
RecFlag(..), isRec )
import Maybes ( orElse, expectJust )
+import ErrUtils ( showPass )
import Outputable
import Data.List
dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
dmdAnalPgm dflags binds
= do {
- showPass dflags "Demand analysis" ;
let { binds_plus_dmds = do_prog binds } ;
-
- endPass dflags "Demand analysis"
- Opt_D_dump_stranal binds_plus_dmds ;
-#ifdef OLD_STRICTNESS
- -- Only if OLD_STRICTNESS is on, because only then is the old
- -- strictness analyser run
- let { dmd_changes = get_changes binds_plus_dmds } ;
- printDump (text "Changes in demands" $$ dmd_changes) ;
-#endif
return binds_plus_dmds
}
where
-- x = (a, absent-error)
-- and that'll crash.
-- So at one stage I had:
- -- dead_case_bndr = isAbsentDmd (idNewDemandInfo case_bndr')
+ -- dead_case_bndr = isAbsentDmd (idDemandInfo case_bndr')
-- keepity | dead_case_bndr = Drop
-- | otherwise = Keep
--
-- 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
- alt_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b])
+ alt_dmd = Eval (Prod [idDemandInfo b | b <- bndrs', isId b])
scrut_dmd = alt_dmd `both`
- idNewDemandInfo case_bndr'
+ idDemandInfo case_bndr'
(scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
in
-- of the fixpoint algorithm. (Cunning plan.)
-- Note that the cunning plan extends to the DmdEnv too,
-- since it is part of the strictness signature
-initialSig id = idNewStrictness_maybe id `orElse` botSig
+initialSig id = idStrictness_maybe id `orElse` botSig
dmdAnalRhs :: TopLevelFlag -> RecFlag
-> SigEnv -> (Id, CoreExpr)
-- The RHS can be eta-reduced to just a variable,
-- in which case we should not complain.
mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty
- id' = id `setIdNewStrictness` sig_ty
+ id' = id `setIdStrictness` sig_ty
sigs' = extendSigEnv top_lvl sigs id sig_ty
\end{code}
mkSigTy top_lvl rec_flag id rhs dmd_ty
= mk_sig_ty never_inline thunk_cpr_ok rhs dmd_ty
where
- never_inline = isNeverActive (idInlinePragma id)
- maybe_id_dmd = idNewDemandInfo_maybe id
+ never_inline = isNeverActive (idInlineActivation id)
+ maybe_id_dmd = idDemandInfo_maybe id
-- Is Nothing the first time round
thunk_cpr_ok
by dmdAnalTopBind.
+Note [NOINLINE and strictness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The strictness analyser used to have a HACK which ensured that NOINLNE
+things were not strictness-analysed. The reason was unsafePerformIO.
+Left to itself, the strictness analyser would discover this strictness
+for unsafePerformIO:
+ unsafePerformIO: C(U(AV))
+But then consider this sub-expression
+ unsafePerformIO (\s -> let r = f x in
+ case writeIORef v r s of (# s1, _ #) ->
+ (# s1, r #)
+The strictness analyser will now find that r is sure to be eval'd,
+and may then hoist it out. This makes tests/lib/should_run/memo002
+deadlock.
+
+Solving this by making all NOINLINE things have no strictness info is overkill.
+In particular, it's overkill for runST, which is perfectly respectable.
+Consider
+ f x = runST (return x)
+This should be strict in x.
+
+So the new plan is to define unsafePerformIO using the 'lazy' combinator:
+
+ unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
+
+Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is
+magically NON-STRICT, and is inlined after strictness analysis. So
+unsafePerformIO will look non-strict, and that's what we want.
+
+Now we don't need the hack in the strictness analyser. HOWEVER, this
+decision does mean that even a NOINLINE function is not entirely
+opaque: some aspect of its implementation leaks out, notably its
+strictness. For example, if you have a function implemented by an
+error stub, but which has RULES, you may want it not to be eliminated
+in favour of error!
+
+
\begin{code}
mk_sig_ty never_inline thunk_cpr_ok rhs (DmdType fv dmds res)
= (lazy_fv, mkStrictSig dmd_ty)
+ -- Re unused never_inline, see Note [NOINLINE and strictness]
where
dmd_ty = DmdType strict_fv final_dmds res'
%************************************************************************
\begin{code}
-splitDmdTy :: DmdType -> (Demand, DmdType)
--- Split off one function argument
--- We already have a suitable demand on all
--- free vars, so no need to add more!
-splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
-splitDmdTy ty@(DmdType fv [] res_ty) = (resTypeArgDmd res_ty, ty)
-\end{code}
-
-\begin{code}
unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes
addVarDmd top_lvl dmd_ty@(DmdType fv ds res) var dmd
-- 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 dmd)
+ | otherwise = (DmdType fv' ds res, setIdDemandInfo var dmd)
where
(fv', dmd) = removeFV fv var res
annotateBndrs = mapAccumR annotateBndr
+annotateLamIdBndr :: DmdType -- Demand type of body
+ -> Id -- Lambda binder
+ -> (DmdType, -- Demand type of lambda
+ Id) -- and binder annotated with demand
+
annotateLamIdBndr dmd_ty@(DmdType fv ds res) id
-- For lambdas we add the demand to the argument demands
-- Only called for Ids
= ASSERT( isId id )
- (DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd)
+ (DmdType fv' (hacked_dmd:ds) res, setIdDemandInfo id hacked_dmd)
where
(fv', dmd) = removeFV fv id res
hacked_dmd = argDemand dmd
-- CPR results (e.g. from \x -> x!).
extendSigsWithLam sigs id
- = case idNewDemandInfo_maybe id of
+ = case idDemandInfo_maybe id of
Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel)
-- Optimistic in the Nothing case;
-- See notes [CPR-AND-STRICTNESS]
------ DATA CONSTRUCTOR
| isDataConWorkId var -- Data constructor
= let
- StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig
+ StrictSig dmd_ty = idStrictness var -- It must have a strictness sig
DmdType _ _ con_res = dmd_ty
arity = idArity var
in
------ IMPORTED FUNCTION
| isGlobalId var, -- Imported function
- let StrictSig dmd_ty = idNewStrictness var
+ let StrictSig dmd_ty = idStrictness var
= if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand
dmd_ty
else
%************************************************************************
\begin{code}
+splitDmdTy :: DmdType -> (Demand, DmdType)
+-- Split off one function argument
+-- We already have a suitable demand on all
+-- free vars, so no need to add more!
+splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
+splitDmdTy ty@(DmdType fv [] res_ty) = (resTypeArgDmd res_ty, ty)
+
splitCallDmd :: Demand -> (Int, Demand)
splitCallDmd (Call d) = case splitCallDmd d of
(n, r) -> (n+1, r)
-- 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
boths ds1 ds2 = zipWithDmds both ds1 ds2
\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{Miscellaneous
-%* *
-%************************************************************************
-
-
-\begin{code}
-#ifdef OLD_STRICTNESS
-get_changes binds = vcat (map get_changes_bind binds)
-
-get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
-get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
-
-get_changes_pr (id,rhs)
- = get_changes_var id $$ get_changes_expr rhs
-
-get_changes_var var
- | isId var = get_changes_str var $$ get_changes_dmd var
- | otherwise = empty
-
-get_changes_expr (Type t) = empty
-get_changes_expr (Var v) = empty
-get_changes_expr (Lit l) = empty
-get_changes_expr (Note n e) = get_changes_expr e
-get_changes_expr (App e1 e2) = get_changes_expr e1 $$ get_changes_expr e2
-get_changes_expr (Lam b e) = {- get_changes_var b $$ -} get_changes_expr e
-get_changes_expr (Let b e) = get_changes_bind b $$ get_changes_expr e
-get_changes_expr (Case e b a) = get_changes_expr e $$ {- get_changes_var b $$ -} vcat (map get_changes_alt a)
-
-get_changes_alt (con,bs,rhs) = {- vcat (map get_changes_var bs) $$ -} get_changes_expr rhs
-
-get_changes_str id
- | new_better && old_better = empty
- | new_better = message "BETTER"
- | old_better = message "WORSE"
- | otherwise = message "INCOMPARABLE"
- where
- message word = text word <+> text "strictness for" <+> ppr id <+> info
- info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
- new = squashSig (idNewStrictness id) -- Don't report spurious diffs that the old
- -- strictness analyser can't track
- old = newStrictnessFromOld (idName id) (idArity id) (idStrictness id) (idCprInfo id)
- old_better = old `betterStrictness` new
- new_better = new `betterStrictness` old
-
-get_changes_dmd id
- | isUnLiftedType (idType id) = empty -- Not useful
- | new_better && old_better = empty
- | new_better = message "BETTER"
- | old_better = message "WORSE"
- | otherwise = message "INCOMPARABLE"
- where
- message word = text word <+> text "demand for" <+> ppr id <+> info
- info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
- new = squashDmd (argDemand (idNewDemandInfo id)) -- To avoid spurious improvements
- -- A bit of a hack
- old = newDemand (idDemandInfo id)
- new_better = new `betterDemand` old
- old_better = old `betterDemand` new
-
-betterStrictness :: StrictSig -> StrictSig -> Bool
-betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2
-
-betterDmdType t1 t2 = (t1 `lubType` t2) == t2
-
-betterDemand :: Demand -> Demand -> Bool
--- If d1 `better` d2, and d2 `better` d2, then d1==d2
-betterDemand d1 d2 = (d1 `lub` d2) == d2
-
-squashSig (StrictSig (DmdType fv ds res))
- = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res)
- where
- -- squash just gets rid of call demands
- -- which the old analyser doesn't track
-squashDmd (Call d) = evalDmd
-squashDmd (Box d) = Box (squashDmd d)
-squashDmd (Eval ds) = Eval (mapDmds squashDmd ds)
-squashDmd (Defer ds) = Defer (mapDmds squashDmd ds)
-squashDmd d = d
-#endif
-\end{code}
projects / ghc-hetmet.git / blobdiff