DmdAnal.lhs 40.3 KB
 simonpj committed Jul 17, 2001 1 2 3 4 5 6 7 8 9 % % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % ----------------- A demand analysis ----------------- \begin{code}  simonpj committed Sep 07, 2001 10 11 12 module DmdAnal ( dmdAnalPgm, dmdAnalTopRhs, both {- needed by WwLib -} ) where  simonpj committed Jul 17, 2001 13 14 15  #include "HsVersions.h"  simonmar committed Mar 18, 2005 16 17 import DynFlags ( DynFlags, DynFlag(..) ) import StaticFlags ( opt_MaxWorkerArgs )  simonpj committed Jul 17, 2001 18 19 import NewDemand -- All of it import CoreSyn  simonpj committed Sep 07, 2001 20 import PprCore  simonpj committed Aug 10, 2005 21 import CoreUtils ( exprIsHNF, exprIsTrivial, exprArity )  simonpj committed Jul 17, 2001 22 23 import DataCon ( dataConTyCon ) import TyCon ( isProductTyCon, isRecursiveTyCon )  simonmar committed Dec 10, 2001 24 import Id ( Id, idType, idInlinePragma,  simonpj committed Feb 12, 2003 25  isDataConWorkId, isGlobalId, idArity,  simonmar committed Mar 15, 2002 26 #ifdef OLD_STRICTNESS  simonpj committed Sep 13, 2002 27  idDemandInfo, idStrictness, idCprInfo, idName,  simonmar committed Dec 10, 2001 28 29 30 #endif idNewStrictness, idNewStrictness_maybe, setIdNewStrictness, idNewDemandInfo,  simonpj committed Apr 04, 2002 31  idNewDemandInfo_maybe,  simonpj committed Sep 13, 2002 32  setIdNewDemandInfo  simonmar committed Dec 10, 2001 33  )  simonmar committed Mar 15, 2002 34 #ifdef OLD_STRICTNESS  simonmar committed Dec 10, 2001 35 36 import IdInfo ( newStrictnessFromOld, newDemand ) #endif  simonpj committed Jul 17, 2001 37 38 import Var ( Var ) import VarEnv  simonpj committed Jun 23, 2003 39 40 import TysWiredIn ( unboxedPairDataCon ) import TysPrim ( realWorldStatePrimTy )  simonpj committed Jul 19, 2001 41 import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,  simonpj committed Jul 20, 2001 42  keysUFM, minusUFM, ufmToList, filterUFM )  chak@cse.unsw.edu.au. committed Aug 04, 2006 43 44 import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe ) import Coercion ( coercionKind )  simonpj committed Jul 17, 2001 45 import CoreLint ( showPass, endPass )  simonpj committed Nov 19, 2001 46 import Util ( mapAndUnzip, mapAccumL, mapAccumR, lengthIs )  simonpj committed Apr 05, 2002 47 48 import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive, RecFlag(..), isRec )  simonpj committed Jul 19, 2001 49 import Maybes ( orElse, expectJust )  simonpj committed Jul 17, 2001 50 51 52 import Outputable \end{code}  simonpj committed Jul 23, 2001 53 54 55 56 57 58 59 To think about * set a noinline pragma on bottoming Ids * Consider f x = x+1 fatbar error (show x) We'd like to unbox x, even if that means reboxing it in the error case.  simonpj committed Jul 17, 2001 60 61 62 63 64 65 66 67 68 69 70 71  %************************************************************************ %* * \subsection{Top level stuff} %* * %************************************************************************ \begin{code} dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind] dmdAnalPgm dflags binds = do { showPass dflags "Demand analysis" ;  simonmar committed Dec 10, 2001 72  let { binds_plus_dmds = do_prog binds } ;  simonpj committed Apr 04, 2002 73   simonpj committed Jul 17, 2001 74 75  endPass dflags "Demand analysis" Opt_D_dump_stranal binds_plus_dmds ;  simonmar committed Mar 15, 2002 76 77 #ifdef OLD_STRICTNESS -- Only if OLD_STRICTNESS is on, because only then is the old  simonmar committed Dec 10, 2001 78  -- strictness analyser run  simonpj committed Dec 11, 2001 79  let { dmd_changes = get_changes binds_plus_dmds } ;  simonpj committed Jul 17, 2001 80  printDump (text "Changes in demands" $$dmd_changes) ;  simonpj committed Jul 25, 2001 81 #endif  simonpj committed Jul 17, 2001 82 83 84 85 86 87 88 89 90 91 92  return binds_plus_dmds } where do_prog :: [CoreBind] -> [CoreBind] do_prog binds = snd  mapAccumL dmdAnalTopBind emptySigEnv binds dmdAnalTopBind :: SigEnv -> CoreBind -> (SigEnv, CoreBind) dmdAnalTopBind sigs (NonRec id rhs) = let  simonpj committed Apr 05, 2002 93 94  ( _, _, (_, rhs1)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs) (sigs2, _, (id2, rhs2)) = dmdAnalRhs TopLevel NonRecursive sigs (id, rhs1)  simonpj committed Oct 24, 2001 95  -- Do two passes to improve CPR information  simonpj committed Apr 04, 2002 96 97  -- See comments with ignore_cpr_info in mk_sig_ty -- and with extendSigsWithLam  simonpj committed Jul 17, 2001 98  in  simonpj committed Oct 24, 2001 99  (sigs2, NonRec id2 rhs2)  simonpj committed Jul 17, 2001 100 101 102  dmdAnalTopBind sigs (Rec pairs) = let  simonpj committed Jul 20, 2001 103  (sigs', _, pairs') = dmdFix TopLevel sigs pairs  simonpj committed Oct 24, 2001 104  -- We get two iterations automatically  simonpj committed Apr 04, 2002 105  -- c.f. the NonRec case above  simonpj committed Jul 17, 2001 106 107 108 109  in (sigs', Rec pairs') \end{code}  simonpj committed Sep 07, 2001 110 111 112 113 114 115 \begin{code} dmdAnalTopRhs :: CoreExpr -> (StrictSig, CoreExpr) -- Analyse the RHS and return -- a) appropriate strictness info -- b) the unfolding (decorated with stricntess info) dmdAnalTopRhs rhs  simonpj@microsoft.com committed Jan 31, 2006 116  = (sig, rhs2)  simonpj committed Sep 07, 2001 117  where  simonpj@microsoft.com committed Jan 31, 2006 118 119 120  call_dmd = vanillaCall (exprArity rhs) (_, rhs1) = dmdAnal emptySigEnv call_dmd rhs (rhs_ty, rhs2) = dmdAnal emptySigEnv call_dmd rhs1  simonpj committed Oct 24, 2001 121  sig = mkTopSigTy rhs rhs_ty  simonpj@microsoft.com committed Jan 31, 2006 122 123 124 125 126 127  -- Do two passes; see notes with extendSigsWithLam -- Otherwise we get bogus CPR info for constructors like -- newtype T a = MkT a -- The constructor looks like (\x::T a -> x), modulo the coerce -- extendSigsWithLam will optimistically give x a CPR tag the -- first time, which is wrong in the end.  simonpj committed Sep 07, 2001 128 \end{code}  simonpj committed Jul 17, 2001 129 130 131 132 133 134 135 136  %************************************************************************ %* * \subsection{The analyser itself} %* * %************************************************************************ \begin{code}  simonpj committed Jul 19, 2001 137 dmdAnal :: SigEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr)  simonpj committed Jul 17, 2001 138   simonpj committed Jul 19, 2001 139 dmdAnal sigs Abs e = (topDmdType, e)  simonpj committed Jul 17, 2001 140   simonpj committed Nov 19, 2001 141 142 143 144 145 146 dmdAnal sigs dmd e | not (isStrictDmd dmd) = let (res_ty, e') = dmdAnal sigs evalDmd e in (deferType res_ty, e')  simonpj committed Jul 17, 2001 147 148 149  -- It's important not to analyse e with a lazy demand because -- a) When we encounter case s of (a,b) -> -- we demand s with U(d1d2)... but if the overall demand is lazy  simonpj committed Jul 19, 2001 150 151  -- that is wrong, and we'd need to reduce the demand on s, -- which is inconvenient  simonpj committed Jul 17, 2001 152 153 154 155 156  -- b) More important, consider -- f (let x = R in x+x), where f is lazy -- We still want to mark x as demanded, because it will be when we -- enter the let. If we analyse f's arg with a Lazy demand, we'll -- just mark x as Lazy  simonpj committed Oct 18, 2001 157 158 159  -- c) The application rule wouldn't be right either -- Evaluating (f x) in a L demand does *not* cause -- evaluation of f in a C(L) demand!  simonpj committed Jul 17, 2001 160 161 162  dmdAnal sigs dmd (Lit lit)  simonpj committed Jul 19, 2001 163 164 165 166  = (topDmdType, Lit lit) dmdAnal sigs dmd (Var var) = (dmdTransform sigs var dmd, Var var)  simonpj committed Jul 17, 2001 167   chak@cse.unsw.edu.au. committed Aug 04, 2006 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 dmdAnal sigs dmd (Cast e co) = (dmd_ty, Cast e' co) where (dmd_ty, e') = dmdAnal sigs dmd' e to_co = snd (coercionKind co) dmd' | Just (tc, args) <- splitTyConApp_maybe to_co , isRecursiveTyCon tc = evalDmd | otherwise = dmd -- This coerce usually arises from a recursive -- newtype, and we don't want to look inside them -- for exactly the same reason that we don't look -- inside recursive products -- we might not reach -- a fixpoint. So revert to a vanilla Eval demand  simonpj committed Jul 17, 2001 183 dmdAnal sigs dmd (Note n e)  simonpj committed Jul 19, 2001 184  = (dmd_ty, Note n e')  simonpj committed Jul 17, 2001 185  where  chak@cse.unsw.edu.au. committed Aug 04, 2006 186  (dmd_ty, e') = dmdAnal sigs dmd e  simonpj committed Jul 17, 2001 187 188  dmdAnal sigs dmd (App fun (Type ty))  simonpj committed Jul 19, 2001 189  = (fun_ty, App fun' (Type ty))  simonpj committed Jul 17, 2001 190  where  simonpj committed Jul 19, 2001 191  (fun_ty, fun') = dmdAnal sigs dmd fun  simonpj committed Jul 17, 2001 192   simonpj committed Oct 18, 2001 193 194 -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-)  simonpj committed Oct 18, 2001 195 dmdAnal sigs dmd e@(App fun arg) -- Non-type arguments  simonpj committed Jul 17, 2001 196  = let -- [Type arg handled above]  simonpj committed Jul 19, 2001 197 198 199  (fun_ty, fun') = dmdAnal sigs (Call dmd) fun (arg_ty, arg') = dmdAnal sigs arg_dmd arg (arg_dmd, res_ty) = splitDmdTy fun_ty  simonpj committed Jul 17, 2001 200  in  simonpj committed Jul 19, 2001 201  (res_ty bothType arg_ty, App fun' arg')  simonpj committed Jul 17, 2001 202 203 204 205  dmdAnal sigs dmd (Lam var body) | isTyVar var = let  simonpj committed Jul 19, 2001 206  (body_ty, body') = dmdAnal sigs dmd body  simonpj committed Jul 17, 2001 207  in  simonpj committed Jul 19, 2001 208  (body_ty, Lam var body')  simonpj committed Jul 17, 2001 209   simonpj committed Jul 20, 2001 210 211  | Call body_dmd <- dmd -- A call demand: good! = let  simonpj committed Apr 04, 2002 212 213  sigs' = extendSigsWithLam sigs var (body_ty, body') = dmdAnal sigs' body_dmd body  simonpj committed Jul 20, 2001 214  (lam_ty, var') = annotateLamIdBndr body_ty var  simonpj committed Jul 17, 2001 215  in  simonpj committed Jul 19, 2001 216  (lam_ty, Lam var' body')  simonpj committed Jul 17, 2001 217   simonpj committed Jul 20, 2001 218 219  | otherwise -- Not enough demand on the lambda; but do the body = let -- anyway to annotate it and gather free var info  simonpj committed Nov 19, 2001 220  (body_ty, body') = dmdAnal sigs evalDmd body  simonpj committed Jul 20, 2001 221 222 223 224  (lam_ty, var') = annotateLamIdBndr body_ty var in (deferType lam_ty, Lam var' body')  simonpj committed Sep 30, 2004 225 dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)])  simonpj committed Jul 17, 2001 226 227 228 229  | let tycon = dataConTyCon dc, isProductTyCon tycon, not (isRecursiveTyCon tycon) = let  simonpj committed Oct 24, 2001 230 231 232 233  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'  simonpj committed Apr 04, 2002 234  case_bndr_sig = cprSig  simonpj committed Oct 24, 2001 235 236 237 238 239 240 241 242 243 244  -- 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  simonpj committed Jul 24, 2001 245   simonpj committed Aug 23, 2001 246 247  -- Figure out whether the demand on the case binder is used, and use -- that to set the scrut_dmd. This is utterly essential.  simonpj committed Jul 24, 2001 248 249 250 251 252  -- Consider f x = case x of y { (a,b) -> k y a } -- If we just take scrut_demand = U(L,A), then we won't pass x to the -- worker, so the worker will rebuild -- x = (a, absent-error) -- and that'll crash.  simonpj committed Aug 23, 2001 253 254 255 256 257 258 259 260 261 262 263 264  -- So at one stage I had: -- dead_case_bndr = isAbsentDmd (idNewDemandInfo case_bndr') -- keepity | dead_case_bndr = Drop -- | otherwise = Keep -- -- But then consider -- case x of y { (a,b) -> h y + a } -- where h : U(LL) -> T -- The above code would compute a Keep for x, since y is not Abs, which is silly -- 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  simonpj committed Nov 19, 2001 265  scrut_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b])  simonpj committed Aug 23, 2001 266  both  simonpj committed Oct 24, 2001 267  idNewDemandInfo case_bndr'  simonpj committed Jul 24, 2001 268   simonpj committed Oct 24, 2001 269  (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut  simonpj committed Jul 17, 2001 270  in  simonpj committed Sep 30, 2004 271  (alt_ty1 bothType scrut_ty, Case scrut' case_bndr' ty [alt'])  simonpj committed Jul 17, 2001 272   simonpj committed Sep 30, 2004 273 dmdAnal sigs dmd (Case scrut case_bndr ty alts)  simonpj committed Jul 17, 2001 274  = let  simonpj committed Jul 19, 2001 275  (alt_tys, alts') = mapAndUnzip (dmdAnalAlt sigs dmd) alts  simonpj committed Nov 19, 2001 276  (scrut_ty, scrut') = dmdAnal sigs evalDmd scrut  simonpj committed Jul 19, 2001 277  (alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr  simonpj committed Jul 17, 2001 278  in  simonpj committed Jul 19, 2001 279 -- pprTrace "dmdAnal:Case" (ppr alts$$ ppr alt_tys)  simonpj committed Sep 30, 2004 280  (alt_ty bothType scrut_ty, Case scrut' case_bndr' ty alts')  simonpj committed Jul 17, 2001 281 282 283  dmdAnal sigs dmd (Let (NonRec id rhs) body) = let  simonpj committed Apr 05, 2002 284  (sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs NotTopLevel NonRecursive sigs (id, rhs)  simonpj committed Jul 20, 2001 285 286 287  (body_ty, body') = dmdAnal sigs' dmd body (body_ty1, id2) = annotateBndr body_ty id1 body_ty2 = addLazyFVs body_ty1 lazy_fv  simonpj committed Jul 17, 2001 288  in  simonpj committed Sep 10, 2002 289 290 291 292 293 294 295 296 297 298 299 300  -- If the actual demand is better than the vanilla call -- demand, you might think that we might do better to re-analyse -- the RHS with the stronger demand. -- But (a) That seldom happens, because it means that *every* path in -- the body of the let has to use that stronger demand -- (b) It often happens temporarily in when fixpointing, because -- the recursive function at first seems to place a massive demand. -- But we don't want to go to extra work when the function will -- probably iterate to something less demanding. -- In practice, all the times the actual demand on id2 is more than -- the vanilla call demand seem to be due to (b). So we don't -- bother to re-analyse the RHS.  simonpj committed Jul 20, 2001 301  (body_ty2, Let (NonRec id2 rhs') body')  simonpj committed Jul 17, 2001 302 303 304  dmdAnal sigs dmd (Let (Rec pairs) body) = let  simonpj committed Jul 20, 2001 305 306 307 308 309 310 311 312  bndrs = map fst pairs (sigs', lazy_fv, pairs') = dmdFix NotTopLevel sigs pairs (body_ty, body') = dmdAnal sigs' dmd body body_ty1 = addLazyFVs body_ty lazy_fv in sigs' seq body_ty seq let (body_ty2, _) = annotateBndrs body_ty1 bndrs  simonpj committed Jul 17, 2001 313 314 315 316 317  -- Don't bother to add demand info to recursive -- binders as annotateBndr does; -- being recursive, we can't treat them strictly. -- But we do need to remove the binders from the result demand env in  simonpj committed Jul 20, 2001 318  (body_ty2, Let (Rec pairs') body')  simonpj committed Jul 19, 2001 319   simonpj committed Jul 17, 2001 320 321 322  dmdAnalAlt sigs dmd (con,bndrs,rhs) = let  simonpj committed Jul 19, 2001 323 324  (rhs_ty, rhs') = dmdAnal sigs dmd rhs (alt_ty, bndrs') = annotateBndrs rhs_ty bndrs  simonpj committed Jun 23, 2003 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345  final_alt_ty | io_hack_reqd = alt_ty lubType topDmdType | otherwise = alt_ty -- There's a hack here for I/O operations. Consider -- case foo x s of { (# s, r #) -> y } -- Is this strict in 'y'. Normally yes, but what if 'foo' is an I/O -- operation that simply terminates the program (not in an erroneous way)? -- In that case we should not evaluate y before the call to 'foo'. -- Hackish solution: spot the IO-like situation and add a virtual branch, -- as if we had -- case foo x s of -- (# s, r #) -> y -- other -> return () -- So the 'y' isn't necessarily going to be evaluated -- -- A more complete example where this shows up is: -- do { let len = ; -- ; when (...) (exitWith ExitSuccess) -- ; print len } io_hack_reqd = con == DataAlt unboxedPairDataCon &&  simonpj committed Dec 20, 2004 346  idType (head bndrs) coreEqType realWorldStatePrimTy  simonpj committed Jun 23, 2003 347 348  in (final_alt_ty, (con, bndrs', rhs'))  simonpj committed Jul 17, 2001 349 350 351 352 353 354 355 356 357 \end{code} %************************************************************************ %* * \subsection{Bindings} %* * %************************************************************************ \begin{code}  simonpj committed Jul 19, 2001 358 359 dmdFix :: TopLevelFlag -> SigEnv -- Does not include bindings for this binding  simonpj committed Jul 17, 2001 360  -> [(Id,CoreExpr)]  simonpj committed Jul 20, 2001 361  -> (SigEnv, DmdEnv,  simonpj committed Jul 17, 2001 362 363  [(Id,CoreExpr)]) -- Binders annotated with stricness info  simonpj committed Sep 07, 2001 364 365 dmdFix top_lvl sigs orig_pairs = loop 1 initial_sigs orig_pairs  simonpj committed Jul 17, 2001 366  where  simonpj committed Sep 07, 2001 367  bndrs = map fst orig_pairs  simonpj committed Apr 04, 2002 368  initial_sigs = extendSigEnvList sigs [(id, (initialSig id, top_lvl)) | id <- bndrs]  simonpj committed Jul 19, 2001 369 370 371 372  loop :: Int -> SigEnv -- Already contains the current sigs -> [(Id,CoreExpr)]  simonpj committed Jul 20, 2001 373  -> (SigEnv, DmdEnv, [(Id,CoreExpr)])  simonpj committed Jul 19, 2001 374  loop n sigs pairs  simonpj committed Sep 02, 2002 375  | found_fixpoint  simonpj committed Sep 07, 2001 376  = (sigs', lazy_fv, pairs')  simonpj committed Jul 20, 2001 377 378 379 380  -- Note: use pairs', not pairs. pairs' is the result of -- processing the RHSs with sigs (= sigs'), whereas pairs -- is the result of processing the RHSs with the *previous* -- iteration of sigs.  simonpj committed Sep 02, 2002 381 382  | n >= 10 = pprTrace "dmdFix loop" (ppr n <+> (vcat  simonpj committed Jul 25, 2001 383 384  [ text "Sigs:" <+> ppr [(id,lookup sigs id, lookup sigs' id) | (id,_) <- pairs], text "env:" <+> ppr (ufmToList sigs),  simonpj committed Sep 07, 2001 385  text "binds:" <+> pprCoreBinding (Rec pairs)]))  simonpj committed Sep 02, 2002 386 387 388 389 390 391 392  (emptySigEnv, lazy_fv, orig_pairs) -- Safe output -- The lazy_fv part is really important! orig_pairs has no strictness -- info, including nothing about free vars. But if we have -- letrec f = ....y..... in ...f... -- where 'y' is free in f, we must record that y is mentioned, -- otherwise y will get recorded as absent altogether  simonpj committed Sep 07, 2001 393  | otherwise = loop (n+1) sigs' pairs'  simonpj committed Jul 17, 2001 394  where  simonpj committed Sep 02, 2002 395  found_fixpoint = all (same_sig sigs sigs') bndrs  simonpj committed Jul 19, 2001 396 397 398  -- Use the new signature to do the next pair -- The occurrence analyser has arranged them in a good order -- so this can significantly reduce the number of iterations needed  simonpj committed Jul 20, 2001 399 400 401 402 403 404 405 406 407  ((sigs',lazy_fv), pairs') = mapAccumL (my_downRhs top_lvl) (sigs, emptyDmdEnv) pairs my_downRhs top_lvl (sigs,lazy_fv) (id,rhs) = -- pprTrace "downRhs {" (ppr id <+> (ppr old_sig)) -- (new_sig seq -- pprTrace "downRhsEnd" (ppr id <+> ppr new_sig <+> char '}' ) ((sigs', lazy_fv'), pair') -- ) where  simonpj committed Apr 05, 2002 408  (sigs', lazy_fv1, pair') = dmdAnalRhs top_lvl Recursive sigs (id,rhs)  simonpj committed Jul 20, 2001 409  lazy_fv' = plusUFM_C both lazy_fv lazy_fv1  simonmar committed Aug 31, 2001 410 411  -- old_sig = lookup sigs id -- new_sig = lookup sigs' id  simonpj committed Jul 17, 2001 412   simonpj committed Apr 04, 2002 413 414 415 416  same_sig sigs sigs' var = lookup sigs var == lookup sigs' var lookup sigs var = case lookupVarEnv sigs var of Just (sig,_) -> sig  simonpj committed Jul 17, 2001 417 418 419  -- Get an initial strictness signature from the Id -- itself. That way we make use of earlier iterations -- of the fixpoint algorithm. (Cunning plan.)  simonpj committed Jul 19, 2001 420 421  -- Note that the cunning plan extends to the DmdEnv too, -- since it is part of the strictness signature  simonpj committed Apr 04, 2002 422 initialSig id = idNewStrictness_maybe id orElse botSig  simonpj committed Jul 17, 2001 423   simonpj committed Apr 05, 2002 424 dmdAnalRhs :: TopLevelFlag -> RecFlag  simonpj committed Jul 19, 2001 425  -> SigEnv -> (Id, CoreExpr)  simonpj committed Jul 20, 2001 426 427 428  -> (SigEnv, DmdEnv, (Id, CoreExpr)) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well.  simonpj committed Jul 17, 2001 429   simonpj committed Apr 05, 2002 430 dmdAnalRhs top_lvl rec_flag sigs (id, rhs)  simonpj committed Jul 20, 2001 431  = (sigs', lazy_fv, (id', rhs'))  simonpj committed Jul 17, 2001 432  where  simonpj committed Oct 24, 2001 433 434 435  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  simonpj committed Oct 29, 2003 436 437 438  (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id ) -- The RHS can be eta-reduced to just a variable, -- in which case we should not complain.  simonpj committed Apr 05, 2002 439  mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty  simonpj committed Oct 24, 2001 440 441  id' = id setIdNewStrictness sig_ty sigs' = extendSigEnv top_lvl sigs id sig_ty  simonpj committed Jul 23, 2001 442 \end{code}  simonpj committed Jul 20, 2001 443   simonpj committed Jul 23, 2001 444 445 446 447 448 449 450 %************************************************************************ %* * \subsection{Strictness signatures and types} %* * %************************************************************************ \begin{code}  simonpj committed Oct 24, 2001 451 452 453 454 455 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)  simonpj committed Apr 05, 2002 456 457 mkSigTy :: TopLevelFlag -> RecFlag -> Id -> CoreExpr -> DmdType -> (DmdEnv, StrictSig) mkSigTy top_lvl rec_flag id rhs dmd_ty  simonpj committed Apr 05, 2002 458  = mk_sig_ty never_inline thunk_cpr_ok rhs dmd_ty  simonpj committed Apr 04, 2002 459  where  simonpj committed Apr 05, 2002 460 461 462 463 464 465 466  never_inline = isNeverActive (idInlinePragma id) maybe_id_dmd = idNewDemandInfo_maybe id -- Is Nothing the first time round thunk_cpr_ok | isTopLevel top_lvl = False -- Top level things don't get -- their demandInfo set at all  simonpj committed Apr 05, 2002 467  | isRec rec_flag = False -- Ditto recursive things  simonpj committed Apr 05, 2002 468 469 470  | Just dmd <- maybe_id_dmd = isStrictDmd dmd | otherwise = True -- Optimistic, first time round -- See notes below  simonpj committed Apr 04, 2002 471 472 \end{code}  simonpj committed Apr 05, 2002 473 The thunk_cpr_ok stuff [CPR-AND-STRICTNESS]  simonpj committed Apr 04, 2002 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the rhs is a thunk, we usually 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. However, if the strictness analyser has figured out (in a previous iteration) that it's strict, then we DON'T need to forget the CPR info. Instead we can retain the CPR info and do the thunk-splitting transform (see WorkWrap.splitThunk). 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; but it does matter that k's RHS has the CPR property.) 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) With thunk-splitting, we get instead let$j x = let k = I#x in ...body strict in k... in if ... then $j a else$j b This is much better; there's a good chance the I# won't get allocated. 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.  simonpj committed Apr 05, 2002 514 The Nothing case in thunk_cpr_ok [CPR-AND-STRICTNESS]  simonpj committed Apr 04, 2002 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Demand info now has a 'Nothing' state, just like strictness info. The analysis works from 'dangerous' towards a 'safe' state; so we start with botSig for 'Nothing' strictness infos, and we start with "yes, it's demanded" for 'Nothing' in the demand info. The fixpoint iteration will sort it all out. We can't start with 'not-demanded' because then consider f x = let t = ... I# x in if ... then t else I# y else f x' In the first iteration we'd have no demand info for x, so assume not-demanded; then we'd get TopRes for f's CPR info. Next iteration  simonpj committed Nov 19, 2002 530 531 532 533 we'd see that t was demanded, and so give it the CPR property, but by now f has TopRes, so it will stay TopRes. Instead, with the Nothing setting the first time round, we say 'yes t is demanded' the first time.  simonpj committed Apr 04, 2002 534 535 536 537 538 539  However, this does mean that for non-recursive bindings we must iterate twice to be sure of not getting over-optimistic CPR info, in the case where t turns out to be not-demanded. This is handled by dmdAnalTopBind.  simonpj committed Oct 24, 2001 540   simonpj committed Apr 04, 2002 541 \begin{code}  simonpj committed Apr 05, 2002 542 mk_sig_ty never_inline thunk_cpr_ok rhs (DmdType fv dmds res)  simonpj committed Sep 07, 2001 543  = (lazy_fv, mkStrictSig dmd_ty)  simonpj committed Jul 20, 2001 544  where  simonpj committed Aug 23, 2001 545  dmd_ty = DmdType strict_fv final_dmds res'  simonpj committed Jul 23, 2001 546   simonpj committed Jul 20, 2001 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578  lazy_fv = filterUFM (not . isStrictDmd) fv strict_fv = filterUFM isStrictDmd fv -- We put the strict FVs in the DmdType of the Id, so -- that at its call sites we unleash demands on its strict fvs. -- An example is 'roll' in imaginary/wheel-sieve2 -- Something like this: -- roll x = letrec -- go y = if ... then roll (x-1) else x+1 -- in -- go ms -- We want to see that roll is strict in x, which is because -- go is called. So we put the DmdEnv for x in go's DmdType. -- -- Another example: -- f :: Int -> Int -> Int -- f x y = let t = x+1 -- h z = if z==0 then t else -- if z==1 then x+1 else -- x + h (z-1) -- in -- h y -- Calling h does indeed evaluate x, but we can only see -- that if we unleash a demand on x at the call site for t. -- -- Incidentally, here's a place where lambda-lifting h would -- lose the cigar --- we couldn't see the joint strictness in t/x -- -- ON THE OTHER HAND -- We don't want to put *all* the fv's from the RHS into the -- DmdType, because that makes fixpointing very slow --- the -- DmdType gets full of lazy demands that are slow to converge.  simonpj committed Oct 24, 2001 579  final_dmds = setUnpackStrategy dmds  simonpj committed Jul 23, 2001 580 581  -- Set the unpacking strategy  simonpj committed Sep 07, 2001 582  res' = case res of  simonpj committed Oct 24, 2001 583 584  RetCPR | ignore_cpr_info -> TopRes other -> res  simonpj committed Aug 10, 2005 585  ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok)  simonpj committed Jul 17, 2001 586 587 \end{code}  simonpj committed Jul 23, 2001 588 589 590 591 592 593 594 595 596 597 598 599 600 The unpack strategy determines whether we'll *really* unpack the argument, or whether we'll just remember its strictness. If unpacking would give rise to a *lot* of worker args, we may decide not to unpack after all. \begin{code} setUnpackStrategy :: [Demand] -> [Demand] setUnpackStrategy ds = snd (go (opt_MaxWorkerArgs - nonAbsentArgs ds) ds) where go :: Int -- Max number of args available for sub-components of [Demand] -> [Demand] -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked  simonpj committed Nov 19, 2001 601 602 603  go n (Eval (Prod cs) : ds) | n' >= 0 = Eval (Prod cs') cons go n'' ds | otherwise = Box (Eval (Prod cs)) cons go n ds  simonpj committed Jul 23, 2001 604 605  where (n'',cs') = go n' cs  simonpj committed Nov 19, 2001 606 607  n' = n + 1 - non_abs_args -- Add one to the budget 'cos we drop the top-level arg  simonpj committed Jul 23, 2001 608 609 610 611 612 613 614 615 616 617 618 619 620 621  non_abs_args = nonAbsentArgs cs -- Delete # of non-absent args to which we'll now be committed go n (d:ds) = d cons go n ds go n [] = (n,[]) cons d (n,ds) = (n, d:ds) nonAbsentArgs :: [Demand] -> Int nonAbsentArgs [] = 0 nonAbsentArgs (Abs : ds) = nonAbsentArgs ds nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds \end{code}  simonpj committed Jul 17, 2001 622 623 624 625 626 627 628  %************************************************************************ %* * \subsection{Strictness signatures and types} %* * %************************************************************************  simonpj committed Jul 23, 2001 629 630 631 \begin{code} splitDmdTy :: DmdType -> (Demand, DmdType) -- Split off one function argument  simonpj committed Oct 18, 2001 632 633 -- We already have a suitable demand on all -- free vars, so no need to add more!  simonpj committed Jul 23, 2001 634 splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)  simonpj committed Nov 19, 2001 635 splitDmdTy ty@(DmdType fv [] res_ty) = (resTypeArgDmd res_ty, ty)  simonpj committed Jul 23, 2001 636 637 \end{code}  simonpj committed Jul 17, 2001 638 \begin{code}  simonpj committed Jul 19, 2001 639 unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes  simonpj committed Jul 17, 2001 640   simonpj committed Jul 19, 2001 641 642 643 addVarDmd top_lvl dmd_ty@(DmdType fv ds res) var dmd | isTopLevel top_lvl = dmd_ty -- Don't record top level things | otherwise = DmdType (extendVarEnv fv var dmd) ds res  simonpj committed Jul 17, 2001 644   simonpj committed Jul 20, 2001 645 addLazyFVs (DmdType fv ds res) lazy_fvs  simonpj committed Sep 07, 2001 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674  = DmdType both_fv1 ds res where both_fv = (plusUFM_C both fv lazy_fvs) both_fv1 = modifyEnv (isBotRes res) (both Bot) lazy_fvs fv both_fv -- This modifyEnv is vital. Consider -- let f = \x -> (x,y) -- in error (f 3) -- Here, y is treated as a lazy-fv of f, but we must both that L -- demand with the bottom coming up from 'error' -- -- I got a loop in the fixpointer without this, due to an interaction -- with the lazy_fv filtering in mkSigTy. Roughly, it was -- letrec f n x -- = letrec g y = x fatbar -- letrec h z = z + ...g... -- in h (f (n-1) x) -- in ... -- In the initial iteration for f, f=Bot -- Suppose h is found to be strict in z, but the occurrence of g in its RHS -- is lazy. Now consider the fixpoint iteration for g, esp the demands it -- places on its free variables. Suppose it places none. Then the -- x fatbar ...call to h... -- will give a x->V demand for x. That turns into a L demand for x, -- which floats out of the defn for h. Without the modifyEnv, that -- L demand doesn't get both'd with the Bot coming up from the inner -- call to f. So we just get an L demand for x for g. -- -- A better way to say this is that the lazy-fv filtering should give the -- same answer as putting the lazy fv demands in the function's type.  simonpj committed Jul 20, 2001 675   simonpj committed Jul 19, 2001 676 annotateBndr :: DmdType -> Var -> (DmdType, Var)  simonpj committed Jul 17, 2001 677 678 -- The returned env has the var deleted -- The returned var is annotated with demand info  simonpj committed Jul 19, 2001 679 680 681 -- No effect on the argument demands annotateBndr dmd_ty@(DmdType fv ds res) var | isTyVar var = (dmd_ty, var)  simonpj committed Nov 19, 2001 682  | otherwise = (DmdType fv' ds res, setIdNewDemandInfo var dmd)  simonpj committed Jul 19, 2001 683 684  where (fv', dmd) = removeFV fv var res  simonpj committed Jul 17, 2001 685 686 687  annotateBndrs = mapAccumR annotateBndr  simonpj committed Jul 19, 2001 688 689 690 691 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 )  simonpj committed Aug 24, 2001 692  (DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd)  simonpj committed Jul 17, 2001 693  where  simonpj committed Jul 19, 2001 694  (fv', dmd) = removeFV fv id res  simonpj committed Nov 19, 2001 695  hacked_dmd = argDemand dmd  simonpj committed Oct 24, 2001 696  -- This call to argDemand is vital, because otherwise we label  simonpj committed Aug 24, 2001 697 698 699 700 701 702  -- 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 -- fw x = (\x y:B -> ...) x (error "oops") -- And then the simplifier things the 'B' is a strict demand -- and evaluates the (error "oops"). Sigh  simonpj committed Jul 19, 2001 703   simonpj committed Nov 19, 2001 704 removeFV fv id res = (fv', zapUnlifted id dmd)  simonpj committed Jul 19, 2001 705  where  simonpj committed Nov 19, 2001 706 707  fv' = fv delVarEnv id dmd = lookupVarEnv fv id orElse deflt  simonpj committed Jul 19, 2001 708 709  deflt | isBotRes res = Bot | otherwise = Abs  simonpj committed Nov 19, 2001 710 711 712 713 714 715 716  -- For unlifted-type variables, we are only -- interested in Bot/Abs/Box Abs zapUnlifted is Bot = Bot zapUnlifted id Abs = Abs zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd | otherwise = dmd  simonpj committed Jul 17, 2001 717 718 719 720 721 722 723 724 725 \end{code} %************************************************************************ %* * \subsection{Strictness signatures} %* * %************************************************************************ \begin{code}  simonpj committed Jul 19, 2001 726 727 728 729 730 731 732 733 type SigEnv = VarEnv (StrictSig, TopLevelFlag) -- We use the SigEnv to tell us whether to -- record info about a variable in the DmdEnv -- We do so if it's a LocalId, but not top-level -- -- The DmdEnv gives the demand on the free vars of the function -- when it is given enough args to satisfy the strictness signature  simonpj committed Jul 17, 2001 734 emptySigEnv = emptyVarEnv  simonpj committed Jul 19, 2001 735 736 737 738  extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv extendSigEnv top_lvl env var sig = extendVarEnv env var (sig, top_lvl)  simonpj committed Jul 17, 2001 739 740 extendSigEnvList = extendVarEnvList  simonpj committed Apr 04, 2002 741 742 extendSigsWithLam :: SigEnv -> Id -> SigEnv -- Extend the SigEnv when we meet a lambda binder  simonpj committed Nov 19, 2002 743 -- If the binder is marked demanded with a product demand, then give it a CPR  simonpj committed Apr 05, 2002 744 745 -- signature, because in the likely event that this is a lambda on a fn defn -- [we only use this when the lambda is being consumed with a call demand],  simonpj committed Nov 19, 2002 746 747 748 749 750 751 -- it'll be w/w'd and so it will be CPR-ish. E.g. -- f = \x::(Int,Int). if ...strict in x... then -- x -- else -- (a,b) -- We want f to have the CPR property because x does, by the time f has been w/w'd  simonpj committed Apr 05, 2002 752 753 754 755 756 -- -- Also note that we only want to do this for something that -- definitely has product type, else we may get over-optimistic -- CPR results (e.g. from \x -> x!).  simonpj committed Apr 04, 2002 757 758 extendSigsWithLam sigs id = case idNewDemandInfo_maybe id of  simonpj committed Apr 05, 2002 759  Nothing -> extendVarEnv sigs id (cprSig, NotTopLevel)  simonpj@microsoft.com committed Jan 31, 2006 760 761  -- Optimistic in the Nothing case; -- See notes [CPR-AND-STRICTNESS]  simonpj committed Apr 05, 2002 762 763  Just (Eval (Prod ds)) -> extendVarEnv sigs id (cprSig, NotTopLevel) other -> sigs  simonpj committed Apr 04, 2002 764 765   simonpj committed Jul 17, 2001 766 767 768 769 dmdTransform :: SigEnv -- The strictness environment -> Id -- The function -> Demand -- The demand on the function -> DmdType -- The demand type of the function in this context  simonpj committed Jul 19, 2001 770 771  -- Returned DmdEnv includes the demand on -- this function plus demand on its free variables  simonpj committed Jul 17, 2001 772 773 774  dmdTransform sigs var dmd  simonpj committed Jul 19, 2001 775 ------ DATA CONSTRUCTOR  simonpj committed Feb 12, 2003 776  | isDataConWorkId var -- Data constructor  simonpj committed Oct 18, 2001 777 778 779 780 781 782  = 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  simonpj committed Aug 22, 2001 783 784  let -- Important! If we Keep the constructor application, then  simonpj committed Oct 18, 2001 785  -- we need the demands the constructor places (always lazy)  simonpj committed Aug 22, 2001 786 787 788 789  -- If not, we don't need to. For example: -- f p@(x,y) = (p,y) -- S(AL) -- g a b = f (a,b) -- It's vital that we don't calculate Absent for a!  simonpj committed Nov 19, 2001 790 791 792 793 794 795 796 797 798 799 800  dmd_ds = case res_dmd of Box (Eval ds) -> mapDmds box ds Eval ds -> ds other -> Poly Top -- ds can be empty, when we are just seq'ing the thing -- If so we must make up a suitable bunch of demands arg_ds = case dmd_ds of Poly d -> replicate arity d Prod ds -> ASSERT( ds lengthIs arity ) ds  simonpj committed Aug 22, 2001 801 802 803  in mkDmdType emptyDmdEnv arg_ds con_res -- Must remember whether it's a product, hence con_res, not TopRes  simonpj committed Jul 19, 2001 804 805 806 807 808  else topDmdType ------ IMPORTED FUNCTION | isGlobalId var, -- Imported function  simonpj committed Nov 19, 2001 809  let StrictSig dmd_ty = idNewStrictness var  simonpj committed Jul 23, 2001 810  = if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand  simonpj committed Jul 19, 2001 811 812 813 814 815  dmd_ty else topDmdType ------ LOCAL LET/REC BOUND THING  simonpj committed Jul 23, 2001 816  | Just (StrictSig dmd_ty, top_lvl) <- lookupVarEnv sigs var  simonpj committed Jul 19, 2001 817  = let  simonpj committed Jul 23, 2001 818 819  fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty | otherwise = deferType dmd_ty  simonpj committed Jul 20, 2001 820 821 822 823  -- NB: it's important to use deferType, and not just return topDmdType -- Consider let { f x y = p + x } in f 1 -- The application isn't saturated, but we must nevertheless propagate -- a lazy demand for p!  simonpj committed Jul 19, 2001 824 825  in addVarDmd top_lvl fn_ty var dmd  simonpj committed Jul 17, 2001 826   simonpj committed Jul 19, 2001 827 ------ LOCAL NON-LET/REC BOUND THING  simonpj committed Jul 17, 2001 828  | otherwise -- Default case  simonpj committed Jul 19, 2001 829  = unitVarDmd var dmd  simonpj committed Jul 17, 2001 830 831  where  simonpj committed Jul 23, 2001 832  (call_depth, res_dmd) = splitCallDmd dmd  simonpj committed Jul 17, 2001 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 \end{code} %************************************************************************ %* * \subsection{Demands} %* * %************************************************************************ \begin{code} splitCallDmd :: Demand -> (Int, Demand) splitCallDmd (Call d) = case splitCallDmd d of (n, r) -> (n+1, r) splitCallDmd d = (0, d) vanillaCall :: Arity -> Demand  simonpj committed Nov 19, 2001 849 vanillaCall 0 = evalDmd  simonpj committed Jul 17, 2001 850 851 vanillaCall n = Call (vanillaCall (n-1))  simonpj committed Jul 19, 2001 852 deferType :: DmdType -> DmdType  simonpj committed Oct 24, 2001 853 deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] TopRes  simonpj committed Jul 20, 2001 854 855 856  -- 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.  simonpj committed Oct 18, 2001 857  -- Peter??  simonpj committed Jul 19, 2001 858   simonpj committed Oct 24, 2001 859 860 861 deferEnv :: DmdEnv -> DmdEnv deferEnv fv = mapVarEnv defer fv  simonpj committed Oct 24, 2001 862 863  ----------------  simonpj committed Nov 19, 2001 864 argDemand :: Demand -> Demand  simonpj committed Jul 19, 2001 865 -- The 'Defer' demands are just Lazy at function boundaries  simonpj committed Aug 24, 2001 866 -- Ugly! Ask John how to improve it.  simonpj committed Nov 19, 2001 867 868 869 870 871 argDemand Top = lazyDmd argDemand (Defer d) = lazyDmd argDemand (Eval ds) = Eval (mapDmds argDemand ds) argDemand (Box Bot) = evalDmd argDemand (Box d) = box (argDemand d)  simonpj committed Sep 13, 2002 872 argDemand Bot = Abs -- Don't pass args that are consumed (only) by bottom  simonpj committed Nov 19, 2001 873 argDemand d = d  simonpj committed Jul 23, 2001 874 875 \end{code}  simonpj committed Jul 19, 2001 876 877 878 879 \begin{code} ------------------------- -- Consider (if x then y else []) with demand V -- Then the first branch gives {y->V} and the second  simonmar committed Mar 31, 2005 880 -- *implicitly* has {y->A}. So we must put {y->(V lub A)}  simonpj committed Jul 19, 2001 881 882 -- in the result env. lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)  simonpj committed Nov 19, 2001 883  = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 lubRes r2)  simonpj committed Jul 19, 2001 884 885  where lub_fv = plusUFM_C lub fv1 fv2  simonpj committed Nov 19, 2001 886 887  lub_fv1 = modifyEnv (not (isBotRes r1)) absLub fv2 fv1 lub_fv lub_fv2 = modifyEnv (not (isBotRes r2)) absLub fv1 fv2 lub_fv1  simonpj committed Jul 19, 2001 888 889  -- lub is the identity for Bot  simonpj committed Nov 19, 2001 890 891 892 893 894 895  -- Extend the shorter argument list to match the longer lub_ds (d1:ds1) (d2:ds2) = lub d1 d2 : lub_ds ds1 ds2 lub_ds [] [] = [] lub_ds ds1 [] = map (lub resTypeArgDmd r2) ds1 lub_ds [] ds2 = map (resTypeArgDmd r1 lub) ds2  simonpj committed Sep 07, 2001 896 897 898 ----------------------------------- -- (t1 bothType t2) takes the argument/result info from t1, -- using t2 just for its free-var info  simonpj committed Oct 18, 2001 899 900 901 -- NB: Don't forget about r2! It might be BotRes, which is -- a bottom demand on all the in-scope variables. -- Peter: can this be done more neatly?  simonpj committed Sep 07, 2001 902 903 904 905 906 907 908 909 910 911 912 bothType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2) = DmdType both_fv2 ds1 (r1 bothRes r2) where both_fv = plusUFM_C both fv1 fv2 both_fv1 = modifyEnv (isBotRes r1) (both Bot) fv2 fv1 both_fv both_fv2 = modifyEnv (isBotRes r2) (both Bot) fv1 fv2 both_fv1 -- both is the identity for Abs \end{code} \begin{code}  simonpj committed Jul 19, 2001 913 914 915 916 lubRes BotRes r = r lubRes r BotRes = r lubRes RetCPR RetCPR = RetCPR lubRes r1 r2 = TopRes  simonpj committed Jul 17, 2001 917   simonpj committed Sep 07, 2001 918 919 -- If either diverges, the whole thing does -- Otherwise take CPR info from the first  simonpj committed Oct 18, 2001 920 921 bothRes r1 BotRes = BotRes bothRes r1 r2 = r1  simonpj committed Sep 07, 2001 922 \end{code}  simonpj committed Jul 17, 2001 923   simonpj committed Jul 19, 2001 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 \begin{code} modifyEnv :: Bool -- No-op if False -> (Demand -> Demand) -- The zapper -> DmdEnv -> DmdEnv -- Env1 and Env2 -> DmdEnv -> DmdEnv -- Transform this env -- Zap anything in Env1 but not in Env2 -- Assume: dom(env) includes dom(Env1) and dom(Env2) modifyEnv need_to_modify zapper env1 env2 env | need_to_modify = foldr zap env (keysUFM (env1 minusUFM env2)) | otherwise = env where zap uniq env = addToUFM_Directly env uniq (zapper current_val) where current_val = expectJust "modifyEnv" (lookupUFM_Directly env uniq)  simonpj committed Jul 17, 2001 939 940 941 \end{code}  simonpj committed Sep 07, 2001 942 943 944 945 946 947 948 949 950 %************************************************************************ %* * \subsection{LUB and BOTH} %* * %************************************************************************ \begin{code} lub :: Demand -> Demand -> Demand  simonpj committed Nov 19, 2001 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 lub Bot d2 = d2 lub Abs d2 = absLub d2 lub Top d2 = Top lub (Defer ds1) d2 = defer (Eval ds1 lub d2) lub (Call d1) (Call d2) = Call (d1 lub d2) lub d1@(Call _) (Box d2) = d1 lub d2 -- Just strip the box lub d1@(Call _) d2@(Eval _) = d2 -- Presumably seq or vanilla eval lub d1@(Call _) d2 = d2 lub d1 -- Bot, Abs, Top -- For the Eval case, we use these approximation rules -- Box Bot <= Eval (Box Bot ...) -- Box Top <= Defer (Box Bot ...) -- Box (Eval ds) <= Eval (map Box ds) lub (Eval ds1) (Eval ds2) = Eval (ds1 lubs ds2) lub (Eval ds1) (Box Bot) = Eval (mapDmds (lub Box Bot) ds1) lub (Eval ds1) (Box (Eval ds2)) = Eval (ds1 lubs mapDmds box ds2) lub (Eval ds1) (Box Abs) = deferEval (mapDmds (lub Box Bot) ds1) lub d1@(Eval _) d2 = d2 lub d1 -- Bot,Abs,Top,Call,Defer lub (Box d1) (Box d2) = box (d1 lub d2) lub d1@(Box _) d2 = d2 lub d1 lubs = zipWithDmds lub --------------------- -- box is the smart constructor for Box -- It computes & d -- INVARIANT: (Box d) => d = Bot, Abs, Eval -- Seems to be no point in allowing (Box (Call d)) box (Call d) = Call d -- The odd man out. Why? box (Box d) = Box d box (Defer _) = lazyDmd  simonpj committed Dec 14, 2001 984 box Top = lazyDmd -- Box Abs and Box Top  simonpj committed Nov 19, 2001 985 986 box Abs = lazyDmd -- are the same box d = Box d -- Bot, Eval  simonpj committed Oct 25, 2001 987   simonpj committed Nov 19, 2001 988 ---------------  simonpj committed Oct 25, 2001 989 defer :: Demand -> Demand  simonpj committed Nov 19, 2001 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013  -- defer is the smart constructor for Defer -- The idea is that (Defer ds) = -- -- It specifies what happens at a lazy function argument -- or a lambda; the L* operator -- Set the strictness part to L, but leave -- the boxity side unaffected -- It also ensures that Defer (Eval [LLLL]) = L defer Bot = Abs defer Abs = Abs defer Top = Top defer (Call _) = lazyDmd -- Approximation here? defer (Box _) = lazyDmd defer (Defer ds) = Defer ds defer (Eval ds) = deferEval ds -- deferEval ds = defer (Eval ds) deferEval ds | allTop ds = Top | otherwise = Defer ds --------------------- absLub :: Demand -> Demand  simonpj committed Oct 25, 2001 1014 1015 1016 1017 1018 -- Computes (Abs lub d) -- For the Bot case consider -- f x y = if ... then x else error x -- Then for y we get Abs lub Bot, and we really -- want Abs overall  simonpj committed Nov 19, 2001 1019 1020 1021 1022 1023 1024 1025 1026 1027 absLub Bot = Abs absLub Abs = Abs absLub Top = Top absLub (Call _) = Top absLub (Box _) = Top absLub (Eval ds) = Defer (absLubs ds) -- Or (Defer ds)? absLub (Defer ds) = Defer (absLubs ds) -- Or (Defer ds)? absLubs = mapDmds absLub  simonpj committed Oct 25, 2001 1028   simonpj committed Sep 07, 2001 1029 1030 1031 --------------- both :: Demand -> Demand -> Demand  simonpj committed Nov 19, 2001 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 both Abs d2 = d2 both Bot Bot = Bot both Bot Abs = Bot both Bot (Eval ds) = Eval (mapDmds (both Bot) ds) -- Consider -- f x = error x -- From 'error' itself we get demand Bot on x -- From the arg demand on x we get -- x :-> evalDmd = Box (Eval (Poly Abs)) -- So we get Bot both Box (Eval (Poly Abs)) -- = Seq Keep (Poly Bot) -- -- Consider also -- f x = if ... then error (fst x) else fst x -- Then we get (Eval (Box Bot, Bot) lub Eval (SA)) -- = Eval (SA) -- which is what we want. both Bot d = errDmd both Top Bot = errDmd both Top Abs = Top both Top Top = Top both Top (Box d) = Box d both Top (Call d) = Call d both Top (Eval ds) = Eval (mapDmds (both Top) ds) both Top (Defer ds) -- = defer (Top both Eval ds) -- = defer (Eval (mapDmds (both Top) ds)) = deferEval (mapDmds (both Top) ds) both (Box d1) (Box d2) = box (d1 both d2) both (Box d1) d2@(Call _) = box (d1 both d2) both (Box d1) d2@(Eval _) = box (d1 both d2) both (Box d1) (Defer d2) = Box d1 both d1@(Box _) d2 = d2 both d1 both (Call d1) (Call d2) = Call (d1 both d2) both (Call d1) (Eval ds2) = Call d1 -- Could do better for (Poly Bot)? both (Call d1) (Defer ds2) = Call d1 -- Ditto both d1@(Call _) d2 = d1 both d1 both (Eval ds1) (Eval ds2) = Eval (ds1 boths ds2) both (Eval ds1) (Defer ds2) = Eval (ds1 boths mapDmds defer ds2) both d1@(Eval ds1) d2 = d2 both d1 both (Defer ds1) (Defer ds2) = deferEval (ds1 boths ds2) both d1@(Defer ds1) d2 = d2 both d1 boths = zipWithDmds both  simonpj committed Sep 07, 2001 1082 1083 1084 \end{code}  simonpj committed Nov 19, 2001 1085   simonpj committed Jul 17, 2001 1086 1087 1088 1089 1090 1091 1092 1093 %************************************************************************ %* * \subsection{Miscellaneous %* * %************************************************************************ \begin{code}  simonmar committed Mar 15, 2002 1094 #ifdef OLD_STRICTNESS  simonpj committed Jul 17, 2001 1095 1096 1097 1098 1099 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)  simonpj committed Jul 20, 2001 1100 get_changes_pr (id,rhs)  simonpj committed Oct 18, 2001 1101  = get_changes_var id $$get_changes_expr rhs  simonpj committed Jul 17, 2001 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111  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  simonpj committed Jul 19, 2001 1112 get_changes_expr (Lam b e) = {- get_changes_var b$$ -} get_changes_expr e  simonpj committed Jul 17, 2001 1113 get_changes_expr (Let b e) = get_changes_bind b $$get_changes_expr e  simonpj committed Jul 25, 2001 1114 get_changes_expr (Case e b a) = get_changes_expr e$$ {- get_changes_var b $$-} vcat (map get_changes_alt a)  simonpj committed Jul 17, 2001 1115   simonpj committed Jul 19, 2001 1116 get_changes_alt (con,bs,rhs) = {- vcat (map get_changes_var bs)$$ -} get_changes_expr rhs  simonpj committed Jul 17, 2001 1117 1118 1119 1120 1121 1122 1123 1124 1125  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)  simonpj committed Nov 19, 2001 1126 1127 1128  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)  simonpj committed Jul 23, 2001 1129 1130  old_better = old betterStrictness new new_better = new betterStrictness old  simonpj committed Jul 17, 2001 1131 1132  get_changes_dmd id  simonpj committed Jul 19, 2001 1133  | isUnLiftedType (idType id) = empty -- Not useful  simonpj committed Jul 17, 2001 1134 1135 1136 1137 1138 1139 1140  | 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)  simonpj committed Nov 19, 2001 1141 1142  new = squashDmd (argDemand (idNewDemandInfo id)) -- To avoid spurious improvements -- A bit of a hack  simonpj committed Jul 17, 2001 1143 1144 1145  old = newDemand (idDemandInfo id) new_better = new betterDemand old old_better = old betterDemand new  simonpj committed Oct 09, 2003 1146 1147 1148 1149 1150 1151 1152 1153 1154  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  simonpj committed Nov 19, 2001 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165  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  simonpj committed Oct 09, 2003 1166 #endif  simonpj committed Jul 17, 2001 1167 \end{code}