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