ghc/compiler/stranal/DmdAnal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5                         -----------------
   6                         A demand analysis
   7                         -----------------
   8
   9 \begin{code}
  10 module DmdAnal ( dmdAnalPgm ) where
  11
  12 #include "HsVersions.h"
  13
  14 import CmdLineOpts      ( DynFlags, DynFlag(..) )
  15 import NewDemand        -- All of it
  16 import CoreSyn
  17 import DataCon          ( dataConTyCon )
  18 import TyCon            ( isProductTyCon, isRecursiveTyCon )
  19 import Id               ( Id, idInfo, idArity, idStrictness, idCprInfo, idDemandInfo,
  20                           modifyIdInfo, isDataConId, isImplicitId )
  21 import IdInfo           ( newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo,
  22                           newDemandInfo, setNewDemandInfo, newDemand
  23                         )
  24 import Var              ( Var )
  25 import VarEnv
  26 import UniqFM           ( plusUFM_C, addToUFM_Directly, keysUFM, minusUFM )
  27 import CoreLint         ( showPass, endPass )
  28 import ErrUtils         ( dumpIfSet_dyn )
  29 import Util             ( mapAccumL, mapAccumR, zipWithEqual )
  30 import BasicTypes       ( Arity )
  31 import Maybes           ( orElse )
  32 import Outputable
  33 import FastTypes
  34 \end{code}
  35
  36 ToDo:   set a noinline pragma on bottoming Ids
  37
  38 %************************************************************************
  39 %*                                                                      *
  40 \subsection{Top level stuff}
  41 %*                                                                      *
  42 %************************************************************************
  43
  44 \begin{code}
  45 dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
  46 #ifndef DEBUG
  47
  48 dmdAnalPgm dflags binds = return binds
  49
  50 #else
  51
  52 dmdAnalPgm dflags binds
  53   = do {
  54         showPass dflags "Demand analysis" ;
  55         let { binds_plus_dmds = do_prog binds ;
  56               dmd_changes = get_changes binds_plus_dmds } ;
  57         endPass dflags "Demand analysis"
  58                 Opt_D_dump_stranal binds_plus_dmds ;
  59         printDump (text "Changes in demands" $$ dmd_changes) ;
  60         return binds_plus_dmds
  61     }
  62   where
  63     do_prog :: [CoreBind] -> [CoreBind]
  64     do_prog binds = snd $ mapAccumL dmdAnalTopBind emptySigEnv binds
  65
  66 dmdAnalTopBind :: SigEnv
  67                -> CoreBind
  68                -> (SigEnv, CoreBind)
  69 dmdAnalTopBind sigs (NonRec id rhs)
  70   | isImplicitId id             -- Don't touch the info on constructors, selectors etc
  71   = (sigs, NonRec id rhs)       -- It's pre-computed in MkId.lhs
  72   | otherwise
  73   = let
  74         (sig, rhs_env, (id', rhs')) = downRhs sigs (id, rhs)
  75         sigs'                       = extendSigEnv sigs id sig
  76     in
  77     (sigs', NonRec id' rhs')
  78
  79 dmdAnalTopBind sigs (Rec pairs)
  80   = let
  81         (sigs', _, pairs')  = dmdFix sigs pairs
  82     in
  83     (sigs', Rec pairs')
  84 \end{code}
  85
  86
  87 %************************************************************************
  88 %*                                                                      *
  89 \subsection{The analyser itself}
  90 %*                                                                      *
  91 %************************************************************************
  92
  93 \begin{code}
  94 dmdAnal :: SigEnv -> Demand -> CoreExpr -> (DmdType, DmdEnv, CoreExpr)
  95
  96 dmdAnal sigs Abs  e = (DmdRes TopRes, emptyDmdEnv, e)
  97
  98 dmdAnal sigs Lazy e = let
  99                         (res_ty, dmd_env, e') = dmdAnal sigs Eval e
 100                       in
 101                       (res_ty, lazify dmd_env, e')
 102         -- It's important not to analyse e with a lazy demand because
 103         -- a) When we encounter   case s of (a,b) ->
 104         --      we demand s with U(d1d2)... but if the overall demand is lazy
 105         --      that is wrong, and we'd need to reduce the demand on s (inconvenient)
 106         -- b) More important, consider
 107         --      f (let x = R in x+x), where f is lazy
 108         --    We still want to mark x as demanded, because it will be when we
 109         --    enter the let.  If we analyse f's arg with a Lazy demand, we'll
 110         --    just mark x as Lazy
 111
 112
 113 dmdAnal sigs dmd (Var var)
 114   = (res_ty,
 115      blackHoleEnv res_ty (unitDmdEnv var dmd),
 116      Var var)
 117   where
 118     res_ty = dmdTransform sigs var dmd
 119
 120 dmdAnal sigs dmd (Lit lit)
 121   = (topDmdType, emptyDmdEnv, Lit lit)
 122
 123 dmdAnal sigs dmd (Note n e)
 124   = (dmd_ty, dmd_env, Note n e')
 125   where
 126     (dmd_ty, dmd_env, e') = dmdAnal sigs dmd e
 127
 128 dmdAnal sigs dmd (App fun (Type ty))
 129   = (fun_ty, fun_env, App fun' (Type ty))
 130   where
 131     (fun_ty, fun_env, fun') = dmdAnal sigs dmd fun
 132
 133 dmdAnal sigs dmd (App fun arg)  -- Non-type arguments
 134   = let                         -- [Type arg handled above]
 135         (fun_ty, fun_env, fun') = dmdAnal sigs (Call dmd) fun
 136         (arg_ty, arg_env, arg') = dmdAnal sigs arg_dmd arg
 137         (arg_dmd, res_ty)       = splitDmdTy fun_ty
 138     in
 139     (res_ty,
 140      blackHoleEnv res_ty (fun_env `bothEnv` arg_env),
 141      App fun' arg')
 142
 143 dmdAnal sigs dmd (Lam var body)
 144   | isTyVar var
 145   = let
 146         (body_ty, body_env, body') = dmdAnal sigs dmd body
 147     in
 148     (body_ty, body_env, Lam var body')
 149
 150   | otherwise
 151   = let
 152         body_dmd = case dmd of
 153                         Call dmd -> dmd
 154                         other    -> Lazy        -- Conservative
 155
 156         (body_ty, body_env, body') = dmdAnal sigs body_dmd body
 157         (lam_env, var')            = annotateBndr body_env var
 158     in
 159     (DmdFun (idNewDemandInfo var') body_ty,
 160      body_env `delDmdEnv` var,
 161      Lam var' body')
 162
 163 dmdAnal sigs dmd (Case scrut case_bndr [alt@(DataAlt dc,bndrs,rhs)])
 164   | let tycon = dataConTyCon dc,
 165     isProductTyCon tycon,
 166     not (isRecursiveTyCon tycon)
 167   = let
 168         bndr_ids                = filter isId bndrs
 169         (alt_ty, alt_env, alt') = dmdAnalAlt sigs dmd alt
 170         (_, scrut_env, scrut')  = dmdAnal sigs scrut_dmd scrut
 171         (alt_env2, case_bndr')  = annotateBndr alt_env case_bndr
 172         (_, bndrs', _)          = alt'
 173         scrut_dmd               = Seq Drop [idNewDemandInfo b | b <- bndrs', isId b]
 174     in
 175     (alt_ty,
 176      alt_env2 `bothEnv` scrut_env,
 177      Case scrut' case_bndr' [alt'])
 178
 179 dmdAnal sigs dmd (Case scrut case_bndr alts)
 180   = let
 181         (alt_tys, alt_envs, alts')    = unzip3 (map (dmdAnalAlt sigs dmd) alts)
 182         (scrut_ty, scrut_env, scrut') = dmdAnal sigs Eval scrut
 183         (alt_env2, case_bndr')        = annotateBndr (foldr1 lubEnv alt_envs) case_bndr
 184     in
 185     (foldr1 lubDmdTy alt_tys,
 186      alt_env2 `bothEnv` scrut_env,
 187      Case scrut' case_bndr' alts')
 188
 189 dmdAnal sigs dmd (Let (NonRec id rhs) body)
 190   | idArity id == 0     -- A thunk; analyse the body first, then the thunk
 191   = let
 192         (body_ty, body_env, body') = dmdAnal sigs dmd body
 193         (rhs_ty, rhs_env, rhs')    = dmdAnal sigs (lookupDmd body_env id) rhs
 194         (body_env1, id1)           = annotateBndr body_env id
 195     in
 196     (body_ty, body_env1 `bothEnv` rhs_env, Let (NonRec id1 rhs') body')
 197
 198   | otherwise   -- A function; analyse the function first, then the body
 199   = let
 200         (sig, rhs_env, (id1, rhs')) = downRhs sigs (id, rhs)
 201         sigs'                       = extendSigEnv sigs id sig
 202         (body_ty, body_env, body')  = dmdAnal sigs' dmd body
 203         rhs_env1                    = weaken body_env id rhs_env
 204         (body_env1, id2)            = annotateBndr body_env id1
 205     in
 206     (body_ty, body_env1 `bothEnv` rhs_env1, Let (NonRec id2 rhs') body')
 207
 208 dmdAnal sigs dmd (Let (Rec pairs) body)
 209   = let
 210         bndrs                      = map fst pairs
 211         (sigs', rhs_envs, pairs')  = dmdFix sigs pairs
 212         (body_ty, body_env, body') = dmdAnal sigs' dmd body
 213
 214         weakened_rhs_envs = zipWithEqual "dmdAnal:Let" (weaken body_env) bndrs rhs_envs
 215                 -- I saw occasions where it was really worth using the
 216                 -- call demands on the Ids to propagate demand info
 217                 -- on the free variables.  An example is 'roll' in imaginary/wheel-sieve2
 218                 -- Something like this:
 219                 --      roll x = letrec go y = if ... then roll (x-1) else x+1
 220                 --               in go ms
 221                 -- We want to see that this is strict in x.
 222
 223         rhs_env1 = foldr1 bothEnv weakened_rhs_envs
 224
 225         result_env = delDmdEnvList (body_env `bothEnv` rhs_env1) bndrs
 226                 -- Don't bother to add demand info to recursive
 227                 -- binders as annotateBndr does;
 228                 -- being recursive, we can't treat them strictly.
 229                 -- But we do need to remove the binders from the result demand env
 230     in
 231     (body_ty, result_env, Let (Rec pairs') body')
 232 \end{code}
 233
 234 \begin{code}
 235 dmdAnalAlt sigs dmd (con,bndrs,rhs)
 236   = let
 237         (rhs_ty, rhs_env, rhs') = dmdAnal sigs dmd rhs
 238         (alt_env, bndrs')       = annotateBndrs rhs_env bndrs
 239     in
 240     (rhs_ty, alt_env, (con, bndrs', rhs'))
 241 \end{code}
 242
 243 %************************************************************************
 244 %*                                                                      *
 245 \subsection{Bindings}
 246 %*                                                                      *
 247 %************************************************************************
 248
 249 \begin{code}
 250 dmdFix :: SigEnv                -- Does not include bindings for this binding
 251        -> [(Id,CoreExpr)]
 252        -> (SigEnv,
 253            [DmdEnv],            -- Demands from RHSs
 254            [(Id,CoreExpr)])     -- Binders annotated with stricness info
 255
 256 dmdFix sigs pairs
 257   = loop (map initial_sig pairs) pairs
 258   where
 259     loop id_sigs pairs
 260       | id_sigs == id_sigs' = (sigs', rhs_envs, pairs')
 261       | otherwise           = loop id_sigs' pairs'
 262       where
 263         extra_sigs = [(id,sig) | ((id,_),sig) <- pairs `zip` id_sigs]
 264         sigs'      = extendSigEnvList sigs extra_sigs
 265         (id_sigs', rhs_envs, pairs') = unzip3 (map (downRhs sigs') pairs)
 266
 267         -- Get an initial strictness signature from the Id
 268         -- itself.  That way we make use of earlier iterations
 269         -- of the fixpoint algorithm.  (Cunning plan.)
 270     initial_sig (id,_) = idNewStrictness_maybe id `orElse` botSig
 271
 272
 273 downRhs :: SigEnv -> (Id, CoreExpr)
 274         -> (StrictSig, DmdEnv, (Id, CoreExpr))
 275 -- On the way down, compute a strictness signature
 276 -- for the function.  Keep its annotated RHS and dmd env
 277 -- for use on the way up
 278 -- The demand-env is that computed for a vanilla call.
 279
 280 downRhs sigs (id, rhs)
 281  = (sig, rhs_env, (id', rhs'))
 282  where
 283   arity                   = idArity id
 284   (rhs_ty, rhs_env, rhs') = dmdAnal sigs (vanillaCall arity) rhs
 285   sig                     = mkStrictSig arity rhs_ty
 286   id'                     = id `setIdNewStrictness` sig
 287 \end{code}
 288
 289
 290 %************************************************************************
 291 %*                                                                      *
 292 \subsection{Strictness signatures and types}
 293 %*                                                                      *
 294 %************************************************************************
 295
 296 \begin{code}
 297 data DmdEnv
 298   = DmdEnv (VarEnv Demand)      -- All the explicitly mentioned variables
 299            Bool                 -- True  <=> all the others are Bot
 300                                 -- False <=> all the others are Abs
 301
 302 emptyDmdEnv        = DmdEnv emptyVarEnv          False
 303 unitDmdEnv var dmd = DmdEnv (unitVarEnv var dmd) False
 304
 305 lookupDmd :: DmdEnv -> Var -> Demand
 306 lookupDmd (DmdEnv env bh) var = lookupVarEnv env var `orElse` deflt
 307                               where
 308                                 deflt | bh        = Bot
 309                                       | otherwise = Abs
 310
 311 delDmdEnv :: DmdEnv -> Var -> DmdEnv
 312 delDmdEnv (DmdEnv env b) var = DmdEnv (env `delVarEnv` var) b
 313
 314 delDmdEnvList :: DmdEnv -> [Var] -> DmdEnv
 315 delDmdEnvList (DmdEnv env b) vars = DmdEnv (env `delVarEnvList` vars) b
 316
 317
 318 blackHoleEnv :: DmdType -> DmdEnv -> DmdEnv
 319 blackHoleEnv (DmdRes BotRes) (DmdEnv env _) = DmdEnv env True
 320 blackHoleEnv other           env            = env
 321
 322 bothEnv (DmdEnv env1 b1) (DmdEnv env2 b2)
 323   = DmdEnv both_env2 (b1 || b2)
 324   where
 325     both_env  = plusUFM_C both env1 env2
 326     both_env1 = modifyEnv b1 Bot env2 env1 both_env
 327     both_env2 = modifyEnv b2 Bot env1 env2 both_env1
 328
 329 lubEnv (DmdEnv env1 b1) (DmdEnv env2 b2)
 330   = DmdEnv lub_env2 (b1 && b2)
 331   where
 332     lub_env  = plusUFM_C lub env1 env2
 333     lub_env1 = modifyEnv (not b1) Lazy env2 env1 lub_env
 334     lub_env2 = modifyEnv (not b2) Lazy env1 env2 lub_env1
 335
 336 modifyEnv :: Bool                               -- No-op if False
 337           -> Demand                             -- The zap value
 338           -> VarEnv Demand -> VarEnv Demand     -- Env1 and Env2
 339           -> VarEnv Demand -> VarEnv Demand     -- Transform this env
 340         -- Zap anything in Env1 but not in Env2
 341         -- Assume: dom(env) includes dom(Env1) and dom(Env2)
 342
 343 modifyEnv need_to_modify zap_value env1 env2 env
 344   | need_to_modify = foldr zap env (keysUFM (env1 `minusUFM` env2))
 345   | otherwise      = env
 346   where
 347     zap uniq env = addToUFM_Directly env uniq zap_value
 348
 349 annotateBndr :: DmdEnv -> Var -> (DmdEnv, Var)
 350 -- The returned env has the var deleted
 351 -- The returned var is annotated with demand info
 352 annotateBndr dmd_env var
 353   | isTyVar var = (dmd_env,                 var)
 354   | otherwise   = (dmd_env `delDmdEnv` var, setIdNewDemandInfo var (lookupDmd dmd_env var))
 355
 356 annotateBndrs = mapAccumR annotateBndr
 357
 358 weaken :: DmdEnv        -- How the Id is used in its scope
 359        -> Id
 360        -> DmdEnv        -- The RHS env for the Id, assuming a vanilla call demand
 361        -> DmdEnv        -- The RHS env given the actual demand
 362 -- Consider     let f = \x -> R in B
 363 -- The vanilla call demand is C(V), and that's what we use to
 364 -- compute f's strictness signature.  If the *actual* demand on
 365 -- f from B is less than this, we must weaken, or lazify, the
 366 -- demands in R to match this
 367
 368 weaken body_env id rhs_env
 369   | depth >= idArity id         -- Enough demand
 370   = rhs_env
 371   | otherwise                   -- Not enough demand
 372   = lazify rhs_env
 373   where
 374     (depth,_) = splitCallDmd (lookupDmd body_env id)
 375
 376 lazify (DmdEnv env _) = DmdEnv (mapVarEnv (\_ -> Lazy) env) False
 377 \end{code}
 378
 379 %************************************************************************
 380 %*                                                                      *
 381 \subsection{Demand types}
 382 %*                                                                      *
 383 %************************************************************************
 384
 385 \begin{code}
 386 splitDmdTy :: DmdType -> (Demand, DmdType)
 387 -- Split off one function argument
 388 splitDmdTy (DmdFun dmd res_ty) = (dmd, res_ty)
 389 splitDmdTy (DmdRes TopRes)     = (topDmd, topDmdType)
 390 splitDmdTy (DmdRes BotRes)     = (Abs, DmdRes BotRes)
 391         -- We already have a suitable demand on all
 392         -- free vars, so no need to add more!
 393 splitDmdTy (DmdRes RetCPR)     = panic "splitDmdTy"
 394
 395 -------------------------
 396 dmdTypeRes :: DmdType -> Result
 397 dmdTypeRes (DmdFun dmd res_ty) = dmdTypeRes res_ty
 398 dmdTypeRes (DmdRes res)        = res
 399
 400 -------------------------
 401 lubDmdTy :: DmdType -> DmdType -> DmdType
 402 lubDmdTy (DmdFun d1 t1) (DmdFun d2 t2) = DmdFun (d1 `lub` d2) (t1 `lubDmdTy` t2)
 403 lubDmdTy (DmdRes r1)    (DmdRes r2)    = DmdRes (r1 `lubRes` r2)
 404 lubDmdTy t1             t2             = topDmdType
 405
 406 -------------------------
 407 lubRes BotRes r      = r
 408 lubRes r      BotRes = r
 409 lubRes RetCPR RetCPR = RetCPR
 410 lubRes r1     r2     = TopRes
 411 \end{code}
 412
 413
 414 %************************************************************************
 415 %*                                                                      *
 416 \subsection{Strictness signatures}
 417 %*                                                                      *
 418 %************************************************************************
 419
 420 \begin{code}
 421 type SigEnv  = VarEnv StrictSig
 422 emptySigEnv  = emptyVarEnv
 423 extendSigEnv = extendVarEnv
 424 extendSigEnvList = extendVarEnvList
 425 lookupSig sigs v = case lookupVarEnv sigs v of
 426                         Just sig -> Just sig
 427                         Nothing  -> idNewStrictness_maybe v
 428
 429 dmdTransform :: SigEnv          -- The strictness environment
 430              -> Id              -- The function
 431              -> Demand          -- The demand on the function
 432              -> DmdType         -- The demand type of the function in this context
 433
 434 dmdTransform sigs var dmd
 435   | isDataConId var,            -- Data constructor
 436     Seq k ds <- res_dmd,        -- and the demand looks inside its fields
 437     StrictSig arity dmd_ty <- idNewStrictness var,      -- It must have a strictness sig
 438     length ds == arity          -- It's saturated
 439   = mkDmdFun ds (dmdTypeRes dmd_ty)
 440         -- Need to extract whether it's a product
 441
 442
 443   | Just (StrictSig arity dmd_ty) <- lookupSig sigs var,
 444     arity <= depth              -- Saturated function;
 445   = dmd_ty                      -- Unleash the demand!
 446
 447   | otherwise                   -- Default case
 448   = topDmdType
 449
 450   where
 451     (depth, res_dmd) = splitCallDmd dmd
 452
 453 betterStrict :: StrictSig -> StrictSig -> Bool
 454 betterStrict (StrictSig ar1 t1) (StrictSig ar2 t2)
 455   = (ar1 >= ar2) && (t1 `betterDmdType` t2)
 456
 457 betterDmdType t1 t2 = (t1 `lubDmdTy` t2) == t2
 458 \end{code}
 459
 460
 461 %************************************************************************
 462 %*                                                                      *
 463 \subsection{Demands}
 464 %*                                                                      *
 465 %************************************************************************
 466
 467 \begin{code}
 468 splitCallDmd :: Demand -> (Int, Demand)
 469 splitCallDmd (Call d) = case splitCallDmd d of
 470                           (n, r) -> (n+1, r)
 471 splitCallDmd d        = (0, d)
 472
 473 vanillaCall :: Arity -> Demand
 474 vanillaCall 0 = Eval
 475 vanillaCall n = Call (vanillaCall (n-1))
 476
 477 -----------------------------------
 478 lub :: Demand -> Demand -> Demand
 479
 480 lub Bot  d = d
 481
 482 lub Lazy d = Lazy
 483
 484 lub Err Bot = Err
 485 lub Err d   = d
 486
 487 lub Abs Bot = Abs
 488 lub Abs Err = Abs
 489 lub Abs Abs = Abs
 490 lub Abs d   = d
 491
 492 lub Eval Abs        = Lazy
 493 lub Eval Lazy       = Lazy
 494 lub Eval (Seq k ds) = Seq Keep ds
 495 lub Eval d          = Eval
 496
 497 lub (Call d1) (Call d2) = Call (lub d1 d2)
 498
 499 lub (Seq k1 ds1) (Seq k2 ds2) = Seq (k1 `vee` k2)
 500                                     (zipWithEqual "lub" lub ds1 ds2)
 501
 502 -- The last clauses deal with the remaining cases for Call and Seq
 503 lub d1@(Call _) d2@(Seq _ _) = pprPanic "lub" (ppr d1 $$ ppr d2)
 504 lub d1 d2                    = lub d2 d1
 505
 506 -----------------------------------
 507 vee :: Keepity -> Keepity -> Keepity
 508 vee Drop Drop = Drop
 509 vee k1   k2   = Keep
 510
 511 -----------------------------------
 512 both :: Demand -> Demand -> Demand
 513
 514 both Bot d = Bot
 515
 516 both Abs Bot = Bot
 517 both Abs d   = d
 518
 519 both Err Bot = Bot
 520 both Err Abs = Err
 521 both Err d   = d
 522
 523 both Lazy Bot        = Bot
 524 both Lazy Abs        = Lazy
 525 both Lazy Err        = Lazy
 526 both Lazy (Seq k ds) = Seq Keep ds
 527 both Lazy d          = d
 528
 529 both Eval Bot        = Bot
 530 both Eval (Seq k ds) = Seq Keep ds
 531 both Eval (Call d)   = Call d
 532 both Eval d          = Eval
 533
 534 both (Seq k1 ds1) (Seq k2 ds2) = Seq (k1 `vee` k2)
 535                                      (zipWithEqual "both" both ds1 ds2)
 536
 537 both (Call d1) (Call d2) = Call (d1 `both` d2)
 538
 539 -- The last clauses deal with the remaining cases for Call and Seq
 540 both d1@(Call _) d2@(Seq _ _) = pprPanic "both" (ppr d1 $$ ppr d2)
 541 both d1 d2                    = both d2 d1
 542
 543 betterDemand :: Demand -> Demand -> Bool
 544 -- If d1 `better` d2, and d2 `better` d2, then d1==d2
 545 betterDemand d1 d2 = (d1 `lub` d2) == d2
 546 \end{code}
 547
 548
 549 %************************************************************************
 550 %*                                                                      *
 551 \subsection{Miscellaneous
 552 %*                                                                      *
 553 %************************************************************************
 554
 555
 556 \begin{code}
 557 -- Move these to Id.lhs
 558 idNewStrictness_maybe :: Id -> Maybe StrictSig
 559 idNewStrictness :: Id -> StrictSig
 560
 561 idNewStrictness_maybe id = newStrictnessInfo (idInfo id)
 562 idNewStrictness       id = idNewStrictness_maybe id `orElse` topSig
 563
 564 setIdNewStrictness :: Id -> StrictSig -> Id
 565 setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` sig) id
 566
 567 idNewDemandInfo :: Id -> Demand
 568 idNewDemandInfo id = newDemandInfo (idInfo id)
 569
 570 setIdNewDemandInfo :: Id -> Demand -> Id
 571 setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` dmd) id
 572 \end{code}
 573
 574 \begin{code}
 575 get_changes binds = vcat (map get_changes_bind binds)
 576
 577 get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
 578 get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs)
 579
 580 get_changes_pr (id,rhs) = get_changes_var id $$ get_changes_expr rhs
 581
 582 get_changes_var var
 583   | isId var  = get_changes_str var $$ get_changes_dmd var
 584   | otherwise = empty
 585
 586 get_changes_expr (Type t)     = empty
 587 get_changes_expr (Var v)      = empty
 588 get_changes_expr (Lit l)      = empty
 589 get_changes_expr (Note n e)   = get_changes_expr e
 590 get_changes_expr (App e1 e2)  = get_changes_expr e1 $$ get_changes_expr e2
 591 get_changes_expr (Lam b e)    = get_changes_var b $$ get_changes_expr e
 592 get_changes_expr (Let b e)    = get_changes_bind b $$ get_changes_expr e
 593 get_changes_expr (Case e b a) = get_changes_expr e $$ get_changes_var b $$ vcat (map get_changes_alt a)
 594
 595 get_changes_alt (con,bs,rhs) = vcat (map get_changes_var bs) $$ get_changes_expr rhs
 596
 597 get_changes_str id
 598   | new_better && old_better = empty
 599   | new_better               = message "BETTER"
 600   | old_better               = message "WORSE"
 601   | otherwise                = message "INCOMPARABLE"
 602   where
 603     message word = text word <+> text "strictness for" <+> ppr id <+> info
 604     info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
 605     new = idNewStrictness id
 606     old = mkNewStrictnessInfo (idArity id) (idStrictness id) (idCprInfo id)
 607     old_better = old `betterStrict` new
 608     new_better = new `betterStrict` old
 609
 610 get_changes_dmd id
 611   | new_better && old_better = empty
 612   | new_better               = message "BETTER"
 613   | old_better               = message "WORSE"
 614   | otherwise                = message "INCOMPARABLE"
 615   where
 616     message word = text word <+> text "demand for" <+> ppr id <+> info
 617     info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new)
 618     new = idNewDemandInfo id
 619     old = newDemand (idDemandInfo id)
 620     new_better = new `betterDemand` old
 621     old_better = old `betterDemand` new
 622 #endif  /* DEBUG */
 623 \end{code}
 624