Simplify.lhs 58.3 KB
 keithw committed May 15, 2000 1 %  simonm committed Dec 02, 1998 2 % (c) The AQUA Project, Glasgow University, 1993-1998  partain committed Jan 08, 1996 3 4 5 6 % \section[Simplify]{The main module of the simplifier} \begin{code}  simonpj committed May 18, 1999 7 module Simplify ( simplTopBinds, simplExpr ) where  partain committed Jan 08, 1996 8   simonm committed Jan 08, 1998 9 #include "HsVersions.h"  partain committed Jan 08, 1996 10   simonmar committed Jul 11, 2000 11 import CmdLineOpts ( switchIsOn, opt_SimplDoEtaReduction,  simonpj committed Aug 01, 2000 12  opt_SimplNoPreInlining,  simonpj committed Jan 11, 2001 13  dopt, DynFlag(Opt_D_dump_inlinings),  simonm committed Dec 02, 1998 14  SimplifierSwitch(..)  sof committed Sep 09, 1997 15  )  simonm committed Dec 02, 1998 16 import SimplMonad  simonpj committed Feb 26, 2001 17 import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion,  simonpj committed Mar 01, 2001 18  simplBinder, simplBinders, simplRecIds, simplLetId,  simonpj committed Sep 07, 2000 19  SimplCont(..), DupFlag(..), mkStop, mkRhsStop,  simonpj committed Aug 01, 2000 20 21  contResultType, discardInline, countArgs, contIsDupable, getContArgs, interestingCallContext, interestingArg, isStrictType  partain committed Apr 05, 1996 22  )  simonpj committed Mar 08, 2001 23 import Var ( mkSysTyVar, tyVarKind, mustHaveLocalBinding )  simonm committed Dec 02, 1998 24 import VarEnv  simonpj committed Mar 08, 2001 25 import Literal ( Literal )  simonpj committed Feb 20, 2001 26 import Id ( Id, idType, idInfo, isDataConId, hasNoBinding,  simonpj committed Mar 23, 2000 27  idUnfolding, setIdUnfolding, isExportedId, isDeadBinder,  simonmar committed Jul 11, 2000 28  idDemandInfo, setIdInfo,  simonpj committed Feb 20, 2001 29  idOccInfo, setIdOccInfo,  simonpj committed Aug 01, 2000 30  zapLamIdInfo, setOneShotLambda,  partain committed Apr 05, 1996 31  )  simonpj committed Sep 07, 2000 32 import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker,  simonpj committed Dec 07, 2000 33 34  setArityInfo, setUnfoldingInfo, atLeastArity,  simonmar committed Jul 11, 2000 35  occInfo  simonm committed Dec 02, 1998 36  )  simonpj committed Oct 25, 2000 37 import Demand ( isStrict )  simonmar committed Jul 11, 2000 38 import DataCon ( dataConNumInstArgs, dataConRepStrictness,  simonpj committed Mar 23, 2000 39 40  dataConSig, dataConArgTys )  simonm committed Dec 02, 1998 41 import CoreSyn  simonpj committed Jan 11, 2001 42 import PprCore ( pprParendExpr, pprCoreExpr )  simonmar committed Jul 11, 2000 43 44 import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline  simonpj committed Jun 22, 1999 45  )  simonmar committed Nov 16, 2000 46 import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial,  simonpj committed Feb 26, 2001 47  exprIsConApp_maybe, mkPiType, findAlt, findDefault,  simonpj committed Dec 07, 2000 48 49  exprType, coreAltsType, exprIsValue, exprOkForSpeculation, exprArity, exprIsCheap,  simonpj committed Mar 27, 2000 50  mkCoerce, mkSCC, mkInlineMe, mkAltExpr  simonm committed Jan 08, 1998 51  )  simonpj committed May 18, 1999 52 import Rules ( lookupRule )  simonmar committed Jul 11, 2000 53 54 import CostCentre ( currentCCS ) import Type ( mkTyVarTys, isUnLiftedType, seqType,  simonpj committed Nov 15, 2000 55  mkFunTy, splitTyConApp_maybe, tyConAppArgs,  simonpj committed Mar 08, 2001 56  funResultTy, splitFunTy_maybe, splitFunTy  simonpj committed May 18, 1999 57  )  simonpj committed Mar 08, 2001 58 import Subst ( mkSubst, substTy, substEnv, substExpr,  simonpj committed Mar 01, 2001 59  isInScope, lookupIdSubst, simplIdInfo  simonpj committed Dec 18, 1998 60  )  simonpj committed Aug 01, 2000 61 import TyCon ( isDataTyCon, tyConDataConsIfAvailable )  simonm committed Dec 02, 1998 62 import TysPrim ( realWorldStatePrimTy )  simonpj committed May 18, 1999 63 import PrelInfo ( realWorldPrimId )  simonpj committed Dec 07, 2000 64 import OrdList  simonm committed Dec 02, 1998 65 import Maybes ( maybeToBool )  simonpj committed Aug 01, 2000 66 import Util ( zipWithEqual )  simonm committed Dec 02, 1998 67 import Outputable  partain committed Jan 08, 1996 68 69 70 \end{code}  simonm committed Dec 02, 1998 71 The guts of the simplifier is in this module, but the driver  simonpj committed May 18, 1999 72 73 74 loop for the simplifier is in SimplCore.lhs.  simonpj committed Aug 01, 2000 75 76 77 78 79 80 81 82 83 84 ----------------------------------------- *** IMPORTANT NOTE *** ----------------------------------------- The simplifier used to guarantee that the output had no shadowing, but it does not do so any more. (Actually, it never did!) The reason is documented with simplifyArgs.  simonpj committed May 18, 1999 85 86 87 88 89 90 91 92 93 94 95 96 97 98 %************************************************************************ %* * \subsection{Bindings} %* * %************************************************************************ \begin{code} simplTopBinds :: [InBind] -> SimplM [OutBind] simplTopBinds binds = -- Put all the top-level binders into scope at the start -- so that if a transformation rule has unexpectedly brought -- anything into scope, then we don't get a complaint about that. -- It's rather as if the top-level binders were imported.  simonpj committed Mar 01, 2001 99  simplRecIds (bindersOfBinds binds) $\ bndrs' ->  simonpj committed Nov 01, 1999 100 101  simpl_binds binds bndrs' thenSmpl \ (binds', _) -> freeTick SimplifierDone thenSmpl_  simonpj committed Dec 07, 2000 102  returnSmpl (fromOL binds')  simonpj committed May 18, 1999 103 104  where  simonpj committed Nov 01, 1999 105 106  -- We need to track the zapped top-level binders, because -- they should have their fragile IdInfo zapped (notably occurrence info)  simonpj committed Dec 07, 2000 107  simpl_binds [] bs = ASSERT( null bs ) returnSmpl (nilOL, panic "simplTopBinds corner")  simonpj committed Nov 01, 1999 108 109 110 111  simpl_binds (NonRec bndr rhs : binds) (b:bs) = simplLazyBind True bndr b rhs (simpl_binds binds bs) simpl_binds (Rec pairs : binds) bs = simplRecBind True pairs (take n bs) (simpl_binds binds (drop n bs)) where n = length pairs  simonpj committed Jul 14, 1999 112   simonpj committed Nov 01, 1999 113 simplRecBind :: Bool -> [(InId, InExpr)] -> [OutId]  simonpj committed May 18, 1999 114 115  -> SimplM (OutStuff a) -> SimplM (OutStuff a) simplRecBind top_lvl pairs bndrs' thing_inside  simonpj committed Dec 07, 2000 116 117  = go pairs bndrs' thenSmpl \ (binds', (_, (binds'', res))) -> returnSmpl (unitOL (Rec (flattenBinds (fromOL binds'))) appOL binds'', res)  simonpj committed May 18, 1999 118 119  where go [] _ = thing_inside thenSmpl \ stuff ->  simonpj committed Dec 07, 2000 120  returnOutStuff stuff  simonpj committed May 18, 1999 121 122 123 124 125 126  go ((bndr, rhs) : pairs) (bndr' : bndrs') = simplLazyBind top_lvl bndr bndr' rhs (go pairs bndrs') -- Don't float unboxed bindings out, -- because we can't "rec" them \end{code}  partain committed Jan 08, 1996 127 128 129 130 131 132 133 134  %************************************************************************ %* * \subsection[Simplify-simplExpr]{The main function: simplExpr} %* * %************************************************************************  simonpj committed Dec 18, 1998 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 The reason for this OutExprStuff stuff is that we want to float *after* simplifying a RHS, not before. If we do so naively we get quadratic behaviour as things float out. To see why it's important to do it after, consider this (real) example: let t = f x in fst t ==> let t = let a = e1 b = e2 in (a,b) in fst t ==> let a = e1 b = e2 t = (a,b) in a -- Can't inline a this round, cos it appears twice ==> e1 Each of the ==> steps is a round of simplification. We'd save a whole round if we float first. This can cascade. Consider let f = g d in \x -> ...f... ==> let f = let d1 = ..d.. in \y -> e in \x -> ...f... ==> let d1 = ..d.. in \x -> ...(\y ->e)... Only in this second round can the \y be applied, and it might do the same again.  partain committed Jan 08, 1996 173 \begin{code}  simonpj committed May 18, 1999 174 175 simplExpr :: CoreExpr -> SimplM CoreExpr simplExpr expr = getSubst thenSmpl \ subst ->  simonpj committed Sep 07, 2000 176  simplExprC expr (mkStop (substTy subst (exprType expr)))  simonpj committed May 18, 1999 177 178  -- The type in the Stop continuation is usually not used -- It's only needed when discarding continuations after finding  simonpj committed Jul 14, 1999 179 180  -- a function that returns bottom. -- Hence the lazy substitution  partain committed Jan 08, 1996 181   simonpj committed May 18, 1999 182 183 simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr -- Simplify an expression, given a continuation  simonpj committed Dec 18, 1998 184   simonpj committed May 18, 1999 185 simplExprC expr cont = simplExprF expr cont thenSmpl \ (floats, (_, body)) ->  simonpj committed Dec 07, 2000 186  returnSmpl (wrapFloats floats body)  partain committed Jan 08, 1996 187   simonpj committed May 18, 1999 188 189 simplExprF :: InExpr -> SimplCont -> SimplM OutExprStuff -- Simplify an expression, returning floated binds  partain committed Jan 08, 1996 190   simonpj committed Mar 08, 2001 191 192 193 194 simplExprF (Var v) cont = simplVar v cont simplExprF (Lit lit) cont = simplLit lit cont simplExprF expr@(Lam _ _) cont = simplLam expr cont simplExprF (Note note expr) cont = simplNote note expr cont  simonm committed Dec 02, 1998 195   simonpj committed May 18, 1999 196 simplExprF (App fun arg) cont  simonm committed Dec 02, 1998 197  = getSubstEnv thenSmpl \ se ->  simonpj committed May 18, 1999 198  simplExprF fun (ApplyTo NoDup arg se cont)  simonm committed Dec 02, 1998 199   simonpj committed Mar 08, 2001 200 201 202 203 204 simplExprF (Type ty) cont = ASSERT( case cont of { Stop _ _ -> True; ArgOf _ _ _ -> True; other -> False } ) simplType ty thenSmpl \ ty' -> rebuild (Type ty') cont  simonpj committed May 18, 1999 205 simplExprF (Case scrut bndr alts) cont  simonpj committed Mar 24, 2000 206  = getSubstEnv thenSmpl \ subst_env ->  simonpj committed Mar 23, 2000 207  getSwitchChecker thenSmpl \ chkr ->  simonpj committed Mar 24, 2000 208 209 210 211  if not (switchIsOn chkr NoCaseOfCase) then -- Simplify the scrutinee with a Select continuation simplExprF scrut (Select NoDup bndr alts subst_env cont)  simonpj committed Mar 23, 2000 212  else  simonpj committed Mar 24, 2000 213 214 215  -- If case-of-case is off, simply simplify the case expression -- in a vanilla Stop context, and rebuild the result around it simplExprC scrut (Select NoDup bndr alts subst_env  simonpj committed Sep 07, 2000 216  (mkStop (contResultType cont))) thenSmpl \ case_expr' ->  simonpj committed Mar 24, 2000 217  rebuild case_expr' cont  simonpj committed May 18, 1999 218 219  simplExprF (Let (Rec pairs) body) cont  simonpj committed Mar 01, 2001 220  = simplRecIds (map fst pairs)$ \ bndrs' ->  simonpj committed May 18, 1999 221 222  -- NB: bndrs' don't have unfoldings or spec-envs -- We add them as we go down, using simplPrags  simonm committed Dec 02, 1998 223   simonpj committed Nov 01, 1999 224  simplRecBind False pairs bndrs' (simplExprF body cont)  simonpj committed May 18, 1999 225   simonpj committed Mar 01, 2001 226 -- A non-recursive let is dealt with by simplNonRecBind  simonpj committed May 18, 1999 227 228 simplExprF (Let (NonRec bndr rhs) body) cont = getSubstEnv thenSmpl \ se ->  simonpj committed Mar 01, 2001 229  simplNonRecBind bndr rhs se (contResultType cont) $ simonpj committed May 18, 1999 230 231 232 233  simplExprF body cont ---------------------------------  simonpj committed Mar 08, 2001 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 simplType :: InType -> SimplM OutType simplType ty = getSubst thenSmpl \ subst -> let new_ty = substTy subst ty in seqType new_ty seq returnSmpl new_ty --------------------------------- simplLit :: Literal -> SimplCont -> SimplM OutExprStuff simplLit lit (Select _ bndr alts se cont) = knownCon (Lit lit) (LitAlt lit) [] bndr alts se cont simplLit lit cont = rebuild (Lit lit) cont \end{code} %************************************************************************ %* * \subsection{Lambdas} %* * %************************************************************************  simonpj committed May 18, 1999 258 259 260 261  \begin{code} simplLam fun cont = go fun cont  partain committed Jan 08, 1996 262  where  simonpj committed Nov 01, 1999 263  zap_it = mkLamBndrZapper fun cont  simonpj committed May 18, 1999 264 265 266 267 268  cont_ty = contResultType cont -- Type-beta reduction go (Lam bndr body) (ApplyTo _ (Type ty_arg) arg_se body_cont) = ASSERT( isTyVar bndr )  simonpj committed Mar 23, 2000 269 270 271  tick (BetaReduction bndr) thenSmpl_ simplTyArg ty_arg arg_se thenSmpl \ ty_arg' -> extendSubst bndr (DoneTy ty_arg')  simonpj committed May 18, 1999 272 273 274 275 276  (go body body_cont) -- Ordinary beta reduction go (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont) = tick (BetaReduction bndr) thenSmpl_  simonpj committed Mar 01, 2001 277  simplNonRecBind zapped_bndr arg arg_se cont_ty  simonpj committed May 18, 1999 278 279 280 281 282 283 284 285 286  (go body body_cont) where zapped_bndr = zap_it bndr -- Not enough args go lam@(Lam _ _) cont = completeLam [] lam cont -- Exactly enough args go expr cont = simplExprF expr cont  partain committed Jan 08, 1996 287   simonpj committed May 18, 1999 288 -- completeLam deals with the case where a lambda doesn't have an ApplyTo  simonpj committed Sep 07, 2000 289 290 291 292 293 294 295 296 -- continuation, so there are real lambdas left to put in the result -- We try for eta reduction here, but *only* if we get all the -- way to an exprIsTrivial expression. -- We don't want to remove extra lambdas unless we are going -- to avoid allocating this thing altogether completeLam rev_bndrs (Lam bndr body) cont  simonm committed Dec 02, 1998 297  = simplBinder bndr$ \ bndr' ->  simonpj committed Sep 07, 2000 298  completeLam (bndr':rev_bndrs) body cont  partain committed Jan 08, 1996 299   simonpj committed Sep 07, 2000 300 completeLam rev_bndrs body cont  simonpj committed May 18, 1999 301  = simplExpr body thenSmpl \ body' ->  simonpj committed Sep 07, 2000 302 303 304 305 306 307  case try_eta body' of Just etad_lam -> tick (EtaReduction (head rev_bndrs)) thenSmpl_ rebuild etad_lam cont Nothing -> rebuild (foldl (flip Lam) body' rev_bndrs) cont where  simonpj committed Dec 01, 2000 308  -- We don't use CoreUtils.etaReduce, because we can be more  simonpj committed Feb 20, 2001 309 310 311 312 313 314  -- efficient here: -- (a) we already have the binders, -- (b) we can do the triviality test before computing the free vars -- [in fact I take the simple path and look for just a variable] -- (c) we don't want to eta-reduce a data con worker or primop -- because we only have to eta-expand them later when we saturate  simonpj committed Sep 07, 2000 315 316 317 318 319 320 321  try_eta body | not opt_SimplDoEtaReduction = Nothing | otherwise = go rev_bndrs body go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round go [] body | ok_body body = Just body -- Success! go _ _ = Nothing -- Failure!  simonpj committed Feb 20, 2001 322 323 324  ok_body (Var v) = not (v elem rev_bndrs) && not (hasNoBinding v) ok_body other = False ok_arg b arg = varToCoreExpr b cheapEqExpr arg  simonpj committed May 18, 1999 325 326  mkLamBndrZapper :: CoreExpr -- Function  simonpj committed Nov 01, 1999 327  -> SimplCont -- The context  simonpj committed May 18, 1999 328  -> Id -> Id -- Use this to zap the binders  simonpj committed Nov 01, 1999 329 mkLamBndrZapper fun cont  simonmar committed May 26, 1999 330  | n_args >= n_params fun = \b -> b -- Enough args  simonpj committed Nov 01, 1999 331  | otherwise = \b -> zapLamIdInfo b  simonpj committed May 18, 1999 332  where  simonpj committed Nov 01, 1999 333 334 335 336 337 338 339  -- NB: we count all the args incl type args -- so we must count all the binders (incl type lambdas) n_args = countArgs cont n_params (Note _ e) = n_params e n_params (Lam b e) = 1 + n_params e n_params other = 0::Int  partain committed Jan 08, 1996 340 341 \end{code}  simonpj committed May 18, 1999 342   simonpj committed Mar 08, 2001 343 344 345 346 347 348 %************************************************************************ %* * \subsection{Notes} %* * %************************************************************************  sof committed May 18, 1997 349 \begin{code}  simonpj committed Mar 08, 2001 350 351 simplNote (Coerce to from) body cont = getInScope thenSmpl \ in_scope ->  simonpj committed Jul 14, 1999 352  let  simonpj committed Mar 08, 2001 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385  addCoerce s1 k1 (CoerceIt t1 cont) -- coerce T1 S1 (coerce S1 K1 e) -- ==> -- e, if T1=K1 -- coerce T1 K1 e, otherwise -- -- For example, in the initial form of a worker -- we may find (coerce T (coerce S (\x.e))) y -- and we'd like it to simplify to e[y/x] in one round -- of simplification | t1 == k1 = cont -- The coerces cancel out | otherwise = CoerceIt t1 cont -- They don't cancel, but -- the inner one is redundant addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont) | Just (s1, s2) <- splitFunTy_maybe s1s2 -- (coerce (T1->T2) (S1->S2) F) E -- ===> -- coerce T2 S2 (F (coerce S1 T1 E)) -- -- t1t2 must be a function type, T1->T2 -- but s1s2 might conceivably not be -- -- When we build the ApplyTo we can't mix the out-types -- with the InExpr in the argument, so we simply substitute -- to make it all consistent. This isn't a common case. = let (t1,t2) = splitFunTy t1t2 new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope arg_se) arg) in ApplyTo dup new_arg emptySubstEnv (addCoerce t2 s2 cont) addCoerce to' _ cont = CoerceIt to' cont  simonpj committed Jul 14, 1999 386  in  simonpj committed Mar 08, 2001 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443  simplType to thenSmpl \ to' -> simplType from thenSmpl \ from' -> simplExprF body (addCoerce to' from' cont) -- Hack: we only distinguish subsumed cost centre stacks for the purposes of -- inlining. All other CCCSs are mapped to currentCCS. simplNote (SCC cc) e cont = setEnclosingCC currentCCS $simplExpr e thenSmpl \ e -> rebuild (mkSCC cc e) cont simplNote InlineCall e cont = simplExprF e (InlinePlease cont) -- Comments about the InlineMe case -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Don't inline in the RHS of something that has an -- inline pragma. But be careful that the InScopeEnv that -- we return does still have inlinings on! -- -- It really is important to switch off inlinings. This function -- may be inlinined in other modules, so we don't want to remove -- (by inlining) calls to functions that have specialisations, or -- that may have transformation rules in an importing scope. -- E.g. {-# INLINE f #-} -- f x = ...g... -- and suppose that g is strict *and* has specialisations. -- If we inline g's wrapper, we deny f the chance of getting -- the specialised version of g when f is inlined at some call site -- (perhaps in some other module). -- It's also important not to inline a worker back into a wrapper. -- A wrapper looks like -- wraper = inline_me (\x -> ...worker... ) -- Normally, the inline_me prevents the worker getting inlined into -- the wrapper (initially, the worker's only call site!). But, -- if the wrapper is sure to be called, the strictness analyser will -- mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf -- continuation. That's why the keep_inline predicate returns True for -- ArgOf continuations. It shouldn't do any harm not to dissolve the -- inline-me note under these circumstances simplNote InlineMe e cont | keep_inline cont -- Totally boring continuation = -- Don't inline inside an INLINE expression setBlackList noInlineBlackList (simplExpr e) thenSmpl \ e' -> rebuild (mkInlineMe e') cont | otherwise -- Dissolve the InlineMe note if there's -- an interesting context of any kind to combine with -- (even a type application -- anything except Stop) = simplExprF e cont where keep_inline (Stop _ _) = True -- See notes above keep_inline (ArgOf _ _ _) = True -- about this predicate keep_inline other = False  partain committed Jan 08, 1996 444 445 446 \end{code}  simonm committed Dec 02, 1998 447 448 %************************************************************************ %* *  simonpj committed May 18, 1999 449 \subsection{Binding}  simonm committed Dec 02, 1998 450 451 %* * %************************************************************************  partain committed Jan 08, 1996 452   simonpj committed Mar 01, 2001 453 @simplNonRecBind@ is used for non-recursive lets in expressions,  simonpj committed May 18, 1999 454 as well as true beta reduction.  partain committed Jun 26, 1996 455   simonpj committed May 18, 1999 456 Very similar to @simplLazyBind@, but not quite the same.  simonm committed Dec 02, 1998 457   simonpj committed May 18, 1999 458 \begin{code}  simonpj committed Mar 01, 2001 459 simplNonRecBind :: InId -- Binder  simonpj committed May 18, 1999 460 461 462 463  -> InExpr -> SubstEnv -- Arg, with its subst-env -> OutType -- Type of thing computed by the context -> SimplM OutExprStuff -- The body -> SimplM OutExprStuff  simonm committed Dec 02, 1998 464 #ifdef DEBUG  simonpj committed Mar 01, 2001 465 simplNonRecBind bndr rhs rhs_se cont_ty thing_inside  simonpj committed May 18, 1999 466  | isTyVar bndr  simonpj committed Mar 01, 2001 467  = pprPanic "simplNonRecBind" (ppr bndr <+> ppr rhs)  simonm committed Dec 02, 1998 468 #endif  partain committed Jan 08, 1996 469   simonpj committed Mar 01, 2001 470 simplNonRecBind bndr rhs rhs_se cont_ty thing_inside  simonpj committed Nov 01, 1999 471  | preInlineUnconditionally False {- not black listed -} bndr  simonpj committed May 18, 1999 472 473  = tick (PreInlineUnconditionally bndr) thenSmpl_ extendSubst bndr (ContEx rhs_se rhs) thing_inside  partain committed Jan 08, 1996 474   simonm committed Dec 02, 1998 475  | otherwise  simonpj committed Mar 01, 2001 476 477 478 479 480  = -- Simplify the binder. -- Don't use simplBinder because that doesn't keep -- fragile occurrence in the substitution simplLetId bndr$ \ bndr' -> getSubst thenSmpl \ bndr_subst ->  simonpj committed Aug 01, 2000 481  let  simonpj committed Mar 01, 2001 482 483 484 485 486  -- Substitute its IdInfo (which simplLetId does not) -- The appropriate substitution env is the one right here, -- not rhs_se. Often they are the same, when all this -- has arisen from an application (\x. E) RHS, perhaps they aren't bndr'' = simplIdInfo bndr_subst (idInfo bndr) bndr'  simonpj committed Aug 01, 2000 487 488 489  bndr_ty' = idType bndr' is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty' in  simonpj committed Mar 01, 2001 490 491 492  modifyInScope bndr'' bndr'' $-- Simplify the argument  simonpj committed Aug 01, 2000 493  simplValArg bndr_ty' is_strict rhs rhs_se cont_ty$ \ rhs' ->  simonpj committed May 18, 1999 494 495  -- Now complete the binding and simplify the body  simonpj committed Aug 01, 2000 496  if needsCaseBinding bndr_ty' rhs' then  simonpj committed Mar 01, 2001 497  addCaseBind bndr'' rhs' thing_inside  simonpj committed Mar 23, 2000 498  else  simonpj committed Mar 01, 2001 499  completeBinding bndr bndr'' False False rhs' thing_inside  simonpj committed May 18, 1999 500 \end{code}  simonm committed Dec 02, 1998 501 502   simonpj committed May 18, 1999 503 \begin{code}  simonpj committed Mar 23, 2000 504 505 506 507 508 509 510 511 512 simplTyArg :: InType -> SubstEnv -> SimplM OutType simplTyArg ty_arg se = getInScope thenSmpl \ in_scope -> let ty_arg' = substTy (mkSubst in_scope se) ty_arg in seqType ty_arg' seq returnSmpl ty_arg'  simonpj committed Aug 01, 2000 513 514 simplValArg :: OutType -- rhs_ty: Type of arg; used only occasionally -> Bool -- True <=> evaluate eagerly  simonpj committed Mar 23, 2000 515  -> InExpr -> SubstEnv  simonpj committed Aug 01, 2000 516 517 518 519 520 521 522 523  -> OutType -- cont_ty: Type of thing computed by the context -> (OutExpr -> SimplM OutExprStuff) -- Takes an expression of type rhs_ty, -- returns an expression of type cont_ty -> SimplM OutExprStuff -- An expression of type cont_ty simplValArg arg_ty is_strict arg arg_se cont_ty thing_inside | is_strict  simonpj committed Sep 07, 2000 524  = getEnv thenSmpl \ env ->  simonpj committed Sep 17, 1999 525  setSubstEnv arg_se $ simonpj committed Sep 07, 2000 526  simplExprF arg (ArgOf NoDup cont_ty$ \ rhs' ->  simonpj committed Sep 17, 1999 527  setAllExceptInScope env $ simonpj committed Sep 07, 2000 528  thing_inside rhs')  simonm committed Dec 02, 1998 529   simonpj committed May 18, 1999 530  | otherwise  simonpj committed Nov 01, 1999 531 532  = simplRhs False {- Not top level -} True {- OK to float unboxed -}  simonpj committed Sep 17, 1999 533 534  arg_ty arg arg_se thing_inside  simonpj committed May 18, 1999 535 \end{code}  simonm committed Dec 02, 1998 536 537   simonpj committed May 18, 1999 538 539 540 completeBinding - deals only with Ids, not TyVars - take an already-simplified RHS  simonm committed Dec 02, 1998 541   simonpj committed May 18, 1999 542 It does *not* attempt to do let-to-case. Why? Because they are used for  partain committed Jan 08, 1996 543   simonpj committed May 18, 1999 544 545  - top-level bindings (when let-to-case is impossible)  partain committed Jan 08, 1996 546   simonpj committed May 18, 1999 547 548  - many situations where the "rhs" is known to be a WHNF (so let-to-case is inappropriate).  partain committed Jan 08, 1996 549 550  \begin{code}  simonpj committed May 18, 1999 551 552 completeBinding :: InId -- Binder -> OutId -- New binder  simonpj committed Nov 01, 1999 553  -> Bool -- True <=> top level  simonpj committed Aug 31, 1999 554  -> Bool -- True <=> black-listed; don't inline  simonpj committed May 18, 1999 555 556 557  -> OutExpr -- Simplified RHS -> SimplM (OutStuff a) -- Thing inside -> SimplM (OutStuff a)  simonm committed Dec 02, 1998 558   simonpj committed Nov 01, 1999 559 completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside  simonpj committed Sep 07, 2000 560 561 562  | isDeadOcc occ_info -- This happens; for example, the case_bndr during case of -- known constructor: case (a,b) of x { (p,q) -> ... } -- Here x isn't mentioned in the RHS, so we don't want to  simonpj committed May 18, 1999 563 564  -- create the (dead) let-binding let x = (a,b) in ... = thing_inside  simonm committed Dec 02, 1998 565   simonpj committed Dec 07, 2000 566  | trivial_rhs && not must_keep_binding  simonpj committed Sep 14, 2000 567 568 569  -- We're looking at a binding with a trivial RHS, so -- perhaps we can discard it altogether! --  simonpj committed Jan 03, 2001 570  -- NB: a loop breaker has must_keep_binding = True  simonpj committed Sep 14, 2000 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589  -- and non-loop-breakers only have *forward* references -- Hence, it's safe to discard the binding -- -- NOTE: This isn't our last opportunity to inline. -- We're at the binding site right now, and -- we'll get another opportunity when we get to the ocurrence(s) -- Note that we do this unconditional inlining only for trival RHSs. -- Don't inline even WHNFs inside lambdas; doing so may -- simply increase allocation when the function is called -- This isn't the last chance; see NOTE above. -- -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here -- Why? Because we don't even want to inline them into the -- RHS of constructor arguments. See NOTE above -- -- NB: Even NOINLINEis ignored here: if the rhs is trivial -- it's best to inline it anyway. We often get a=E; b=a -- from desugaring, with both a and b marked NOINLINE.  simonpj committed Dec 07, 2000 590 591  = -- Drop the binding extendSubst old_bndr (DoneEx new_rhs)$  simonpj committed Sep 14, 2000 592 593  -- Use the substitution to make quite, quite sure that the substitution -- will happen, since we are going to discard the binding  simonpj committed Dec 07, 2000 594 595  tick (PostInlineUnconditionally old_bndr) thenSmpl_ thing_inside  simonpj committed Sep 07, 2000 596   simonpj committed Dec 07, 2000 597  | Note coercion@(Coerce _ inner_ty) inner_rhs <- new_rhs,  simonpj committed Jan 02, 2001 598  not trivial_rhs && not (isUnLiftedType inner_ty)  simonpj committed Sep 07, 2000 599 600 601 602 603 604 605  -- x = coerce t e ==> c = e; x = inline_me (coerce t c) -- Now x can get inlined, which moves the coercion -- to the usage site. This is a bit like worker/wrapper stuff, -- but it's useful to do it very promptly, so that -- x = coerce T (I# 3) -- get's w/wd to -- c = I# 3  simonpj committed Sep 14, 2000 606  -- x = coerce T c  simonpj committed Sep 07, 2000 607 608 609 610  -- This in turn means that -- case (coerce Int x) of ... -- will inline x. -- Also the full-blown w/w thing isn't set up for non-functions  simonpj committed May 18, 1999 611  --  simonpj committed Jan 02, 2001 612 613 614 615 616 617 618 619 620 621  -- The (not (isUnLiftedType inner_ty)) avoids the nasty case of -- x::Int = coerce Int Int# (foo y) -- ==> -- v::Int# = foo y -- x::Int = coerce Int Int# v -- which would be bogus because then v will be evaluated strictly. -- How can this arise? Via -- x::Int = case (foo y) of { ... } -- followed by case elimination. --  simonpj committed Sep 07, 2000 622 623 624 625 626  -- The inline_me note is so that the simplifier doesn't -- just substitute c back inside x's rhs! (Typically, x will -- get substituted away, but not if it's exported.) = newId SLIT("c") inner_ty $\ c_id -> completeBinding c_id c_id top_lvl False inner_rhs$  simonpj committed Sep 14, 2000 627 628  completeBinding old_bndr new_bndr top_lvl black_listed (Note InlineMe (Note coercion (Var c_id))) $ simonpj committed Sep 07, 2000 629 630  thing_inside  simonm committed Dec 02, 1998 631  | otherwise  simonpj committed Mar 01, 2001 632  = let  simonpj committed Sep 14, 2000 633 634 635  -- We make new IdInfo for the new binder by starting from the old binder, -- doing appropriate substitutions. -- Then we add arity and unfolding info to get the new binder  simonpj committed Mar 01, 2001 636  new_bndr_info = idInfo new_bndr setArityInfo arity_info  simonpj committed Sep 14, 2000 637 638 639 640 641 642  -- Add the unfolding *only* for non-loop-breakers -- Making loop breakers not have an unfolding at all -- means that we can avoid tests in exprIsConApp, for example. -- This is important: if exprIsConApp says 'yes' for a recursive -- thing, then we can get into an infinite loop  simonpj committed Dec 07, 2000 643 644  info_w_unf | loop_breaker = new_bndr_info | otherwise = new_bndr_info setUnfoldingInfo mkUnfolding top_lvl new_rhs  simonpj committed Sep 14, 2000 645   simonpj committed Dec 07, 2000 646 647  final_id = new_bndr setIdInfo info_w_unf in  simonpj committed Sep 14, 2000 648 649  -- These seqs forces the Id, and hence its IdInfo, -- and hence any inner substitutions  simonpj committed Dec 07, 2000 650 651 652 653 654 655 656 657 658 659 660  final_id seq addLetBind (NonRec final_id new_rhs)$ modifyInScope new_bndr final_id thing_inside where old_info = idInfo old_bndr occ_info = occInfo old_info loop_breaker = isLoopBreaker occ_info trivial_rhs = exprIsTrivial new_rhs must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr arity_info = atLeastArity (exprArity new_rhs)  simonpj committed May 18, 1999 661 \end{code}  partain committed Jan 08, 1996 662   partain committed Mar 19, 1996 663   simonpj committed Sep 07, 2000 664   simonm committed Dec 02, 1998 665 666 %************************************************************************ %* *  simonpj committed May 18, 1999 667 \subsection{simplLazyBind}  simonm committed Dec 02, 1998 668 669 %* * %************************************************************************  simonpj committed Sep 26, 1997 670   simonpj committed May 18, 1999 671 simplLazyBind basically just simplifies the RHS of a let(rec).  simonm committed Dec 02, 1998 672 It does two important optimisations though:  simonpj committed Sep 26, 1997 673   simonm committed Dec 02, 1998 674 675  * It floats let(rec)s out of the RHS, even if they are hidden by big lambdas  simonpj committed Sep 26, 1997 676   simonm committed Dec 02, 1998 677  * It does eta expansion  simonpj committed Sep 26, 1997 678   simonm committed Dec 02, 1998 679 \begin{code}  simonpj committed Nov 01, 1999 680 simplLazyBind :: Bool -- True <=> top level  simonpj committed May 18, 1999 681 682 683 684 685 686 687 688 689  -> InId -> OutId -> InExpr -- The RHS -> SimplM (OutStuff a) -- The body of the binding -> SimplM (OutStuff a) -- When called, the subst env is correct for the entire let-binding -- and hence right for the RHS. -- Also the binder has already been simplified, and hence is in scope simplLazyBind top_lvl bndr bndr' rhs thing_inside  simonpj committed Aug 31, 1999 690  = getBlackList thenSmpl \ black_list_fn ->  simonpj committed Nov 01, 1999 691 692  let black_listed = black_list_fn bndr  simonpj committed Aug 31, 1999 693  in  simonpj committed Nov 01, 1999 694 695 696 697 698  if preInlineUnconditionally black_listed bndr then -- Inline unconditionally tick (PreInlineUnconditionally bndr) thenSmpl_ getSubstEnv thenSmpl \ rhs_se ->  simonpj committed Aug 31, 1999 699  (extendSubst bndr (ContEx rhs_se rhs) thing_inside)  simonpj committed Nov 01, 1999 700  else  simonpj committed May 18, 1999 701   simonpj committed Nov 01, 1999 702  -- Simplify the RHS  simonpj committed Mar 01, 2001 703 704 705 706 707 708 709 710 711  getSubst thenSmpl \ rhs_subst -> let -- Substitute IdInfo on binder, in the light of earlier -- substitutions in this very letrec, and extend the in-scope -- env so that it can see the new thing bndr'' = simplIdInfo rhs_subst (idInfo bndr) bndr' in modifyInScope bndr'' bndr'' $ simonpj committed Aug 01, 2000 712  simplRhs top_lvl False {- Not ok to float unboxed (conservative) -}  simonpj committed Nov 01, 1999 713  (idType bndr')  simonpj committed Mar 01, 2001 714  rhs (substEnv rhs_subst)$ \ rhs' ->  simonpj committed May 18, 1999 715 716  -- Now compete the binding and simplify the body  simonpj committed Mar 01, 2001 717  completeBinding bndr bndr'' top_lvl black_listed rhs' thing_inside  simonm committed Dec 02, 1998 718 \end{code}  simonpj committed Sep 26, 1997 719 720 721   simonm committed Dec 02, 1998 722 \begin{code}  simonpj committed Nov 01, 1999 723 simplRhs :: Bool -- True <=> Top level  simonpj committed May 18, 1999 724  -> Bool -- True <=> OK to float unboxed (speculative) bindings  simonpj committed Dec 07, 2000 725  -- False for (a) recursive and (b) top-level bindings  simonpj committed Aug 01, 2000 726 727  -> OutType -- Type of RHS; used only occasionally -> InExpr -> SubstEnv  simonpj committed May 18, 1999 728 729 730  -> (OutExpr -> SimplM (OutStuff a)) -> SimplM (OutStuff a) simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside  simonpj committed Sep 07, 2000 731  = -- Simplify it  simonpj committed Dec 07, 2000 732  setSubstEnv rhs_se (simplExprF rhs (mkRhsStop rhs_ty)) thenSmpl \ (floats1, (rhs_in_scope, rhs1)) ->  simonpj committed May 18, 1999 733  let  simonpj committed Dec 07, 2000 734  (floats2, rhs2) = splitFloats float_ubx floats1 rhs1  simonpj committed May 18, 1999 735 736 737 738 739 740 741  in -- There's a subtlety here. There may be a binding (x* = e) in the -- floats, where the '*' means 'will be demanded'. So is it safe -- to float it out? Answer no, but it won't matter because -- we only float if arg' is a WHNF, -- and so there can't be any 'will be demanded' bindings in the floats. -- Hence the assert  simonpj committed Dec 07, 2000 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765  WARN( any demanded_float (fromOL floats2), ppr (fromOL floats2) ) -- Transform the RHS -- It's important that we do eta expansion on function *arguments* (which are -- simplified with simplRhs), as well as let-bound right-hand sides. -- Otherwise we find that things like -- f (\x -> case x of I# x' -> coerce T (\ y -> ...)) -- get right through to the code generator as two separate lambdas, -- which is a Bad Thing tryRhsTyLam rhs2 thenSmpl \ (floats3, rhs3) -> tryEtaExpansion rhs3 rhs_ty thenSmpl \ (floats4, rhs4) -> -- Float lets if (a) we're at the top level -- or (b) the resulting RHS is one we'd like to expose if (top_lvl || exprIsCheap rhs4) then (if (isNilOL floats2 && null floats3 && null floats4) then returnSmpl () else tick LetFloatFromLet) thenSmpl_ addFloats floats2 rhs_in_scope $addAuxiliaryBinds floats3$ addAuxiliaryBinds floats4 $thing_inside rhs4  simonpj committed May 18, 1999 766 767  else -- Don't do the float  simonpj committed Dec 07, 2000 768  thing_inside (wrapFloats floats1 rhs1)  simonpj committed May 18, 1999 769   simonpj committed Mar 23, 2000 770 demanded_float (NonRec b r) = isStrict (idDemandInfo b) && not (isUnLiftedType (idType b))  simonpj committed May 18, 1999 771 772 773  -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them demanded_float (Rec _) = False  simonpj committed Aug 01, 2000 774 775 776 777 778 779 -- If float_ubx is true we float all the bindings, otherwise -- we just float until we come across an unlifted one. -- Remember that the unlifted bindings in the floats are all for -- guaranteed-terminating non-exception-raising unlifted things, -- which we are happy to do speculatively. However, we may still -- not be able to float them out, because the context  simonpj committed May 18, 1999 780 781 -- is either a Rec group, or the top level, neither of which -- can tolerate them.  simonpj committed Aug 01, 2000 782 783 splitFloats float_ubx floats rhs | float_ubx = (floats, rhs) -- Float them all  simonpj committed Dec 07, 2000 784  | otherwise = go (fromOL floats)  simonm committed Dec 02, 1998 785  where  simonpj committed Dec 07, 2000 786 787  go [] = (nilOL, rhs) go (f:fs) | must_stay f = (nilOL, mkLets (f:fs) rhs)  simonpj committed May 18, 1999 788  | otherwise = case go fs of  simonpj committed Dec 07, 2000 789  (out, rhs') -> (f consOL out, rhs')  simonpj committed Sep 26, 1997 790   simonpj committed May 18, 1999 791 792  must_stay (Rec prs) = False -- No unlifted bindings in here must_stay (NonRec b r) = isUnLiftedType (idType b)  partain committed Jan 08, 1996 793 794 795 \end{code}  simonpj committed May 18, 1999 796   simonpj committed Mar 19, 1998 797 798 %************************************************************************ %* *  simonpj committed May 18, 1999 799 \subsection{Variables}  simonpj committed Mar 19, 1998 800 801 802 803 %* * %************************************************************************ \begin{code}  simonpj committed May 18, 1999 804 simplVar var cont  simonpj committed Jul 14, 1999 805  = getSubst thenSmpl \ subst ->  simonpj committed Nov 01, 1999 806 807 808  case lookupIdSubst subst var of DoneEx e -> zapSubstEnv (simplExprF e cont) ContEx env1 e -> setSubstEnv env1 (simplExprF e cont)  simonpj committed May 25, 2000 809  DoneId var1 occ -> WARN( not (isInScope var1 subst) && mustHaveLocalBinding var1,  simonpj committed Nov 01, 1999 810  text "simplVar:" <+> ppr var )  simonpj committed Mar 23, 2000 811  zapSubstEnv (completeCall var1 occ cont)  simonpj committed Jun 22, 1999 812 813 814 815 816 817 818 819  -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider -- let x = e in -- let y = \z -> ...x... in -- \ x -> ...y... -- We'll clone the inner \x, adding x->x' in the id_subst -- Then when we inline y, we must *not* replace x by x' in -- the inlined copy!!  simonpj committed Sep 17, 1999 820   simonpj committed Mar 23, 2000 821 822 823 --------------------------------------------------------- -- Dealing with a call  simonpj committed Jan 03, 2001 824 completeCall var occ_info cont  simonpj committed Aug 01, 2000 825 826 827  = getBlackList thenSmpl \ black_list_fn -> getInScope thenSmpl \ in_scope -> getContArgs var cont thenSmpl \ (args, call_cont, inline_call) ->  sewardj committed Oct 19, 2000 828  getDOptsSmpl thenSmpl \ dflags ->  simonpj committed Mar 23, 2000 829  let  simonpj committed Mar 24, 2000 830  black_listed = black_list_fn var  simonpj committed Aug 01, 2000 831 832 833 834 835 836  arg_infos = [ interestingArg in_scope arg subst | (arg, subst, _) <- args, isValArg arg] interesting_cont = interestingCallContext (not (null args)) (not (null arg_infos)) call_cont  simonpj committed Mar 24, 2000 837   simonpj committed Aug 01, 2000 838 839  inline_cont | inline_call = discardInline cont | otherwise = cont  simonpj committed Mar 23, 2000 840   simonpj committed Jan 03, 2001 841  maybe_inline = callSiteInline dflags black_listed inline_call occ_info  simonpj committed Mar 23, 2000 842 843 844 845 846 847  var arg_infos interesting_cont in -- First, look for an inlining case maybe_inline of { Just unfolding -- There is an inlining! -> tick (UnfoldingDone var) thenSmpl_  simonpj committed Aug 01, 2000 848  simplExprF unfolding inline_cont  simonpj committed Mar 23, 2000 849 850 851 852  ; Nothing -> -- No inlining!  simonpj committed Aug 01, 2000 853 854 855  simplifyArgs (isDataConId var) args (contResultType call_cont)$ \ args' ->  simonpj committed Mar 23, 2000 856  -- Next, look for rules or specialisations that match  simonpj committed Sep 17, 1999 857 858 859 860 861 862 863 864 865 866 867 868  -- -- It's important to simplify the args first, because the rule-matcher -- doesn't do substitution as it goes. We don't want to use subst_args -- (defined in the 'where') because that throws away useful occurrence info, -- and perhaps-very-important specialisations. -- -- Some functions have specialisations *and* are strict; in this case, -- we don't want to inline the wrapper of the non-specialised thing; better -- to call the specialised thing instead. -- But the black-listing mechanism means that inlining of the wrapper -- won't occur for things that have specialisations till a later phase, so -- it's ok to try for inlining first.  simonpj committed Jan 03, 2001 869  --  simonpj committed Jan 04, 2001 870 871 872 873 874 875 876 877 878 879 880  -- You might think that we shouldn't apply rules for a loop breaker: -- doing so might give rise to an infinite loop, because a RULE is -- rather like an extra equation for the function: -- RULE: f (g x) y = x+y -- Eqn: f a y = a-y -- -- But it's too drastic to disable rules for loop breakers. -- Even the foldr/build rule would be disabled, because foldr -- is recursive, and hence a loop breaker: -- foldr k z (build g) = g k z -- So it's up to the programmer: rules can cause divergence  simonpj committed Mar 23, 2000 881   simonpj committed Aug 01, 2000 882  getSwitchChecker thenSmpl \ chkr ->  simonpj committed Mar 23, 2000 883  let  simonpj committed Jan 04, 2001 884  maybe_rule | switchIsOn chkr DontApplyRules = Nothing  simonpj committed Aug 01, 2000 885  | otherwise = lookupRule in_scope var args'  simonpj committed Mar 23, 2000 886 887  in case maybe_rule of {  simonpj committed Jan 04, 2000 888  Just (rule_name, rule_rhs) ->  simonpj committed Sep 17, 1999 889  tick (RuleFired rule_name) thenSmpl_  simonpj committed Jan 11, 2001 890 891 892 893 894 895 896 897 898 #ifdef DEBUG (if dopt Opt_D_dump_inlinings dflags then pprTrace "Rule fired" (vcat [ text "Rule:" <+> ptext rule_name, text "Before:" <+> ppr var <+> sep (map pprParendExpr args'), text "After: " <+> pprCoreExpr rule_rhs]) else id) $#endif  simonpj committed Aug 01, 2000 899  simplExprF rule_rhs call_cont ;  simonpj committed Sep 17, 1999 900   simonpj committed Mar 23, 2000 901  Nothing -> -- No rules  simonpj committed Mar 19, 1998 902   simonpj committed Mar 23, 2000 903  -- Done  simonpj committed Aug 01, 2000 904  rebuild (mkApps (Var var) args') call_cont  simonpj committed Mar 23, 2000 905  }}  simonpj committed Jun 22, 1999 906 907   simonpj committed May 18, 1999 908 ---------------------------------------------------------  simonpj committed Aug 01, 2000 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 -- Simplifying the arguments of a call simplifyArgs :: Bool -- It's a data constructor -> [(InExpr, SubstEnv, Bool)] -- Details of the arguments -> OutType -- Type of the continuation -> ([OutExpr] -> SimplM OutExprStuff) -> SimplM OutExprStuff -- Simplify the arguments to a call. -- This part of the simplifier may break the no-shadowing invariant -- Consider -- f (...(\a -> e)...) (case y of (a,b) -> e') -- where f is strict in its second arg -- If we simplify the innermost one first we get (...(\a -> e)...) -- Simplifying the second arg makes us float the case out, so we end up with -- case y of (a,b) -> f (...(\a -> e)...) e' -- So the output does not have the no-shadowing invariant. However, there is -- no danger of getting name-capture, because when the first arg was simplified -- we used an in-scope set that at least mentioned all the variables free in its -- static environment, and that is enough. -- -- We can't just do innermost first, or we'd end up with a dual problem: -- case x of (a,b) -> f e (...(\a -> e')...) -- -- I spent hours trying to recover the no-shadowing invariant, but I just could -- not think of an elegant way to do it. The simplifier is already knee-deep in -- continuations. We have to keep the right in-scope set around; AND we have -- to get the effect that finding (error "foo") in a strict arg position will -- discard the entire application and replace it with (error "foo"). Getting -- all this at once is TOO HARD! simplifyArgs is_data_con args cont_ty thing_inside | not is_data_con = go args thing_inside | otherwise -- It's a data constructor, so we want -- to switch off inlining in the arguments  simonpj committed Mar 23, 2000 946 947 948 949  -- If we don't do this, consider: -- let x = +# p q in C {x} -- Even though x get's an occurrence of 'many', its RHS looks cheap, -- and there's a good chance it'll get inlined back into C's RHS. Urgh!  simonpj committed Aug 01, 2000 950 951 952 953 954  = getBlackList thenSmpl \ old_bl -> setBlackList noInlineBlackList$ go args $\ args' -> setBlackList old_bl$ thing_inside args'  simonpj committed Mar 23, 2000 955   simonpj committed Aug 01, 2000 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994  where go [] thing_inside = thing_inside [] go (arg:args) thing_inside = simplifyArg is_data_con arg cont_ty $\ arg' -> go args$ \ args' -> thing_inside (arg':args') simplifyArg is_data_con (Type ty_arg, se, _) cont_ty thing_inside = simplTyArg ty_arg se thenSmpl \ new_ty_arg -> thing_inside (Type new_ty_arg) simplifyArg is_data_con (val_arg, se, is_strict) cont_ty thing_inside = getInScope thenSmpl \ in_scope -> let arg_ty = substTy (mkSubst in_scope se) (exprType val_arg) in if not is_data_con then -- An ordinary function simplValArg arg_ty is_strict val_arg se cont_ty thing_inside else -- A data constructor -- simplifyArgs has already switched off inlining, so -- all we have to do here is to let-bind any non-trivial argument -- It's not always the case that new_arg will be trivial -- Consider f x -- where, in one pass, f gets substituted by a constructor, -- but x gets substituted by an expression (assume this is the -- unique occurrence of x). It doesn't really matter -- it'll get -- fixed up next pass. And it happens for dictionary construction, -- which mentions the wrapper constructor to start with. simplValArg arg_ty is_strict val_arg se cont_ty $\ arg' -> if exprIsTrivial arg' then thing_inside arg' else newId SLIT("a") (exprType arg')$ \ arg_id -> addNonRecBind arg_id arg' \$ thing_inside (Var arg_id) \end{code}  simonpj committed May 18, 1999 995   simonpj committed Mar 23, 2000 996   simonpj committed May 18, 1999 997 998 999 1000 1001 %************************************************************************ %* * \subsection{Decisions about inlining} %* * %************************************************************************  simonpj committed Mar 19, 1998 1002   simonpj committed Nov 01, 1999 1003 1004 1005 1006 1007 NB: At one time I tried not pre/post-inlining top-level things, even if they occur exactly once. Reason: (a) some might appear as a function argument, so we simply replace static allocation with dynamic allocation: l = <...>  simonmar committed Nov 07, 2000 1008  x = f l  simonpj committed Nov 01, 1999 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019  becomes x = f <...> (b) some top level things might be black listed HOWEVER, I found that some useful foldr/build fusion was lost (most notably in spectral/hartel/parstof) because the foldr didn't see the build. Doing the dynamic allocation isn't a big deal, in fact, but losing the fusion can be.  simonpj committed Mar 19, 1998 1020 \begin{code}  simonpj committed Nov 01, 1999 1021 preInlineUnconditionally :: Bool {- Black listed -} -> InId -> Bool  simonm committed Dec 02, 1998 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038  -- Examines a bndr to see if it is used just once in a -- completely safe way, so that it is safe to discard the binding -- inline its RHS at the (unique) usage site, REGARDLESS of how -- big the RHS might be. If this is the case we don't simplify -- the RHS first, but just inline it un-simplified. -- -- This is much better than first simplifying a perhaps-huge RHS -- and then inlining and re-simplifying it. -- -- NB: we don't even look at the RHS to see if it's trivial -- We might have -- x = y -- where x is used many times, but this is the unique occurrence -- of y. We should NOT inline x at all its uses, because then -- we'd do the same for y -- aargh! So we must base this -- pre-rhs-simplification decision solely on x's occurrences, not -- on its rhs.  simonpj committed May 18, 1999 1039 1040 1041  -- -- Evne RHSs labelled InlineMe aren't caught here, because -- there might be no benefit from inlining at the call site.  simonpj committed Nov 01, 1999 1042 1043 1044  preInlineUnconditionally black_listed bndr | black_listed || opt_SimplNoPreInlining = False  simonpj committed Mar 23, 2000 1045  | otherwise = case idOccInfo bndr of  simonpj committed Nov 01, 1999 1046 1047 1048  OneOcc in_lam once -> not in_lam && once -- Not inside a lambda, one occurrence ==> safe! other -> False  simonpj committed May 18, 1999 1049 \end{code}  simonm committed Dec 02, 1998 1050   partain committed Jan 08, 1996 1051   simonpj committed Jan 28, 1999 1052   simonm committed Dec 02, 1998 1053 1054 1055 1056 1057 %************************************************************************ %* * \subsection{The main rebuilder} %* * %************************************************************************  partain committed Jan 08, 1996 1058   simonm committed Dec 02, 1998 1059 1060 \begin{code} -------------------------------------------------------------------  simonpj committed May 18, 1999 1061 -- Finish rebuilding  simonpj committed Dec 07, 2000 1062 rebuild_done expr = returnOutStuff expr  partain committed Jan 08, 1996 1063   simonm committed Dec 02, 1998 1064 ---------------------------------------------------------  simonpj committed May 18, 1999