ghc/compiler/stranal/SaAbsInt.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[SaAbsInt]{Abstract interpreter for strictness analysis}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SaAbsInt (
  10         findStrictness,
  11         findDemand,
  12         absEval,
  13         widen,
  14         fixpoint,
  15         isBot
  16     ) where
  17
  18 IMPORT_Trace            -- ToDo: rm
  19 import Pretty
  20 --import FiniteMap
  21 import Outputable
  22
  23 import AbsPrel          ( PrimOp(..),
  24                           intTyCon, integerTyCon, doubleTyCon,
  25                           floatTyCon, wordTyCon, addrTyCon,
  26                           PrimKind
  27                         )
  28 import AbsUniType       ( isPrimType, getUniDataTyCon_maybe,
  29                           maybeSingleConstructorTyCon,
  30                           returnsRealWorld,
  31                           isEnumerationTyCon, TyVarTemplate, TyCon
  32                           IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
  33                         )
  34 import Id               ( getIdStrictness, getIdUniType, getIdUnfolding,
  35                           getDataConSig, getInstantiatedDataConSig,
  36                           DataCon(..), isBottomingId
  37                         )
  38
  39 import IdInfo           -- various bits
  40 import IdEnv
  41 import CoreFuns         ( unTagBinders )
  42 import Maybes           ( maybeToBool, Maybe(..) )
  43 import PlainCore
  44 import SaLib
  45 import SimplEnv         ( FormSummary(..) ) -- nice data abstraction, huh? (WDP 95/03)
  46 import Util
  47 \end{code}
  48
  49 %************************************************************************
  50 %*                                                                      *
  51 \subsection[AbsVal-ops]{Operations on @AbsVals@}
  52 %*                                                                      *
  53 %************************************************************************
  54
  55 Least upper bound, greatest lower bound.
  56
  57 \begin{code}
  58 lub, glb :: AbsVal -> AbsVal -> AbsVal
  59
  60 lub val1 val2 | isBot val1    = val2    -- The isBot test includes the case where
  61 lub val1 val2 | isBot val2    = val1    -- one of the val's is a function which
  62                                         -- always returns bottom, such as \y.x,
  63                                         -- when x is bound to bottom.
  64
  65 lub (AbsProd xs) (AbsProd ys) = ASSERT (length xs == length ys)
  66                                 AbsProd (zipWith lub xs ys)
  67
  68 lub _             _           = AbsTop  -- Crude, but conservative
  69                                         -- The crudity only shows up if there
  70                                         -- are functions involved
  71
  72 -- Slightly funny glb; for absence analysis only;
  73 -- AbsBot is the safe answer.
  74 --
  75 -- Using anyBot rather than just testing for AbsBot is important.
  76 -- Consider:
  77 --
  78 --   f = \a b -> ...
  79 --
  80 --   g = \x y z -> case x of
  81 --                   []     -> f x
  82 --                   (p:ps) -> f p
  83 --
  84 -- Now, the abstract value of the branches of the case will be an
  85 -- AbsFun, but when testing for z's absence we want to spot that it's
  86 -- an AbsFun which can't possibly return AbsBot.  So when glb'ing we
  87 -- mustn't be too keen to bale out and return AbsBot; the anyBot test
  88 -- spots that (f x) can't possibly return AbsBot.
  89
  90 -- We have also tripped over the following interesting case:
  91 --      case x of
  92 --        []     -> \y -> 1
  93 --        (p:ps) -> f
  94 --
  95 -- Now, suppose f is bound to AbsTop.  Does this expression mention z?
  96 -- Obviously not.  But the case will take the glb of AbsTop (for f) and
  97 -- an AbsFun (for \y->1). We should not bale out and give AbsBot, because
  98 -- that would say that it *does* mention z (or anything else for that matter).
  99 -- Nor can we always return AbsTop, because the AbsFun might be something
 100 -- like (\y->z), which obviously does mention z. The point is that we're
 101 -- glbing two functions, and AbsTop is not actually the top of the function
 102 -- lattice.  It is more like (\xyz -> x|y|z); that is, AbsTop returns
 103 -- poison iff any of its arguments do.
 104
 105 -- Deal with functions specially, because AbsTop isn't the
 106 -- top of their domain.
 107
 108 glb v1 v2
 109   | is_fun v1 || is_fun v2
 110   = if not (anyBot v1) && not (anyBot v2)
 111     then
 112         AbsTop
 113     else
 114         AbsBot
 115   where
 116     is_fun (AbsFun _ _ _)   = True
 117     is_fun (AbsApproxFun _) = True      -- Not used, but the glb works ok
 118     is_fun other            = False
 119
 120 -- The non-functional cases are quite straightforward
 121
 122 glb (AbsProd xs) (AbsProd ys) = ASSERT (length xs == length ys)
 123                                 AbsProd (zipWith glb xs ys)
 124
 125 glb AbsTop       v2           = v2
 126 glb v1           AbsTop       = v1
 127
 128 glb _            _            = AbsBot          -- Be pessimistic
 129
 130
 131
 132 combineCaseValues
 133         :: AnalysisKind
 134         -> AbsVal       -- Value of scrutinee
 135         -> [AbsVal]     -- Value of branches (at least one)
 136         -> AbsVal       -- Result
 137
 138 -- For strictness analysis, see if the scrutinee is bottom; if so
 139 -- return bottom; otherwise, the lub of the branches.
 140
 141 combineCaseValues StrAnal AbsBot          branches = AbsBot
 142 combineCaseValues StrAnal other_scrutinee branches
 143         -- Scrutinee can only be AbsBot, AbsProd or AbsTop
 144   = ASSERT(ok_scrutinee)
 145     foldr1 lub branches
 146   where
 147     ok_scrutinee
 148       = case other_scrutinee of {
 149           AbsTop    -> True;    -- i.e., cool
 150           AbsProd _ -> True;    -- ditto
 151           _         -> False    -- party over
 152         }
 153
 154 -- For absence analysis, check if the scrutinee is all poison (isBot)
 155 -- If so, return poison (AbsBot); otherwise, any nested poison will come
 156 -- out from looking at the branches, so just glb together the branches
 157 -- to get the worst one.
 158
 159 combineCaseValues AbsAnal AbsBot          branches = AbsBot
 160 combineCaseValues AbsAnal other_scrutinee branches
 161         -- Scrutinee can only be AbsBot, AbsProd or AbsTop
 162   = ASSERT(ok_scrutinee)
 163     let
 164         result = foldr1 glb branches
 165
 166         tracer = if at_least_one_AbsFun && at_least_one_AbsTop
 167                     && no_AbsBots then
 168                     pprTrace "combineCase:" (ppr PprDebug branches)
 169                  else
 170                     id
 171     in
 172 --    tracer (
 173     result
 174 --    )
 175   where
 176     ok_scrutinee
 177       = case other_scrutinee of {
 178           AbsTop    -> True;    -- i.e., cool
 179           AbsProd _ -> True;    -- ditto
 180           _         -> False    -- party over
 181         }
 182
 183     at_least_one_AbsFun = foldr ((||) . is_AbsFun) False branches
 184     at_least_one_AbsTop = foldr ((||) . is_AbsTop) False branches
 185     no_AbsBots = foldr ((&&) . is_not_AbsBot) True branches
 186
 187     is_AbsFun x = case x of { AbsFun _ _ _ -> True; _ -> False }
 188     is_AbsTop x = case x of { AbsTop -> True; _ -> False }
 189     is_not_AbsBot x = case x of { AbsBot -> False; _ -> True }
 190 \end{code}
 191
 192 @isBot@ returns True if its argument is (a representation of) bottom.  The
 193 ``representation'' part is because we need to detect the bottom {\em function}
 194 too.  To detect the bottom function, bind its args to top, and see if it
 195 returns bottom.
 196
 197 Used only in strictness analysis:
 198 \begin{code}
 199 isBot :: AbsVal -> Bool
 200
 201 isBot AbsBot                 = True
 202 isBot (AbsFun args body env) = isBot (absEval StrAnal body env)
 203                                -- Don't bother to extend the envt because
 204                                -- unbound variables default to AbsTop anyway
 205 isBot other                  = False
 206 \end{code}
 207
 208 Used only in absence analysis:
 209 \begin{code}
 210 anyBot :: AbsVal -> Bool
 211
 212 anyBot AbsBot                 = True    -- poisoned!
 213 anyBot AbsTop                 = False
 214 anyBot (AbsProd vals)         = any anyBot vals
 215 anyBot (AbsFun args body env) = anyBot (absEval AbsAnal body env)
 216 anyBot (AbsApproxFun demands) = False
 217
 218     -- AbsApproxFun can only arise in absence analysis from the Demand
 219     -- info of an imported value; whatever it is we're looking for is
 220     -- certainly not present over in the imported value.
 221 \end{code}
 222
 223 @widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is
 224 approximated by $val$.  Furthermore, the result has no @AbsFun@s in
 225 it, so it can be compared for equality by @sameVal@.
 226
 227 \begin{code}
 228 widen :: AnalysisKind -> AbsVal -> AbsVal
 229
 230 widen StrAnal (AbsFun args body env)
 231   | isBot (absEval StrAnal body env) = AbsBot
 232   | otherwise
 233   = ASSERT (not (null args))
 234     AbsApproxFun (map (findDemandStrOnly env body) args)
 235
 236     -- It's worth checking for a function which is unconditionally
 237     -- bottom.  Consider
 238     --
 239     --  f x y = let g y = case x of ...
 240     --          in (g ..) + (g ..)
 241     --
 242     -- Here, when we are considering strictness of f in x, we'll
 243     -- evaluate the body of f with x bound to bottom.  The current
 244     -- strategy is to bind g to its *widened* value; without the isBot
 245     -- (...) test above, we'd bind g to an AbsApproxFun, and deliver
 246     -- Top, not Bot as the value of f's rhs.  The test spots the
 247     -- unconditional bottom-ness of g when x is bottom.  (Another
 248     -- alternative here would be to bind g to its exact abstract
 249     -- value, but that entails lots of potential re-computation, at
 250     -- every application of g.)
 251
 252 widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals)
 253 widen StrAnal other_val      = other_val
 254
 255
 256 widen AbsAnal (AbsFun args body env)
 257   | anyBot (absEval AbsAnal body env) = AbsBot
 258         -- In the absence-analysis case it's *essential* to check
 259         -- that the function has no poison in its body.  If it does,
 260         -- anywhere, then the whole function is poisonous.
 261
 262   | otherwise
 263   = ASSERT (not (null args))
 264     AbsApproxFun (map (findDemandAbsOnly env body) args)
 265
 266 widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals)
 267
 268         -- It's desirable to do a good job of widening for product
 269         -- values.  Consider
 270         --
 271         --      let p = (x,y)
 272         --      in ...(case p of (x,y) -> x)...
 273         --
 274         -- Now, is y absent in this expression?  Currently the
 275         -- analyser widens p before looking at p's scope, to avoid
 276         -- lots of recomputation in the case where p is a function.
 277         -- So if widening doesn't have a case for products, we'll
 278         -- widen p to AbsBot (since when searching for absence in y we
 279         -- bind y to poison ie AbsBot), and now we are lost.
 280
 281 widen AbsAnal other_val = other_val
 282
 283 -- OLD                    if anyBot val then AbsBot else AbsTop
 284 -- Nowadays widen is doing a better job on functions for absence analysis.
 285 \end{code}
 286
 287 @crudeAbsWiden@ is used just for absence analysis, and always
 288 returns AbsTop or AbsBot, so it widens to a two-point domain
 289
 290 \begin{code}
 291 crudeAbsWiden :: AbsVal -> AbsVal
 292 crudeAbsWiden val = if anyBot val then AbsBot else AbsTop
 293 \end{code}
 294
 295 @sameVal@ compares two abstract values for equality.  It can't deal with
 296 @AbsFun@, but that should have been removed earlier in the day by @widen@.
 297
 298 \begin{code}
 299 sameVal :: AbsVal -> AbsVal -> Bool     -- Can't handle AbsFun!
 300
 301 #ifdef DEBUG
 302 sameVal (AbsFun _ _ _) _ = panic "sameVal: AbsFun: arg1"
 303 sameVal _ (AbsFun _ _ _) = panic "sameVal: AbsFun: arg2"
 304 #endif
 305
 306 sameVal AbsBot AbsBot = True
 307 sameVal AbsBot other  = False   -- widen has reduced AbsFun bots to AbsBot
 308
 309 sameVal AbsTop AbsTop = True
 310 sameVal AbsTop other  = False           -- Right?
 311
 312 sameVal (AbsProd vals1) (AbsProd vals2) = ASSERT (length vals1 == length vals2)
 313                                           and (zipWith sameVal vals1 vals2)
 314 sameVal (AbsProd _)     AbsTop          = False
 315 sameVal (AbsProd _)     AbsBot          = False
 316
 317 sameVal (AbsApproxFun str1) (AbsApproxFun str2) = str1 == str2
 318 sameVal (AbsApproxFun _)    AbsTop              = False
 319 sameVal (AbsApproxFun _)    AbsBot              = False
 320
 321 sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered"
 322 \end{code}
 323
 324
 325 @evalStrictness@ compares a @Demand@ with an abstract value, returning
 326 @True@ iff the abstract value is {\em less defined} than the demand.
 327 (@True@ is the exciting answer; @False@ is always safe.)
 328
 329 \begin{code}
 330 evalStrictness :: Demand
 331                -> AbsVal
 332                -> Bool          -- True iff the value is sure
 333                                 -- to be less defined than the Demand
 334
 335 evalStrictness (WwLazy _) _   = False
 336 evalStrictness WwStrict   val = isBot val
 337 evalStrictness WwEnum     val = isBot val
 338
 339 evalStrictness (WwUnpack demand_info) val
 340   = case val of
 341       AbsTop       -> False
 342       AbsBot       -> True
 343       AbsProd vals -> ASSERT (length vals == length demand_info)
 344                       or (zipWith evalStrictness demand_info vals)
 345       _            -> trace "evalStrictness?" False
 346
 347 evalStrictness WwPrim val
 348   = case val of
 349       AbsTop -> False
 350
 351       other  ->   -- A primitive value should be defined, never bottom;
 352                   -- hence this paranoia check
 353                 pprPanic "evalStrictness: WwPrim:" (ppr PprDebug other)
 354 \end{code}
 355
 356 For absence analysis, we're interested in whether "poison" in the
 357 argument (ie a bottom therein) can propagate to the result of the
 358 function call; that is, whether the specified demand can {\em
 359 possibly} hit poison.
 360
 361 \begin{code}
 362 evalAbsence (WwLazy True) _ = False     -- Can't possibly hit poison
 363                                         -- with Absent demand
 364
 365 evalAbsence (WwUnpack demand_info) val
 366   = case val of
 367         AbsTop       -> False           -- No poison in here
 368         AbsBot       -> True            -- Pure poison
 369         AbsProd vals -> ASSERT (length demand_info == length vals)
 370                         or (zipWith evalAbsence demand_info vals)
 371         _            -> panic "evalAbsence: other"
 372
 373 evalAbsence other val = anyBot val
 374   -- The demand is conservative; even "Lazy" *might* evaluate the
 375   -- argument arbitrarily so we have to look everywhere for poison
 376 \end{code}
 377
 378 %************************************************************************
 379 %*                                                                      *
 380 \subsection[absEval]{Evaluate an expression in the abstract domain}
 381 %*                                                                      *
 382 %************************************************************************
 383
 384 \begin{code}
 385 -- The isBottomingId stuf is now dealt with via the Id's strictness info
 386 -- absId anal var env | isBottomingId var
 387 --   = case anal of
 388 --      StrAnal -> AbsBot       -- See discussion below
 389 --      AbsAnal -> AbsTop       -- Just want to see if there's any poison in
 390                                 -- error's arg
 391
 392 absId anal var env
 393   = let
 394      result =
 395       case (lookupAbsValEnv env var, getIdStrictness var, getIdUnfolding var) of
 396
 397         (Just abs_val, _, _) ->
 398                         abs_val -- Bound in the environment
 399
 400         (Nothing, NoStrictnessInfo, LiteralForm _) ->
 401                         AbsTop  -- Literals all terminate, and have no poison
 402
 403         (Nothing, NoStrictnessInfo, ConstructorForm _ _ _) ->
 404                         AbsTop -- An imported constructor won't have
 405                                -- bottom components, nor poison!
 406
 407         (Nothing, NoStrictnessInfo, GeneralForm _ _ unfolding _) ->
 408                         -- We have an unfolding for the expr
 409                         -- Assume the unfolding has no free variables since it
 410                         -- came from inside the Id
 411                         absEval anal (unTagBinders unfolding) env
 412                 -- Notice here that we only look in the unfolding if we don't
 413                 -- have strictness info (an unusual situation).
 414                 -- We could have chosen to look in the unfolding if it exists,
 415                 -- and only try the strictness info if it doesn't, and that would
 416                 -- give more accurate results, at the cost of re-abstract-interpreting
 417                 -- the unfolding every time.
 418                 -- We found only one place where the look-at-unfolding-first
 419                 -- method gave better results, which is in the definition of
 420                 -- showInt in the Prelude.  In its defintion, fromIntegral is
 421                 -- not inlined (it's big) but ab-interp-ing its unfolding gave
 422                 -- a better result than looking at its strictness only.
 423                 --  showInt :: Integral a => a -> [Char] -> [Char]
 424                 -- !       {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
 425                 --         "U(U(U(U(SA)AAAAAAAAL)AA)AAAAASAAASA)" {...} _N_ _N_ #-}
 426                 -- --- 42,44 ----
 427                 --   showInt :: Integral a => a -> [Char] -> [Char]
 428                 -- !       {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_
 429                 --        "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-}
 430
 431
 432         (Nothing, strictness_info, _) ->
 433                         -- Includes MagicForm, IWantToBeINLINEd, NoUnfoldingDetails
 434                         -- Try the strictness info
 435                         absValFromStrictness anal strictness_info
 436
 437
 438         --      Done via strictness now
 439         --        GeneralForm _ BottomForm _ _ -> AbsBot
 440     in
 441     -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) (
 442     result
 443     -- )
 444   where
 445     pp_anal StrAnal = ppStr "STR"
 446     pp_anal AbsAnal = ppStr "ABS"
 447
 448 absEvalAtom anal (CoVarAtom v) env = absId anal v env
 449 absEvalAtom anal (CoLitAtom _) env = AbsTop
 450 \end{code}
 451
 452 \begin{code}
 453 absEval :: AnalysisKind -> PlainCoreExpr -> AbsValEnv -> AbsVal
 454
 455 absEval anal (CoVar var) env = absId anal var env
 456
 457 absEval anal (CoLit _) env = AbsTop
 458     -- What if an unboxed literal?  That's OK: it terminates, so its
 459     -- abstract value is AbsTop.
 460
 461     -- For absence analysis, a literal certainly isn't the "poison" variable
 462 \end{code}
 463
 464 Discussion about \tr{error} (following/quoting Lennart): Any expression
 465 \tr{error e} is regarded as bottom (with HBC, with the
 466 \tr{-ffail-strict} flag, on with \tr{-O}).
 467
 468 Regarding it as bottom gives much better strictness properties for
 469 some functions.  E.g.
 470 \begin{verbatim}
 471         f [x] y = x+y
 472         f (x:xs) y = f xs (x+y)
 473 i.e.
 474         f [] _ = error "no match"
 475         f [x] y = x+y
 476         f (x:xs) y = f xs (x+y)
 477 \end{verbatim}
 478 is strict in \tr{y}, which you really want.  But, it may lead to
 479 transformations that turn a call to \tr{error} into non-termination.
 480 (The odds of this happening aren't good.)
 481
 482
 483 Things are a little different for absence analysis, because we want
 484 to make sure that any poison (?????)
 485
 486 \begin{code}
 487 absEval StrAnal (CoPrim SeqOp [t] [e]) env
 488   = if isBot (absEvalAtom StrAnal e env) then AbsBot else AbsTop
 489         -- This is a special case to ensure that seq# is strict in its argument.
 490         -- The comments below (for most normal PrimOps) do not apply.
 491
 492 absEval StrAnal (CoPrim op ts es) env = AbsTop
 493         -- The arguments are all of unboxed type, so they will already
 494         -- have been eval'd.  If the boxed version was bottom, we'll
 495         -- already have returned bottom.
 496
 497         -- Actually, I believe we are saying that either (1) the
 498         -- primOp uses unboxed args and they've been eval'ed, so
 499         -- there's no need to force strictness here, _or_ the primOp
 500         -- uses boxed args and we don't know whether or not it's
 501         -- strict, so we assume laziness. (JSM)
 502
 503 absEval AbsAnal (CoPrim op ts as) env
 504   = if any anyBot [absEvalAtom AbsAnal a env | a <- as]
 505     then AbsBot
 506     else AbsTop
 507         -- For absence analysis, we want to see if the poison shows up...
 508
 509 absEval anal (CoCon con ts as) env
 510   | has_single_con
 511   = AbsProd [absEvalAtom anal a env | a <- as]
 512
 513   | otherwise   -- Not single-constructor
 514   = case anal of
 515         StrAnal ->      -- Strictness case: it's easy: it certainly terminates
 516                    AbsTop
 517         AbsAnal ->      -- In the absence case we need to be more
 518                         -- careful: look to see if there's any
 519                         -- poison in the components
 520                    if any anyBot [absEvalAtom AbsAnal a env | a <- as]
 521                    then AbsBot
 522                    else AbsTop
 523   where
 524     (_,_,_, tycon) = getDataConSig con
 525     has_single_con = maybeToBool (maybeSingleConstructorTyCon tycon)
 526 \end{code}
 527
 528 \begin{code}
 529 absEval anal (CoLam []      body) env   = absEval anal body env -- paranoia
 530 absEval anal (CoLam binders body) env   = AbsFun binders body env
 531 absEval anal (CoTyLam ty expr)    env   = absEval  anal expr env
 532 absEval anal (CoApp e1 e2)        env   = absApply anal (absEval     anal e1 env)
 533                                                         (absEvalAtom anal e2 env)
 534 absEval anal (CoTyApp expr ty)    env   = absEval anal expr env
 535 \end{code}
 536
 537 For primitive cases, just GLB the branches, then LUB with the expr part.
 538
 539 \begin{code}
 540 absEval anal (CoCase expr (CoPrimAlts alts deflt)) env
 541   = let
 542         expr_val    = absEval anal expr env
 543         abs_alts    = [ absEval anal rhs env | (_, rhs) <- alts ]
 544                         -- Don't bother to extend envt, because unbound vars
 545                         -- default to the conservative AbsTop
 546
 547         abs_deflt   = absEvalDefault anal expr_val deflt env
 548     in
 549         combineCaseValues anal expr_val
 550                                (abs_deflt ++ abs_alts)
 551
 552 absEval anal (CoCase expr (CoAlgAlts alts deflt)) env
 553   = let
 554         expr_val  = absEval anal expr env
 555         abs_alts  = [ absEvalAlgAlt anal expr_val alt env | alt <- alts ]
 556         abs_deflt = absEvalDefault anal expr_val deflt env
 557     in
 558     let
 559         result =
 560           combineCaseValues anal expr_val
 561                                 (abs_deflt ++ abs_alts)
 562     in
 563 {-
 564     (case anal of
 565         StrAnal -> id
 566         _ -> pprTrace "absCase:ABS:" (ppAbove (ppCat [ppr PprDebug expr, ppr PprDebug result, ppr PprDebug expr_val, ppr PprDebug abs_deflt, ppr PprDebug abs_alts]) (ppr PprDebug (keysFM env `zip` eltsFM env)))
 567     )
 568 -}
 569     result
 570 \end{code}
 571
 572 For @CoLets@ we widen the value we get.  This is nothing to
 573 do with fixpointing.  The reason is so that we don't get an explosion
 574 in the amount of computation.  For example, consider:
 575 \begin{verbatim}
 576       let
 577         g a = case a of
 578                 q1 -> ...
 579                 q2 -> ...
 580         f x = case x of
 581                 p1 -> ...g r...
 582                 p2 -> ...g s...
 583       in
 584         f e
 585 \end{verbatim}
 586 If we bind @f@ and @g@ to their exact abstract value, then we'll
 587 ``execute'' one call to @f@ and {\em two} calls to @g@.  This can blow
 588 up exponentially.  Widening cuts it off by making a fixed
 589 approximation to @f@ and @g@, so that the bodies of @f@ and @g@ are
 590 not evaluated again at all when they are called.
 591
 592 Of course, this can lose useful joint strictness, which is sad.  An
 593 alternative approach would be to try with a certain amount of ``fuel''
 594 and be prepared to bale out.
 595
 596 \begin{code}
 597 absEval anal (CoLet (CoNonRec binder e1) e2) env
 598   = let
 599         new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env))
 600     in
 601         -- The binder of a CoNonRec should *not* be of unboxed type,
 602         -- hence no need to strictly evaluate the Rhs.
 603     absEval anal e2 new_env
 604
 605 absEval anal (CoLet (CoRec pairs) body) env
 606   = let
 607         (binders,rhss) = unzip pairs
 608         rhs_vals = cheapFixpoint anal binders rhss env  -- Returns widened values
 609         new_env  = growAbsValEnvList env (binders `zip` rhs_vals)
 610     in
 611     absEval anal body new_env
 612 \end{code}
 613
 614 \begin{code}
 615 absEval anal (CoSCC cc expr) env = absEval anal expr env
 616
 617 -- ToDo: add DPH stuff here
 618 \end{code}
 619
 620 \begin{code}
 621 absEvalAlgAlt :: AnalysisKind -> AbsVal -> (Id,[Id],PlainCoreExpr) -> AbsValEnv -> AbsVal
 622
 623 absEvalAlgAlt anal (AbsProd arg_vals) (con, args, rhs) env
 624   =     -- The scrutinee is a product value, so it must be of a single-constr
 625         -- type; so the constructor in this alternative must be the right one
 626         -- so we can go ahead and bind the constructor args to the components
 627         -- of the product value.
 628     ASSERT(length arg_vals == length args)
 629     let
 630          new_env = growAbsValEnvList env (args `zip` arg_vals)
 631     in
 632     absEval anal rhs new_env
 633
 634 absEvalAlgAlt anal other_scrutinee (con, args, rhs) env
 635   =     -- Scrutinised value is Top or Bot (it can't be a function!)
 636         -- So just evaluate the rhs with all constr args bound to Top.
 637         -- (If the scrutinee is Top we'll never evaluated this function
 638         -- call anyway!)
 639     ASSERT(ok_scrutinee)
 640     absEval anal rhs env
 641   where
 642     ok_scrutinee
 643       = case other_scrutinee of {
 644           AbsTop -> True;   -- i.e., OK
 645           AbsBot -> True;   -- ditto
 646           _      -> False   -- party over
 647         }
 648
 649
 650 absEvalDefault :: AnalysisKind
 651                -> AbsVal                -- Value of scrutinee
 652                -> PlainCoreCaseDefault
 653                -> AbsValEnv
 654                -> [AbsVal]              -- Empty or singleton
 655
 656 absEvalDefault anal scrut_val CoNoDefault env = []
 657 absEvalDefault anal scrut_val (CoBindDefault binder expr) env
 658   = [absEval anal expr (addOneToAbsValEnv env binder scrut_val)]
 659 \end{code}
 660
 661 %************************************************************************
 662 %*                                                                      *
 663 \subsection[absApply]{Apply an abstract function to an abstract argument}
 664 %*                                                                      *
 665 %************************************************************************
 666
 667 Easy ones first:
 668
 669 \begin{code}
 670 absApply :: AnalysisKind -> AbsVal -> AbsVal -> AbsVal
 671
 672 absApply anal AbsBot arg = AbsBot
 673   -- AbsBot represents the abstract bottom *function* too
 674
 675 absApply StrAnal AbsTop arg = AbsTop
 676 absApply AbsAnal AbsTop arg = if anyBot arg
 677                               then AbsBot
 678                               else AbsTop
 679         -- To be conservative, we have to assume that a function about
 680         -- which we know nothing (AbsTop) might look at some part of
 681         -- its argument
 682 \end{code}
 683
 684 An @AbsFun@ with only one more argument needed---bind it and eval the
 685 result.  A @CoLam@ with two or more args: return another @AbsFun@ with
 686 an augmented environment.
 687
 688 \begin{code}
 689 absApply anal (AbsFun [binder] body env) arg
 690   = absEval anal body (addOneToAbsValEnv env binder arg)
 691
 692 absApply anal (AbsFun (binder:bs) body env) arg
 693   = AbsFun bs body (addOneToAbsValEnv env binder arg)
 694 \end{code}
 695
 696 \begin{code}
 697 absApply StrAnal (AbsApproxFun (arg1_demand:ds)) arg
 698   = if evalStrictness arg1_demand arg
 699     then AbsBot
 700     else case ds of
 701            []    -> AbsTop
 702            other -> AbsApproxFun ds
 703
 704 absApply AbsAnal (AbsApproxFun (arg1_demand:ds)) arg
 705   = if evalAbsence arg1_demand arg
 706     then AbsBot
 707     else case ds of
 708            []    -> AbsTop
 709            other -> AbsApproxFun ds
 710
 711 #ifdef DEBUG
 712 absApply anal (AbsApproxFun []) arg = panic ("absApply: Duff function: AbsApproxFun." ++ show anal)
 713 absApply anal (AbsFun [] _ _)   arg = panic ("absApply: Duff function: AbsFun." ++ show anal)
 714 absApply anal (AbsProd _)       arg = panic ("absApply: Duff function: AbsProd." ++ show anal)
 715 #endif
 716 \end{code}
 717
 718
 719
 720
 721 %************************************************************************
 722 %*                                                                      *
 723 \subsection[findStrictness]{Determine some binders' strictness}
 724 %*                                                                      *
 725 %************************************************************************
 726
 727 @findStrictness@ applies the function \tr{\ ids -> expr} to
 728 \tr{[bot,top,top,...]}, \tr{[top,bot,top,top,...]}, etc., (i.e., once
 729 with @AbsBot@ in each argument position), and evaluates the resulting
 730 abstract value; it returns a vector of @Demand@s saying whether the
 731 result of doing this is guaranteed to be bottom.  This tells the
 732 strictness of the function in each of the arguments.
 733
 734 If an argument is of unboxed type, then we declare that function to be
 735 strict in that argument.
 736
 737 We don't really have to make up all those lists of mostly-@AbsTops@;
 738 unbound variables in an @AbsValEnv@ are implicitly mapped to that.
 739
 740 See notes on @addStrictnessInfoToId@.
 741
 742 \begin{code}
 743 findStrictness :: StrAnalFlags
 744                -> [UniType]     -- Types of args in which strictness is wanted
 745                -> AbsVal        -- Abstract strictness value of function
 746                -> AbsVal        -- Abstract absence value of function
 747                -> [Demand]      -- Resulting strictness annotation
 748
 749 findStrictness strflags [] str_val abs_val = []
 750
 751 findStrictness strflags (ty:tys) str_val abs_val
 752   = let
 753         demand       = findRecDemand strflags [] str_fn abs_fn ty
 754         str_fn val   = absApply StrAnal str_val val
 755         abs_fn val   = absApply AbsAnal abs_val val
 756
 757         demands = findStrictness strflags tys
 758                         (absApply StrAnal str_val AbsTop)
 759                         (absApply AbsAnal abs_val AbsTop)
 760     in
 761     demand : demands
 762 \end{code}
 763
 764
 765 \begin{code}
 766 findDemandStrOnly str_env expr binder   -- Only strictness environment available
 767   = findRecDemand strflags [] str_fn abs_fn (getIdUniType binder)
 768   where
 769     str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
 770     abs_fn val = AbsBot         -- Always says poison; so it looks as if
 771                                 -- nothing is absent; safe
 772     strflags   = getStrAnalFlags str_env
 773
 774 findDemandAbsOnly abs_env expr binder   -- Only absence environment available
 775   = findRecDemand strflags [] str_fn abs_fn (getIdUniType binder)
 776   where
 777     str_fn val = AbsBot         -- Always says non-termination;
 778                                 -- that'll make findRecDemand peer into the
 779                                 -- structure of the value.
 780     abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
 781     strflags   = getStrAnalFlags abs_env
 782
 783
 784 findDemand str_env abs_env expr binder
 785   = findRecDemand strflags [] str_fn abs_fn (getIdUniType binder)
 786   where
 787     str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
 788     abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
 789     strflags   = getStrAnalFlags str_env
 790 \end{code}
 791
 792 @findRecDemand@ is where we finally convert strictness/absence info
 793 into ``Demands'' which we can pin on Ids (etc.).
 794
 795 NOTE: What do we do if something is {\em both} strict and absent?
 796 Should \tr{f x y z = error "foo"} says that \tr{f}'s arguments are all
 797 strict (because of bottoming effect of \tr{error}) or all absent
 798 (because they're not used)?
 799
 800 Well, for practical reasons, we prefer absence over strictness.  In
 801 particular, it makes the ``default defaults'' for class methods (the
 802 ones that say \tr{defm.foo dict = error "I don't exist"}) come out
 803 nicely [saying ``the dict isn't used''], rather than saying it is
 804 strict in every component of the dictionary [massive gratuitious
 805 casing to take the dict apart].
 806
 807 But you could have examples where going for strictness would be better
 808 than absence.  Consider:
 809 \begin{verbatim}
 810         let x = something big
 811         in
 812         f x y z + g x
 813 \end{verbatim}
 814
 815 If \tr{x} is marked absent in \tr{f}, but not strict, and \tr{g} is
 816 lazy, then the thunk for \tr{x} will be built.  If \tr{f} was strict,
 817 then we'd let-to-case it:
 818 \begin{verbatim}
 819         case something big of
 820           x -> f x y z + g x
 821 \end{verbatim}
 822 Ho hum.
 823
 824 \begin{code}
 825 findRecDemand :: StrAnalFlags
 826               -> [TyCon]            -- TyCons already seen; used to avoid
 827                                     -- zooming into recursive types
 828               -> (AbsVal -> AbsVal) -- The strictness function
 829               -> (AbsVal -> AbsVal) -- The absence function
 830               -> UniType            -- The type of the argument
 831               -> Demand
 832
 833 findRecDemand strflags seen str_fn abs_fn ty
 834   = if isPrimType ty then -- It's a primitive type!
 835        wwPrim
 836
 837     else if not (anyBot (abs_fn AbsBot)) then -- It's absent
 838        -- We prefer absence over strictness: see NOTE above.
 839        WwLazy True
 840
 841     else if not (all_strict ||
 842                  (num_strict && is_numeric_type ty) ||
 843                  (isBot (str_fn AbsBot))) then
 844         WwLazy False -- It's not strict and we're not pretending
 845
 846     else -- It's strict (or we're pretending it is)!
 847
 848        case getUniDataTyCon_maybe ty of
 849
 850          Nothing    -> wwStrict
 851
 852          Just (tycon,tycon_arg_tys,[data_con]) | tycon `not_elem` seen ->
 853            -- Single constructor case, tycon not already seen higher up
 854            let
 855               (_,cmpnt_tys,_) = getInstantiatedDataConSig data_con tycon_arg_tys
 856               prod_len = length cmpnt_tys
 857
 858               compt_strict_infos
 859                 = [ findRecDemand strflags (tycon:seen)
 860                          (\ cmpnt_val ->
 861                                str_fn (mkMainlyTopProd prod_len i cmpnt_val)
 862                          )
 863                          (\ cmpnt_val ->
 864                                abs_fn (mkMainlyTopProd prod_len i cmpnt_val)
 865                          )
 866                      cmpnt_ty
 867                   | (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ]
 868            in
 869            if null compt_strict_infos then
 870                  if isEnumerationTyCon tycon then wwEnum else wwStrict
 871            else
 872                  wwUnpack compt_strict_infos
 873           where
 874            not_elem = isn'tIn "findRecDemand"
 875
 876          Just (tycon,_,_) ->
 877                 -- Multi-constr data types, *or* an abstract data
 878                 -- types, *or* things we don't have a way of conveying
 879                 -- the info over module boundaries (class ops,
 880                 -- superdict sels, dfns).
 881             if isEnumerationTyCon tycon then
 882                 wwEnum
 883             else
 884                 wwStrict
 885   where
 886     (all_strict, num_strict) = strflags
 887
 888     is_numeric_type ty
 889       = case (getUniDataTyCon_maybe ty) of -- NB: duplicates stuff done above
 890           Nothing -> False
 891           Just (tycon, _, _)
 892             | tycon `is_elem`
 893               [intTyCon, integerTyCon,
 894                doubleTyCon, floatTyCon,
 895                wordTyCon, addrTyCon]
 896             -> True
 897           _{-something else-} -> False
 898       where
 899         is_elem = isIn "is_numeric_type"
 900
 901     -- mkMainlyTopProd: make an AbsProd that is all AbsTops ("n"-1 of
 902     -- them) except for a given value in the "i"th position.
 903
 904     mkMainlyTopProd :: Int -> Int -> AbsVal -> AbsVal
 905
 906     mkMainlyTopProd n i val
 907       = let
 908             befores = nOfThem (i-1) AbsTop
 909             afters  = nOfThem (n-i) AbsTop
 910         in
 911         AbsProd (befores ++ (val : afters))
 912 \end{code}
 913
 914 %************************************************************************
 915 %*                                                                      *
 916 \subsection[fixpoint]{Fixpointer for the strictness analyser}
 917 %*                                                                      *
 918 %************************************************************************
 919
 920 The @fixpoint@ functions take a list of \tr{(binder, expr)} pairs, an
 921 environment, and returns the abstract value of each binder.
 922
 923 The @cheapFixpoint@ function makes a conservative approximation,
 924 by binding each of the variables to Top in their own right hand sides.
 925 That allows us to make rapid progress, at the cost of a less-than-wonderful
 926 approximation.
 927
 928 \begin{code}
 929 cheapFixpoint :: AnalysisKind -> [Id] -> [PlainCoreExpr] -> AbsValEnv -> [AbsVal]
 930
 931 cheapFixpoint AbsAnal [id] [rhs] env
 932   = [crudeAbsWiden (absEval AbsAnal rhs new_env)]
 933   where
 934     new_env = addOneToAbsValEnv env id AbsTop   -- Unsafe starting point!
 935                     -- In the just-one-binding case, we guarantee to
 936                     -- find a fixed point in just one iteration,
 937                     -- because we are using only a two-point domain.
 938                     -- This improves matters in cases like:
 939                     --
 940                     --  f x y = letrec g = ...g...
 941                     --          in g x
 942                     --
 943                     -- Here, y isn't used at all, but if g is bound to
 944                     -- AbsBot we simply get AbsBot as the next
 945                     -- iteration too.
 946
 947 cheapFixpoint anal ids rhss env
 948   = [widen anal (absEval anal rhs new_env) | rhs <- rhss]
 949                 -- We do just one iteration, starting from a safe
 950                 -- approximation.  This won't do a good job in situations
 951                 -- like:
 952                 --      \x -> letrec f = ...g...
 953                 --                   g = ...f...x...
 954                 --            in
 955                 --            ...f...
 956                 -- Here, f will end up bound to Top after one iteration,
 957                 -- and hence we won't spot the strictness in x.
 958                 -- (A second iteration would solve this.  ToDo: try the effect of
 959                 --  really searching for a fixed point.)
 960   where
 961     new_env = growAbsValEnvList env [(id,safe_val) | id <- ids]
 962
 963     safe_val
 964       = case anal of    -- The safe starting point
 965           StrAnal -> AbsTop
 966           AbsAnal -> AbsBot
 967 \end{code}
 968
 969 \begin{verbatim}
 970 mkLookupFun :: (key -> key -> Bool)     -- Equality predicate
 971             -> (key -> key -> Bool)     -- Less-than predicate
 972             -> [(key,val)]              -- The assoc list
 973             -> key                      -- The key
 974             -> Maybe val                -- The corresponding value
 975
 976 mkLookupFun eq lt alist s
 977   = case [a | (s',a) <- alist, s' `eq` s] of
 978       []    -> Nothing
 979       (a:_) -> Just a
 980 \end{verbatim}
 981
 982 \begin{code}
 983 fixpoint :: AnalysisKind -> [Id] -> [PlainCoreExpr] -> AbsValEnv -> [AbsVal]
 984
 985 fixpoint anal [] _ env = []
 986
 987 fixpoint anal ids rhss env
 988   = fix_loop initial_vals
 989   where
 990     initial_val id
 991       = case anal of    -- The (unsafe) starting point
 992           StrAnal -> if (returnsRealWorld (getIdUniType id))
 993                      then AbsTop -- this is a massively horrible hack (SLPJ 95/05)
 994                      else AbsBot
 995           AbsAnal -> AbsTop
 996
 997     initial_vals = [ initial_val id | id <- ids ]
 998
 999     fix_loop :: [AbsVal] -> [AbsVal]
1000
1001     fix_loop current_widened_vals
1002       = let
1003             new_env  = growAbsValEnvList env (ids `zip` current_widened_vals)
1004             new_vals = [ absEval anal rhs new_env | rhs <- rhss ]
1005             new_widened_vals = map (widen anal) new_vals
1006         in
1007         if (and (zipWith sameVal current_widened_vals new_widened_vals)) then
1008             current_widened_vals
1009
1010             -- Return the widened values.  We might get a slightly
1011             -- better value by returning new_vals (which we used to
1012             -- do, see below), but alas that means that whenever the
1013             -- function is called we have to re-execute it, which is
1014             -- expensive.
1015
1016             -- OLD VERSION
1017             -- new_vals
1018             -- Return the un-widened values which may be a bit better
1019             -- than the widened ones, and are guaranteed safe, since
1020             -- they are one iteration beyond current_widened_vals,
1021             -- which itself is a fixed point.
1022         else
1023             fix_loop new_widened_vals
1024 \end{code}
1025
1026 For absence analysis, we make do with a very very simple approach:
1027 look for convergence in a two-point domain.
1028
1029 We used to use just one iteration, starting with the variables bound
1030 to @AbsBot@, which is safe.
1031
1032 Prior to that, we used one iteration starting from @AbsTop@ (which
1033 isn't safe).  Why isn't @AbsTop@ safe?  Consider:
1034 \begin{verbatim}
1035         letrec
1036           x = ...p..d...
1037           d = (x,y)
1038         in
1039         ...
1040 \end{verbatim}
1041 Here, if p is @AbsBot@, then we'd better {\em not} end up with a ``fixed
1042 point'' of @d@ being @(AbsTop, AbsTop)@!  An @AbsBot@ initial value is
1043 safe because it gives poison more often than really necessary, and
1044 thus may miss some absence, but will never claim absence when it ain't
1045 so.
1046
1047 Anyway, one iteration starting with everything bound to @AbsBot@ give
1048 bad results for
1049
1050         f = \ x -> ...f...
1051
1052 Here, f would always end up bound to @AbsBot@, which ain't very
1053 clever, because then it would introduce poison whenever it was
1054 applied.  Much better to start with f bound to @AbsTop@, and widen it
1055 to @AbsBot@ if any poison shows up. In effect we look for convergence
1056 in the two-point @AbsTop@/@AbsBot@ domain.
1057
1058 What we miss (compared with the cleverer strictness analysis) is
1059 spotting that in this case
1060
1061         f = \ x y -> ...y...(f x y')...
1062
1063 \tr{x} is actually absent, since it is only passed round the loop, never
1064 used.  But who cares about missing that?
1065
1066 NB: despite only having a two-point domain, we may still have many
1067 iterations, because there are several variables involved at once.