CorePrep.hs 65.9 KB
 Austin Seipp committed Dec 03, 2014 1 2 3 {- (c) The University of Glasgow, 1994-2006  Simon Marlow committed Oct 11, 2006 4 5  Core pass to saturate constructors and PrimOps  Austin Seipp committed Dec 03, 2014 6 -}  simonmar committed Dec 06, 2000 7   Ben Gamari committed Nov 02, 2016 8 {-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}  Ian Lynagh committed Nov 04, 2011 9   simonmar committed Mar 13, 2001 10 module CorePrep (  Sylvain Henry committed Jun 15, 2018 11 12 13  corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural, lookupMkIntegerName, lookupIntegerSDataConName, lookupMkNaturalName, lookupNaturalSDataConName  simonmar committed Dec 06, 2000 14 15 16 17  ) where #include "HsVersions.h"  Herbert Valerio Riedel committed Sep 19, 2017 18 19 import GhcPrelude  nfrisby committed Mar 28, 2013 20 21 import OccurAnal  Ian Lynagh committed Jun 06, 2012 22 import HscTypes  Ian Lynagh committed Sep 13, 2011 23 import PrelNames  Ben Gamari committed Nov 12, 2015 24 import MkId ( realWorldPrimId )  simonpj@microsoft.com committed Jan 13, 2009 25 26 import CoreUtils import CoreArity  Simon Marlow committed Oct 11, 2006 27 import CoreFVs  Simon Peyton Jones committed Dec 15, 2014 28 29 import CoreMonad ( CoreToDo(..) ) import CoreLint ( endPassIO )  simonmar committed Dec 06, 2000 30 import CoreSyn  simonpj@microsoft.com committed Jun 14, 2010 31 import CoreSubst  Simon Peyton Jones committed Jan 12, 2012 32 import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here  Simon Marlow committed Oct 11, 2006 33 import Type  Ian Lynagh committed Sep 13, 2011 34 import Literal  Simon Marlow committed Oct 11, 2006 35 import Coercion  Ian Lynagh committed Jun 06, 2012 36 import TcEnv  Simon Marlow committed Oct 11, 2006 37 import TyCon  simonpj@microsoft.com committed Nov 19, 2009 38 import Demand  Simon Marlow committed Oct 11, 2006 39 import Var  simonmar committed Dec 06, 2000 40 import VarSet  simonmar committed Mar 13, 2001 41 import VarEnv  Simon Marlow committed Oct 11, 2006 42 import Id  andy@galois.com committed Nov 29, 2006 43 import IdInfo  Simon Peyton Jones committed Sep 14, 2011 44 import TysWiredIn  Simon Marlow committed Oct 11, 2006 45 46 import DataCon import BasicTypes  ian@well-typed.com committed May 19, 2013 47 import Module  simonmar committed Dec 06, 2000 48 49 import UniqSupply import Maybes  simonpj committed Feb 20, 2001 50 import OrdList  simonmar committed Dec 06, 2000 51 import ErrUtils  simonmar committed Mar 18, 2005 52 import DynFlags  Simon Marlow committed Oct 11, 2006 53 import Util  54 import Pair  simonmar committed Dec 06, 2000 55 import Outputable  ian@well-typed.com committed Aug 29, 2012 56 import Platform  Ian Lynagh committed Mar 29, 2008 57 import FastString  Ian Lynagh committed Sep 13, 2011 58 import Config  Peter Wortmann committed Dec 16, 2014 59 60 import Name ( NamedThing(..), nameSrcSpan ) import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )  Ian Lynagh committed Sep 13, 2011 61 import Data.Bits  Simon Peyton Jones committed Aug 26, 2015 62 import MonadUtils ( mapAccumLM )  Ömer Sinan Ağacan committed Feb 13, 2018 63 import Data.List ( mapAccumL, foldl' )  simonpj@microsoft.com committed Jan 13, 2009 64 import Control.Monad  Ömer Sinan Ağacan committed Feb 13, 2018 65 66 import CostCentre ( CostCentre, ccFromThisModule ) import qualified Data.Set as S  simonmar committed Dec 06, 2000 67   Austin Seipp committed Dec 03, 2014 68 {-  simonmar committed Dec 06, 2000 69 -- ---------------------------------------------------------------------------  Ömer Sinan Ağacan committed Feb 13, 2018 70 -- Note [CorePrep Overview]  simonmar committed Dec 06, 2000 71 -- ---------------------------------------------------------------------------  simonmar committed Dec 06, 2000 72   simonmar committed Mar 13, 2001 73 The goal of this pass is to prepare for code generation.  simonmar committed Dec 06, 2000 74   simonpj committed Feb 20, 2001 75 1. Saturate constructor and primop applications.  simonmar committed Dec 06, 2000 76   chak@cse.unsw.edu.au. committed Aug 04, 2006 77 78 2. Convert to A-normal form; that is, function arguments are always variables.  simonmar committed Dec 06, 2000 79   simonpj committed Feb 20, 2001 80  * Use case for strict arguments:  Ian Lynagh committed May 29, 2012 81 82  f E ==> case E of x -> f x (where f is strict)  simonmar committed Dec 06, 2000 83   simonpj committed Feb 20, 2001 84  * Use let for non-trivial lazy arguments  Ian Lynagh committed May 29, 2012 85 86  f E ==> let x = E in f x (were f is lazy and x is non-trivial)  simonmar committed Dec 06, 2000 87   simonpj committed Feb 20, 2001 88 3. Similarly, convert any unboxed lets into cases.  Ian Lynagh committed May 29, 2012 89  [I'm experimenting with leaving 'ok-for-speculation'  simonpj committed Feb 20, 2001 90  rhss in let-form right up to this point.]  simonmar committed Dec 06, 2000 91   simonpj@microsoft.com committed Dec 30, 2008 92 4. Ensure that *value* lambdas only occur as the RHS of a binding  simonmar committed Dec 06, 2000 93  (The code generator can't deal with anything else.)  simonpj@microsoft.com committed Dec 30, 2008 94  Type lambdas are ok, however, because the code gen discards them.  simonmar committed Dec 06, 2000 95   simonpj committed Jun 18, 2002 96 5. [Not any more; nuked Jun 2002] Do the seq/par munging.  simonpj committed Feb 26, 2001 97   simonpj committed Oct 25, 2001 98 6. Clone all local Ids.  Ian Lynagh committed May 29, 2012 99  This means that all such Ids are unique, rather than the  simonpj committed Oct 25, 2001 100 101 102  weaker guarantee of no clashes which the simplifier provides. And that is what the code generator needs.  Ian Lynagh committed May 29, 2012 103  We don't clone TyVars or CoVars. The code gen doesn't need that,  simonpj committed Oct 25, 2001 104  and doing so would be tiresome because then we'd need  105  to substitute in types and coercions.  simonpj committed Oct 25, 2001 106   simonmar committed Mar 13, 2001 107 108 109 7. Give each dynamic CCall occurrence a fresh unique; this is rather like the cloning step above.  simonpj committed Oct 18, 2001 110 8. Inject bindings for the "implicit" Ids:  Ian Lynagh committed May 29, 2012 111 112  * Constructor wrappers * Constructor workers  simonpj committed Oct 18, 2001 113 114  We want curried definitions for all of these in case they aren't inlined by some caller.  Ian Lynagh committed May 29, 2012 115   rodlogic committed Feb 09, 2015 116 9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.hs  Edward Z. Yang committed Aug 21, 2016 117  Also replace (noinline e) by e.  simonpj@microsoft.com committed May 29, 2009 118   Ian Lynagh committed Jun 06, 2012 119 120 10. Convert (LitInteger i t) into the core representation for the Integer i. Normally this uses mkInteger, but if  Ian Lynagh committed Sep 25, 2011 121 122 123 124  we are using the integer-gmp implementation then there is a special case where we use the S# constructor for Integers that are in the range of Int.  Sylvain Henry committed Jun 15, 2018 125 126 127 11. Same for LitNatural. 12. Uphold tick consistency while doing this: We move ticks out of  Peter Wortmann committed Dec 16, 2014 128 129 130  (non-type) applications where we can, and make sure that we annotate according to scoping rules when floating.  Sylvain Henry committed Jun 15, 2018 131 13. Collect cost centres (including cost centres in unfoldings) if we're in  Ömer Sinan Ağacan committed Feb 13, 2018 132 133 134  profiling mode. We have to do this here beucase we won't have unfoldings after this pass (see zapUnfolding and Note [Drop unfoldings and rules].  simonpj committed Feb 20, 2001 135 136 137 This is all done modulo type applications and abstractions, so that when type erasure is done for conversion to STG, we don't end up with any trivial or useless bindings.  simonmar committed Mar 13, 2001 138   Ian Lynagh committed May 29, 2012 139   Simon Peyton Jones committed Nov 02, 2016 140 141 Note [CorePrep invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~  simonpj@microsoft.com committed Jan 13, 2009 142 Here is the syntax of the Core produced by CorePrep:  simonmar committed Dec 06, 2000 143   Ian Lynagh committed May 29, 2012 144  Trivial expressions  Simon Peyton Jones committed Nov 02, 2016 145 146 147  arg ::= lit | var | arg ty | /\a. arg | truv co | /\c. arg | arg |> co  simonpj@microsoft.com committed Jan 13, 2009 148 149  Applications  Simon Peyton Jones committed Nov 02, 2016 150  app ::= lit | var | app arg | app ty | app co | app |> co  simonpj@microsoft.com committed Jan 13, 2009 151 152  Expressions  Ian Lynagh committed May 29, 2012 153  body ::= app  simonpj@microsoft.com committed Jan 13, 2009 154 155  | let(rec) x = rhs in body -- Boxed only | case body of pat -> body  Ian Lynagh committed May 29, 2012 156  | /\a. body | /\c. body  simonpj@microsoft.com committed Jan 13, 2009 157 158  | body |> co  159  Right hand sides (only place where value lambdas can occur)  simonpj@microsoft.com committed Jan 13, 2009 160 161 162 163  rhs ::= /\a.rhs | \x.rhs | body We define a synonym for each of these non-terminals. Functions with the corresponding name produce a result in that syntax.  Austin Seipp committed Dec 03, 2014 164 -}  simonpj@microsoft.com committed Jan 13, 2009 165   Simon Peyton Jones committed Nov 02, 2016 166 type CpeArg = CoreExpr -- Non-terminal 'arg'  Ian Lynagh committed May 29, 2012 167 168 169 type CpeApp = CoreExpr -- Non-terminal 'app' type CpeBody = CoreExpr -- Non-terminal 'body' type CpeRhs = CoreExpr -- Non-terminal 'rhs'  simonpj@microsoft.com committed Jan 13, 2009 170   Austin Seipp committed Dec 03, 2014 171 172 173 {- ************************************************************************ * *  Ian Lynagh committed May 29, 2012 174  Top level stuff  Austin Seipp committed Dec 03, 2014 175 176 177 * * ************************************************************************ -}  simonmar committed Dec 06, 2000 178   Ben Gamari committed Mar 24, 2016 179 corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]  Ömer Sinan Ağacan committed Feb 13, 2018 180  -> IO (CoreProgram, S.Set CostCentre)  Ben Gamari committed Mar 24, 2016 181 182 183 184 corePrepPgm hsc_env this_mod mod_loc binds data_tycons = withTiming (pure dflags) (text "CorePrep"<+>brackets (ppr this_mod)) (const ()) $do  twanvl committed Jan 17, 2008 185  us <- mkSplitUniqSupply 's'  ian@well-typed.com committed Aug 29, 2012 186  initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env  twanvl committed Jan 17, 2008 187   Ömer Sinan Ağacan committed Feb 13, 2018 188 189 190 191 192 193 194  let cost_centres | WayProf elem ways dflags = collectCostCentres this_mod binds | otherwise = S.empty implicit_binds = mkDataConWorkers dflags mod_loc data_tycons  twanvl committed Jan 17, 2008 195 196 197 198  -- NB: we must feed mkImplicitBinds through corePrep too -- so that they are suitably cloned and eta-expanded binds_out = initUs_ us$ do  Ian Lynagh committed Jun 06, 2012 199 200  floats1 <- corePrepTopBinds initialCorePrepEnv binds floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds  twanvl committed Jan 17, 2008 201 202  return (deFloatTop (floats1 appendFloats floats2))  Simon Peyton Jones committed Nov 04, 2014 203  endPassIO hsc_env alwaysQualify CorePrep binds_out []  Ömer Sinan Ağacan committed Feb 13, 2018 204  return (binds_out, cost_centres)  Ben Gamari committed Mar 24, 2016 205 206  where dflags = hsc_dflags hsc_env  simonmar committed Dec 06, 2000 207   Ian Lynagh committed Jun 06, 2012 208 corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr  Ben Gamari committed Mar 24, 2016 209 210 corePrepExpr dflags hsc_env expr = withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $do  twanvl committed Jan 17, 2008 211  us <- mkSplitUniqSupply 's'  ian@well-typed.com committed Aug 29, 2012 212  initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env  Ian Lynagh committed Jun 06, 2012 213  let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)  twanvl committed Jan 17, 2008 214 215  dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) return new_expr  simonpj committed Oct 18, 2001 216   Ian Lynagh committed Jun 06, 2012 217 corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats  simonpj@microsoft.com committed Jan 13, 2009 218 -- Note [Floating out of top level bindings]  Ian Lynagh committed Jun 06, 2012 219 220 corePrepTopBinds initialCorePrepEnv binds = go initialCorePrepEnv binds  simonpj@microsoft.com committed Jan 13, 2009 221 222  where go _ [] = return emptyFloats  lukemaurer committed Feb 01, 2017 223 224 225 226 227 228 229  go env (bind : binds) = do (env', floats, maybe_new_bind) <- cpeBind TopLevel env bind MASSERT(isNothing maybe_new_bind) -- Only join points get returned this way by -- cpeBind, and no join point may float to top floatss <- go env' binds return (floats appendFloats floatss)  simonpj committed Oct 18, 2001 230   Peter Wortmann committed Dec 16, 2014 231 mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]  simonpj@microsoft.com committed Jan 13, 2009 232 -- See Note [Data constructor workers]  Gergő Érdi committed May 27, 2014 233 -- c.f. Note [Injecting implicit bindings] in TidyPgm  Peter Wortmann committed Dec 16, 2014 234 235 236 mkDataConWorkers dflags mod_loc data_tycons = [ NonRec id (tick_it (getName data_con) (Var id)) -- The ice is thin here, but it works  Ian Lynagh committed May 29, 2012 237  | tycon <- data_tycons, -- CorePrep will eta-expand it  simonpj@microsoft.com committed Jan 13, 2009 238  data_con <- tyConDataCons tycon,  Peter Wortmann committed Dec 16, 2014 239 240 241 242 243 244  let id = dataConWorkId data_con ] where -- If we want to generate debug info, we put a source note on the -- worker. This is useful, especially for heap profiling. tick_it name  Ben Gamari committed Nov 23, 2015 245  | debugLevel dflags == 0 = id  Peter Wortmann committed Dec 16, 2014 246 247 248 249 250  | RealSrcSpan span <- nameSrcSpan name = tick span | Just file <- ml_hs_file mod_loc = tick (span1 file) | otherwise = tick (span1 "???") where tick span = Tick (SourceNote span$ showSDoc dflags (ppr name)) span1 file = realSrcLocSpan $mkRealSrcLoc (mkFastString file) 1 1  simonpj@microsoft.com committed Jan 13, 2009 251   Austin Seipp committed Dec 03, 2014 252 {-  simonpj@microsoft.com committed Jan 13, 2009 253 254 255 Note [Floating out of top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: we do need to float out of top-level bindings  Ian Lynagh committed May 29, 2012 256 Consider x = length [True,False]  simonpj@microsoft.com committed Jan 13, 2009 257 We want to get  Ian Lynagh committed May 29, 2012 258 259 260  s1 = False : [] s2 = True : s1 x = length s2  simonpj@microsoft.com committed Jan 13, 2009 261 262  We return a *list* of bindings, because we may start with  Ian Lynagh committed May 29, 2012 263  x* = f (g y)  simonpj@microsoft.com committed Jan 13, 2009 264 where x is demanded, in which case we want to finish with  Ian Lynagh committed May 29, 2012 265 266  a = g y x* = f a  simonpj@microsoft.com committed Jan 13, 2009 267 268 269 270 And then x will actually end up case-bound Note [CafInfo and floating] ~~~~~~~~~~~~~~~~~~~~~~~~~~~  simonpj@microsoft.com committed Sep 22, 2010 271 What happens when we try to float bindings to the top level? At this  simonpj@microsoft.com committed Jun 14, 2010 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 point all the CafInfo is supposed to be correct, and we must make certain that is true of the new top-level bindings. There are two cases to consider a) The top-level binding is marked asCafRefs. In that case we are basically fine. The floated bindings had better all be lazy lets, so they can float to top level, but they'll all have HasCafRefs (the default) which is safe. b) The top-level binding is marked NoCafRefs. This really happens Example. CoreTidy produces$fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah... Now CorePrep has to eta-expand to $fApplicativeSTM = let sat = \xy. retry x y in D:Alternative sat ...blah... So what we *want* is sat [NoCafRefs] = \xy. retry x y$fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...  Ian Lynagh committed May 29, 2012 290   simonpj@microsoft.com committed Jun 14, 2010 291  So, gruesomely, we must set the NoCafRefs flag on the sat bindings,  Gabor Greif committed Feb 20, 2017 292  *and* substitute the modified 'sat' into the old RHS.  simonpj@microsoft.com committed Jun 14, 2010 293 294 295 296 297 298 299  It should be the case that 'sat' is itself [NoCafRefs] (a value, no cafs) else the original top-level binding would not itself have been marked [NoCafRefs]. The DEBUG check in CoreToStg for consistentCafInfo will find this. This is all very gruesome and horrible. It would be better to figure  Ian Lynagh committed May 29, 2012 300 out CafInfo later, after CorePrep. We'll do that in due course.  simonpj@microsoft.com committed Jun 14, 2010 301 302 Meanwhile this horrible hack works.  lukemaurer committed Feb 01, 2017 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 Note [Join points and floating] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Join points can float out of other join points but not out of value bindings: let z = let w = ... in -- can float join k = ... in -- can't float ... jump k ... join j x1 ... xn = let y = ... in -- can float (but don't want to) join h = ... in -- can float (but not much point) ... jump h ... in ... Here, the jump to h remains valid if h is floated outward, but the jump to k does not. We don't float *out* of join points. It would only be safe to float out of nullary join points (or ones where the arguments are all either type arguments or dead binders). Nullary join points aren't ever recursive, so they're always effectively one-shot functions, which we don't float out of. We *could* float join points from nullary join points, but there's no clear benefit at this stage.  simonpj@microsoft.com committed Jan 13, 2009 326 327 328  Note [Data constructor workers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  simonpj committed Apr 28, 2005 329 330 Create any necessary "implicit" bindings for data con workers. We create the rather strange (non-recursive!) binding  simonpj committed Oct 18, 2001 331   Ian Lynagh committed May 29, 2012 332  $wC = \x y ->$wC x y  simonpj committed Oct 18, 2001 333 334 335 336 337 338 339 340 341 342 343  i.e. a curried constructor that allocates. This means that we can treat the worker for a constructor like any other function in the rest of the compiler. The point here is that CoreToStg will generate a StgConApp for the RHS, rather than a call to the worker (which would give a loop). As Lennart says: the ice is thin here, but it works. Hmm. Should we create bindings for dictionary constructors? They are always fully applied, and the bindings are just there to support partial applications. But it's easier to let them through.  simonpj committed Sep 26, 2001 344   batterseapower committed Feb 19, 2011 345 346 Note [Dead code in CorePrep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~  Simon Peyton Jones committed Mar 27, 2013 347 Imagine that we got an input program like this (see Trac #4962):  batterseapower committed Feb 19, 2011 348 349 350 351 352 353 354 355 356 357 358 359 360  f :: Show b => Int -> (Int, b -> Maybe Int -> Int) f x = (g True (Just x) + g () (Just x), g) where g :: Show a => a -> Maybe Int -> Int g _ Nothing = x g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown After specialisation and SpecConstr, we would get something like this: f :: Show b => Int -> (Int, b -> Maybe Int -> Int) f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) where  Ian Lynagh committed May 29, 2012 361  {-# RULES g $dBool = g$Bool  batterseapower committed Feb 19, 2011 362 363 364 365 366 367 368 369 370  g $dUnit = g$Unit #-} g = ... {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} g$Bool = ... {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-} g$Unit = ... g$Bool_True_Just = ... g$Unit_Unit_Just = ...  Simon Marlow committed Oct 06, 2011 371 372 373 374 Note that the g$Bool and g$Unit functions are actually dead code: they are only kept alive by the occurrence analyser because they are referred to by the rules of g, which is being kept alive by the fact that it is used (unspecialised) in the returned pair.  batterseapower committed Feb 19, 2011 375   Simon Marlow committed Oct 06, 2011 376 377 378 379 However, at the CorePrep stage there is no way that the rules for g will ever fire, and it really seems like a shame to produce an output program that goes to the trouble of allocating a closure for the unreachable g$Bool and g$Unit functions.  batterseapower committed Feb 19, 2011 380 381 382  The way we fix this is to: * In cloneBndr, drop all unfoldings/rules  nfrisby committed Mar 28, 2013 383 384 385 386 387 388  * In deFloatTop, run a simple dead code analyser on each top-level RHS to drop the dead local bindings. For that call to OccAnal, we disable the binder swap, else the occurrence analyser sometimes introduces new let bindings for cased binders, which lead to the bug in #5433.  Simon Marlow committed Oct 06, 2011 389 390 391 392 393 394  The reason we don't just OccAnal the whole output of CorePrep is that the tidier ensures that all top-level binders are GlobalIds, so they don't show up in the free variables any longer. So if you run the occurrence analyser on the output of CoreTidy (or later) you e.g. turn this program:  batterseapower committed Feb 19, 2011 395 396 397 398 399 400 401 402 403 404 405 406  Rec { f = ... f ... } Into this one: f = ... f ... (Since f is not considered to be free in its own RHS.)  Austin Seipp committed Dec 03, 2014 407 408 ************************************************************************ * *  Ian Lynagh committed May 29, 2012 409  The main code  Austin Seipp committed Dec 03, 2014 410 411 412 * * ************************************************************************ -}  simonpj committed Feb 20, 2001 413   Simon Peyton Jones committed Jan 17, 2013 414 cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind  lukemaurer committed Feb 01, 2017 415 416 417 418  -> UniqSM (CorePrepEnv, Floats, -- Floating value bindings Maybe CoreBind) -- Just bind' <=> returned new bind; no float -- Nothing <=> added bind' to floats instead  simonpj@microsoft.com committed Jan 13, 2009 419 cpeBind top_lvl env (NonRec bndr rhs)  lukemaurer committed Feb 01, 2017 420  | not (isJoinId bndr)  Simon Peyton Jones committed Jun 30, 2011 421  = do { (_, bndr1) <- cpCloneBndr env bndr  Simon Peyton Jones committed Jun 06, 2013 422  ; let dmd = idDemandInfo bndr  Ömer Sinan Ağacan committed Jan 27, 2016 423  is_unlifted = isUnliftedType (idType bndr)  Simon Peyton Jones committed Jan 03, 2018 424 425 426  ; (floats, rhs1) <- cpePair top_lvl NonRecursive dmd is_unlifted env bndr1 rhs  Edward Z. Yang committed Jun 08, 2016 427  -- See Note [Inlining in CorePrep]  Simon Peyton Jones committed Jan 03, 2018 428 429  ; if exprIsTrivial rhs1 && isNotTopLevel top_lvl then return (extendCorePrepEnvExpr env bndr rhs1, floats, Nothing)  Edward Z. Yang committed Jun 08, 2016 430 431  else do {  Simon Peyton Jones committed Jan 03, 2018 432  ; let new_float = mkFloat dmd is_unlifted bndr1 rhs1  simonpj committed Oct 03, 2001 433   Simon Peyton Jones committed Jan 03, 2018 434  ; return (extendCorePrepEnv env bndr bndr1,  lukemaurer committed Feb 01, 2017 435 436  addFloat floats new_float, Nothing) }}  Simon Peyton Jones committed Jan 03, 2018 437 438  | otherwise -- A join point; see Note [Join points and floating]  lukemaurer committed Feb 01, 2017 439 440 441 442 443 444  = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point do { (_, bndr1) <- cpCloneBndr env bndr ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs ; return (extendCorePrepEnv env bndr bndr2, emptyFloats, Just (NonRec bndr2 rhs1)) }  simonpj@microsoft.com committed Jan 13, 2009 445 446  cpeBind top_lvl env (Rec pairs)  lukemaurer committed Feb 01, 2017 447 448  | not (isJoinId (head bndrs)) = do { (env', bndrs1) <- cpCloneBndrs env bndrs  Simon Peyton Jones committed Jan 03, 2018 449 450  ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss  simonpj@microsoft.com committed Jan 13, 2009 451   Simon Peyton Jones committed Jan 03, 2018 452 453  ; let (floats_s, rhss1) = unzip stuff all_pairs = foldrOL add_float (bndrs1 zip rhss1)  Ian Lynagh committed May 29, 2012 454  (concatFloats floats_s)  Simon Peyton Jones committed Jan 03, 2018 455 456  ; return (extendCorePrepEnvList env (bndrs zip bndrs1),  lukemaurer committed Feb 01, 2017 457 458  unitFloat (FloatLet (Rec all_pairs)), Nothing) }  Simon Peyton Jones committed Jan 03, 2018 459   lukemaurer committed Feb 01, 2017 460 461 462 463 464 465 466 467  | otherwise -- See Note [Join points and floating] = do { (env', bndrs1) <- cpCloneBndrs env bndrs ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss ; let bndrs2 = map fst pairs1 ; return (extendCorePrepEnvList env' (bndrs zip bndrs2), emptyFloats, Just (Rec pairs1)) }  simonpj committed Oct 18, 2001 468  where  lukemaurer committed Feb 01, 2017 469 470  (bndrs, rhss) = unzip pairs  Gabor Greif committed Feb 08, 2017 471  -- Flatten all the floats, and the current  Ian Lynagh committed May 29, 2012 472  -- group into a single giant Rec  simonpj@microsoft.com committed Jan 13, 2009 473 474 475 476 477  add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 add_float b _ = pprPanic "cpeBind" (ppr b) ---------------  Simon Peyton Jones committed Jun 06, 2013 478 cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool  Simon Peyton Jones committed Jan 03, 2018 479 480  -> CorePrepEnv -> OutId -> CoreExpr -> UniqSM (Floats, CpeRhs)  simonpj@microsoft.com committed Jan 13, 2009 481 -- Used for all bindings  Simon Peyton Jones committed Jan 03, 2018 482 -- The binder is already cloned, hence an OutId  Simon Peyton Jones committed Jun 06, 2013 483 cpePair top_lvl is_rec dmd is_unlifted env bndr rhs  lukemaurer committed Feb 01, 2017 484 485  = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair do { (floats1, rhs1) <- cpeRhsE env rhs  simonpj@microsoft.com committed May 31, 2010 486   simonpj@microsoft.com committed Sep 22, 2010 487 488 489 490  -- See if we are allowed to float this stuff out of the RHS ; (floats2, rhs2) <- float_from_rhs floats1 rhs1 -- Make the arity match up  Peter Wortmann committed Dec 16, 2014 491  ; (floats3, rhs3)  Ian Lynagh committed May 29, 2012 492 493 494 495 496  <- if manifestArity rhs1 <= arity then return (floats2, cpeEtaExpand arity rhs2) else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) -- Note [Silly extra arguments] (do { v <- newVar (idType bndr)  Simon Peyton Jones committed Jun 06, 2013 497  ; let float = mkFloat topDmd False v rhs2  Ian Lynagh committed May 29, 2012 498  ; return ( addFloat floats2 float  Simon Peyton Jones committed Jul 27, 2011 499  , cpeEtaExpand arity (Var v)) })  simonpj@microsoft.com committed Jan 13, 2009 500   Peter Wortmann committed Dec 16, 2014 501 502 503  -- Wrap floating ticks ; let (floats4, rhs4) = wrapTicks floats3 rhs3  Simon Peyton Jones committed Jan 03, 2018 504  ; return (floats4, rhs4) }  simonpj@microsoft.com committed Jan 13, 2009 505  where  ian@well-typed.com committed Aug 29, 2012 506 507  platform = targetPlatform (cpe_dynFlags env)  Ian Lynagh committed May 29, 2012 508  arity = idArity bndr -- We must match this arity  simonpj@microsoft.com committed Jun 14, 2010 509 510  ---------------------  simonpj@microsoft.com committed Sep 22, 2010 511 512  float_from_rhs floats rhs | isEmptyFloats floats = return (emptyFloats, rhs)  Simon Peyton Jones committed Mar 25, 2016 513 514  | isTopLevel top_lvl = float_top floats rhs | otherwise = float_nested floats rhs  simonpj@microsoft.com committed Jun 14, 2010 515 516  ---------------------  simonpj@microsoft.com committed Sep 22, 2010 517  float_nested floats rhs  Simon Peyton Jones committed Mar 25, 2016 518  | wantFloatNested is_rec dmd is_unlifted floats rhs  simonpj@microsoft.com committed Sep 22, 2010 519  = return (floats, rhs)  Simon Peyton Jones committed Mar 25, 2016 520  | otherwise = dontFloat floats rhs  simonpj@microsoft.com committed Jun 14, 2010 521 522  ---------------------  Ian Lynagh committed May 29, 2012 523  float_top floats rhs -- Urhgh! See Note [CafInfo and floating]  simonpj@microsoft.com committed Jun 14, 2010 524  | mayHaveCafRefs (idCafInfo bndr)  simonpj@microsoft.com committed Sep 22, 2010 525 526 527 528  , allLazyTop floats = return (floats, rhs) -- So the top-level binding is marked NoCafRefs  ian@well-typed.com committed Aug 29, 2012 529  | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs  simonpj@microsoft.com committed Sep 22, 2010 530  = return (floats', rhs')  simonpj@microsoft.com committed Jun 14, 2010 531 532  | otherwise  Simon Peyton Jones committed Mar 25, 2016 533 534 535 536 537 538 539 540 541 542 543  = dontFloat floats rhs dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody) -- Non-empty floats, but do not want to float from rhs -- So wrap the rhs in the floats -- But: rhs1 might have lambdas, and we can't -- put them inside a wrapBinds dontFloat floats1 rhs = do { (floats2, body) <- rhsToBody rhs ; return (emptyFloats, wrapBinds floats1 $wrapBinds floats2 body) }  simonmar committed Mar 14, 2001 544   simonpj@microsoft.com committed Jan 29, 2009 545 546 547 {- Note [Silly extra arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we had this  Ian Lynagh committed May 29, 2012 548  f{arity=1} = \x\y. e  simonpj@microsoft.com committed Jan 29, 2009 549 550 We *must* match the arity on the Id, so we have to generate f' = \x\y. e  Ian Lynagh committed May 29, 2012 551  f = \x. f' x  simonpj@microsoft.com committed Jan 29, 2009 552 553  It's a bizarre case: why is the arity on the Id wrong? Reason  Ian Lynagh committed May 29, 2012 554 (in the days of __inline_me__):  simonpj@microsoft.com committed Jan 29, 2009 555 556 557 558  f{arity=0} = __inline_me__ (let v = expensive in \xy. e) When InlineMe notes go away this won't happen any more. But it seems good for CorePrep to be robust. -}  simonpj@microsoft.com committed Nov 26, 2008 559   lukemaurer committed Feb 01, 2017 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 --------------- cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr -> UniqSM (JoinId, CpeRhs) -- Used for all join bindings cpeJoinPair env bndr rhs = ASSERT(isJoinId bndr) do { let Just join_arity = isJoinId_maybe bndr (bndrs, body) = collectNBinders join_arity rhs ; (env', bndrs') <- cpCloneBndrs env bndrs ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts -- with a lambda ; let rhs' = mkCoreLams bndrs' body' bndr' = bndr setIdUnfolding evaldUnfolding setIdArity count isId bndrs -- See Note [Arity and join points] ; return (bndr', rhs') } {- Note [Arity and join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Up to now, we've allowed a join point to have an arity greater than its join arity (minus type arguments), since this is what's useful for eta expansion. However, for code gen purposes, its arity must be exactly the number of value arguments it will be called with, and it must have exactly that many value lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS: join j x y z = \w -> ... in ... => join j x y z = (let f = \w -> ... in f) in ... This is also what happens with Note [Silly extra arguments]. Note that it's okay for us to mess with the arity because a join point is never exported. -}  simonmar committed Dec 06, 2000 598 -- ---------------------------------------------------------------------------  Ian Lynagh committed May 29, 2012 599 -- CpeRhs: produces a result satisfying CpeRhs  simonmar committed Dec 06, 2000 600 601 -- ---------------------------------------------------------------------------  simonpj@microsoft.com committed Jan 13, 2009 602 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)  simonmar committed Dec 06, 2000 603 -- If  Ian Lynagh committed May 29, 2012 604 605 606 -- e ===> (bs, e') -- then -- e = let bs in e' (semantically, that is!)  simonmar committed Dec 06, 2000 607 608 -- -- For example  Ian Lynagh committed May 29, 2012 609 -- f (g x) ===> ([v = g x], f v)  simonmar committed Dec 06, 2000 610   Simon Peyton Jones committed Sep 14, 2011 611 612 cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)  Sylvain Henry committed Jun 15, 2018 613 cpeRhsE env (Lit (LitNumber LitNumInteger i _))  Herbert Valerio Riedel committed Oct 27, 2014 614 615  = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env) (cpe_integerSDataCon env) i)  Sylvain Henry committed Jun 15, 2018 616 617 618 cpeRhsE env (Lit (LitNumber LitNumNatural i _)) = cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env) (cpe_naturalSDataCon env) i)  Simon Peyton Jones committed Jan 17, 2013 619 620 cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE env expr@(Var {}) = cpeApp env expr  simonpj@microsoft.com committed May 29, 2009 621 622 cpeRhsE env expr@(App {}) = cpeApp env expr  lukemaurer committed Feb 01, 2017 623 624 625 626 627 628 cpeRhsE env (Let bind body) = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind ; (body_floats, body') <- cpeRhsE env' body ; let expr' = case maybe_bind' of Just bind' -> Let bind' body' Nothing -> body' ; return (bind_floats appendFloats body_floats, expr') }  simonpj@microsoft.com committed Jan 13, 2009 629   Simon Marlow committed Nov 02, 2011 630 cpeRhsE env (Tick tickish expr)  Peter Wortmann committed Dec 16, 2014 631 632 633 634 635  | tickishPlace tickish == PlaceNonLam && tickish tickishScopesLike SoftScope = do { (floats, body) <- cpeRhsE env expr -- See [Floating Ticks in CorePrep] ; return (unitFloat (FloatTick tickish) appendFloats floats, body) } | otherwise  simonpj@microsoft.com committed Jan 13, 2009 636  = do { body <- cpeBodyNF env expr  Peter Wortmann committed Dec 16, 2014 637  ; return (emptyFloats, mkTick tickish' body) }  Simon Marlow committed Nov 02, 2011 638 639  where tickish' | Breakpoint n fvs <- tickish  Edward Z. Yang committed Jun 08, 2016 640 641  -- See also 'substTickish' = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)  Simon Marlow committed Nov 02, 2011 642 643  | otherwise = tickish  simonpj@microsoft.com committed Jan 13, 2009 644 645 646 647 648 649 650  cpeRhsE env (Cast expr co) = do { (floats, expr') <- cpeRhsE env expr ; return (floats, Cast expr' co) } cpeRhsE env expr@(Lam {}) = do { let (bndrs,body) = collectBinders expr  Simon Peyton Jones committed Jun 30, 2011 651  ; (env', bndrs') <- cpCloneBndrs env bndrs  Ian Lynagh committed May 29, 2012 652 653  ; body' <- cpeBodyNF env' body ; return (emptyFloats, mkLams bndrs' body') }  simonpj@microsoft.com committed Jan 13, 2009 654 655 656  cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut  Simon Peyton Jones committed Jan 03, 2018 657  ; (env', bndr2) <- cpCloneBndr env bndr  Ben Gamari committed Jul 20, 2017 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672  ; let alts' -- This flag is intended to aid in debugging strictness -- analysis bugs. These are particularly nasty to chase down as -- they may manifest as segmentation faults. When this flag is -- enabled we instead produce an 'error' expression to catch -- the case where a function we think should bottom -- unexpectedly returns. | gopt Opt_CatchBottoms (cpe_dynFlags env) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty "Bottoming expression returned" ; alts'' <- mapM (sat_alt env') alts' ; return (floats, Case scrut' bndr2 ty alts'') }  simonpj@microsoft.com committed Jan 13, 2009 673 674  where sat_alt env (con, bs, rhs)  Simon Peyton Jones committed Jun 30, 2011 675  = do { (env2, bs') <- cpCloneBndrs env bs  simonpj@microsoft.com committed Jan 13, 2009 676 677  ; rhs' <- cpeBodyNF env2 rhs ; return (con, bs', rhs') }  simonmar committed Dec 06, 2000 678   Herbert Valerio Riedel committed Oct 27, 2014 679 cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr  Simon Peyton Jones committed Sep 14, 2011 680 -- Here we convert a literal Integer to the low-level  Gabor Greif committed Jan 09, 2017 681 -- representation. Exactly how we do this depends on the  Ian Lynagh committed May 29, 2012 682 683 -- library that implements Integer. If it's GMP we -- use the S# data constructor for small literals.  Simon Peyton Jones committed Sep 23, 2011 684 -- See Note [Integer literals] in Literal  Herbert Valerio Riedel committed Oct 27, 2014 685 686 cvtLitInteger dflags _ (Just sdatacon) i | inIntRange dflags i -- Special case for small integers  Sylvain Henry committed Nov 22, 2018 687  = mkConApp sdatacon [Lit (mkLitInt dflags i)]  Simon Peyton Jones committed Sep 23, 2011 688   Herbert Valerio Riedel committed Oct 27, 2014 689 cvtLitInteger dflags mk_integer _ i  Simon Peyton Jones committed Sep 23, 2011 690  = mkApps (Var mk_integer) [isNonNegative, ints]  Ian Lynagh committed Sep 17, 2011 691 692 693 694 695 696  where isNonNegative = if i < 0 then mkConApp falseDataCon [] else mkConApp trueDataCon [] ints = mkListExpr intTy (f (abs i)) f 0 = [] f x = let low = x .&. mask high = x shiftR bits  Sylvain Henry committed Nov 22, 2018 697  in mkConApp intDataCon [Lit (mkLitInt dflags low)] : f high  Ian Lynagh committed Sep 17, 2011 698 699  bits = 31 mask = 2 ^ bits - 1  Ian Lynagh committed Sep 13, 2011 700   Sylvain Henry committed Jun 15, 2018 701 702 703 704 705 706 cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr -- Here we convert a literal Natural to the low-level -- representation. -- See Note [Natural literals] in Literal cvtLitNatural dflags _ (Just sdatacon) i | inWordRange dflags i -- Special case for small naturals  Sylvain Henry committed Nov 22, 2018 707  = mkConApp sdatacon [Lit (mkLitWord dflags i)]  Sylvain Henry committed Jun 15, 2018 708 709 710 711 712 713 714  cvtLitNatural dflags mk_natural _ i = mkApps (Var mk_natural) [words] where words = mkListExpr wordTy (f i) f 0 = [] f x = let low = x .&. mask high = x shiftR bits  Sylvain Henry committed Nov 22, 2018 715  in mkConApp wordDataCon [Lit (mkLitWord dflags low)] : f high  Sylvain Henry committed Jun 15, 2018 716 717 718  bits = 32 mask = 2 ^ bits - 1  simonpj@microsoft.com committed Jan 13, 2009 719 -- ---------------------------------------------------------------------------  Ian Lynagh committed May 29, 2012 720 -- CpeBody: produces a result satisfying CpeBody  simonpj@microsoft.com committed Jan 13, 2009 721 -- ---------------------------------------------------------------------------  simonmar committed Dec 06, 2000 722   Edward Z. Yang committed Jun 08, 2016 723 724 725 726 727 -- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without -- producing any floats (any generated floats are immediately -- let-bound using 'wrapBinds'). Generally you want this, esp. -- when you've reached a binding form (e.g., a lambda) and -- floating any further would be incorrect.  simonpj@microsoft.com committed Jan 13, 2009 728 cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody  Ian Lynagh committed May 29, 2012 729 cpeBodyNF env expr  simonpj@microsoft.com committed Jan 13, 2009 730 731  = do { (floats, body) <- cpeBody env expr ; return (wrapBinds floats body) }  simonmar committed Dec 06, 2000 732   Edward Z. Yang committed Jun 08, 2016 733 734 735 736 737 738 739 740 741 742 -- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce -- a list of 'Floats' which are being propagated upwards. In -- fact, this function is used in only two cases: to -- implement 'cpeBodyNF' (which is what you usually want), -- and in the case when a let-binding is in a case scrutinee--here, -- we can always float out: -- -- case (let x = y in z) of ... -- ==> let x = y in case z of ... --  simonpj@microsoft.com committed Jan 13, 2009 743 744 745 746 747 cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) cpeBody env expr = do { (floats1, rhs) <- cpeRhsE env expr ; (floats2, body) <- rhsToBody rhs ; return (floats1 appendFloats floats2, body) }  simonmar committed Feb 16, 2001 748   simonpj@microsoft.com committed Jan 13, 2009 749 750 -------- rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)  simonpj@microsoft.com committed May 28, 2009 751 -- Remove top level lambdas by let-binding  simonmar committed Dec 06, 2000 752   Simon Marlow committed Nov 02, 2011 753 rhsToBody (Tick t expr)  Peter Wortmann committed Dec 16, 2014 754  | tickishScoped t == NoScope -- only float out of non-scoped annotations  simonpj@microsoft.com committed Jan 13, 2009 755  = do { (floats, expr') <- rhsToBody expr  Peter Wortmann committed Dec 16, 2014 756  ; return (floats, mkTick t expr') }  simonmar committed Dec 06, 2000 757   simonpj@microsoft.com committed Jan 13, 2009 758 rhsToBody (Cast e co)  Simon Marlow committed Nov 02, 2011 759 760  -- You can get things like -- case e of { p -> coerce t (\s -> ...) }  simonpj@microsoft.com committed Jan 13, 2009 761 762  = do { (floats, e') <- rhsToBody e ; return (floats, Cast e' co) }  chak@cse.unsw.edu.au. committed Aug 04, 2006 763   simonpj@microsoft.com committed Jan 13, 2009 764 rhsToBody expr@(Lam {})  simonpj@microsoft.com committed Jul 26, 2010 765  | Just no_lam_result <- tryEtaReducePrep bndrs body  simonpj@microsoft.com committed Jan 13, 2009 766  = return (emptyFloats, no_lam_result)  Ian Lynagh committed May 29, 2012 767  | all isTyVar bndrs -- Type lambdas are ok  simonpj@microsoft.com committed Jan 13, 2009 768  = return (emptyFloats, expr)  Ian Lynagh committed May 29, 2012 769  | otherwise -- Some value lambdas  simonpj@microsoft.com committed Jan 13, 2009 770 771  = do { fn <- newVar (exprType expr) ; let rhs = cpeEtaExpand (exprArity expr) expr  Ian Lynagh committed May 29, 2012 772  float = FloatLet (NonRec fn rhs)  simonpj@microsoft.com committed Jan 13, 2009 773  ; return (unitFloat float, Var fn) }  simonpj committed Feb 20, 2001 774 775  where (bndrs,body) = collectBinders expr  simonmar committed Dec 06, 2000 776   simonpj@microsoft.com committed Jan 13, 2009 777 778 rhsToBody expr = return (emptyFloats, expr)  simonmar committed Mar 13, 2001 779   simonpj@microsoft.com committed Jan 13, 2009 780 781  -- ---------------------------------------------------------------------------  Ian Lynagh committed May 29, 2012 782 -- CpeApp: produces a result satisfying CpeApp  simonpj@microsoft.com committed Jan 13, 2009 783 784 -- ---------------------------------------------------------------------------  Simon Peyton Jones committed Nov 02, 2016 785 786 787 data ArgInfo = CpeApp CoreArg | CpeCast Coercion | CpeTick (Tickish Id)  Edward Z. Yang committed Aug 21, 2016 788 789 790 791 792 793 794 795 796 797 798 799  {- Note [runRW arg] ~~~~~~~~~~~~~~~~~~~ If we got, say runRW# (case bot of {}) which happened in Trac #11291, we do /not/ want to turn it into (case bot of {}) realWorldPrimId# because that gives a panic in CoreToStg.myCollectArgs, which expects only variables in function position. But if we are sure to make runRW# strict (which we do in MkId), this can't happen -}  simonpj@microsoft.com committed Jan 13, 2009 800 801 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- May return a CpeRhs because of saturating primops  Edward Z. Yang committed Aug 21, 2016 802 803 cpeApp top_env expr = do { let (terminal, args, depth) = collect_args expr  Edward Z. Yang committed Aug 30, 2016 804 805  ; cpe_app top_env terminal args depth }  simonmar committed Dec 06, 2000 806 807  where  Edward Z. Yang committed Aug 21, 2016 808 809  -- We have a nested data structure of the form -- e App a1 App a2 ... App an, convert it into  Simon Peyton Jones committed Nov 02, 2016 810 811  -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth) -- We use 'ArgInfo' because we may also need to  Edward Z. Yang committed Aug 21, 2016 812 813 814  -- record casts and ticks. Depth counts the number -- of arguments that would consume strictness information -- (so, no type or coercion arguments.)  Simon Peyton Jones committed Nov 02, 2016 815  collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)  Edward Z. Yang committed Aug 21, 2016 816 817  collect_args e = go e [] 0 where  Ben Gamari committed Feb 07, 2017 818  go (App fun arg) as !depth  Simon Peyton Jones committed Nov 02, 2016 819  = go fun (CpeApp arg : as)  Edward Z. Yang committed Aug 21, 2016 820 821 822 823 824 825 826 827 828 829 830  (if isTyCoArg arg then depth else depth + 1) go (Cast fun co) as depth = go fun (CpeCast co : as) depth go (Tick tickish fun) as depth | tickishPlace tickish == PlaceNonLam && tickish tickishScopesLike SoftScope = go fun (CpeTick tickish : as) depth go terminal as depth = (terminal, as, depth) cpe_app :: CorePrepEnv -> CoreExpr  Simon Peyton Jones committed Nov 02, 2016 831  -> [ArgInfo]  Edward Z. Yang committed Aug 21, 2016 832  -> Int  Edward Z. Yang committed Aug 30, 2016 833  -> UniqSM (Floats, CpeRhs)  Simon Peyton Jones committed Nov 02, 2016 834  cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth  Edward Z. Yang committed Aug 21, 2016 835 836  | f hasKey lazyIdKey -- Replace (lazy a) with a, and || f hasKey noinlineIdKey -- Replace (noinline a) with a  Edward Z. Yang committed Aug 30, 2016 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851  -- Consider the code: -- -- lazy (f x) y -- -- We need to make sure that we need to recursively collect arguments on -- "f x", otherwise we'll float "f x" out (it's not a variable) and -- end up with this awful -ddump-prep: -- -- case f x of f_x { -- __DEFAULT -> f_x y -- } -- -- rather than the far superior "f x y". Test case is par01. = let (terminal, args', depth') = collect_args arg in cpe_app env terminal (args' ++ args) (depth + depth' - 1)  Simon Peyton Jones committed Nov 02, 2016 852  cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1  Edward Z. Yang committed Aug 21, 2016 853  | f hasKey runRWKey  Simon Peyton Jones committed Dec 19, 2017 854  -- See Note [runRW magic]  Edward Z. Yang committed Aug 21, 2016 855 856 857 858  -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0  Simon Peyton Jones committed Nov 02, 2016 859  _ -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1  Edward Z. Yang committed Aug 21, 2016 860  cpe_app env (Var v) args depth  simonpj@microsoft.com committed Jan 13, 2009 861  = do { v1 <- fiddleCCall v  Edward Z. Yang committed Jun 08, 2016 862  ; let e2 = lookupCorePrepEnv env v1  Edward Z. Yang committed Aug 21, 2016 863 864  hd = getIdFromTrivialExpr_maybe e2 -- NB: depth from collect_args is right, because e2 is a trivial expression  Edward Z. Yang committed Jun 08, 2016 865 866  -- and thus its embedded Id *must* be at the same depth as any -- Apps it is under are type applications only (c.f.  Ben Gamari committed Nov 02, 2016 867  -- exprIsTrivial). But note that we need the type of the  Edward Z. Yang committed Jun 08, 2016 868  -- expression, not the id.  Edward Z. Yang committed Aug 21, 2016 869  ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts  Edward Z. Yang committed Aug 30, 2016 870  ; mb_saturate hd app floats depth }  Ian Lynagh committed May 29, 2012 871 872  where stricts = case idStrictness v of  Simon Peyton Jones committed Jan 17, 2013 873 874  StrictSig (DmdType _ demands _) | listLengthCmp demands depth /= GT -> demands  Ian Lynagh committed May 29, 2012 875  -- length demands <= depth  Simon Peyton Jones committed Jan 17, 2013 876  | otherwise -> []  Ian Lynagh committed May 29, 2012 877 878 879 880 881  -- If depth < length demands, then we have too few args to -- satisfy strictness info so we have to ignore all the -- strictness info, e.g. + (error "urk") -- Here, we can't evaluate the arg strictly, because this -- partial application might be seq'd  simonmar committed Mar 13, 2001 882   Edward Z. Yang committed Aug 30, 2016 883 884 885 886  -- We inlined into something that's not a var and has no args. -- Bounce it back up to cpeRhsE. cpe_app env fun [] _ = cpeRhsE env fun  Ian Lynagh committed May 29, 2012 887  -- N-variable fun, better let-bind it  Edward Z. Yang committed Aug 30, 2016 888  cpe_app env fun args depth  Simon Peyton Jones committed Jun 06, 2013 889 890  = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty -- The evalDmd says that it's sure to be evaluated,  Ian Lynagh committed May 29, 2012 891  -- so we'll end up case-binding it  Edward Z. Yang committed Aug 21, 2016 892  ; (app, floats) <- rebuild_app args fun' ty fun_floats []  Edward Z. Yang committed Aug 30, 2016 893  ; mb_saturate Nothing app floats depth }  simonpj committed Feb 20, 2001 894  where  Ian Lynagh committed May 29, 2012 895  ty = exprType fun  simonmar committed Dec 06, 2000 896   Edward Z. Yang committed Aug 30, 2016 897 898 899 900 901 902 903  -- Saturate if necessary mb_saturate head app floats depth = case head of Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth ; return (floats, sat_app) } _other -> return (floats, app)  Edward Z. Yang committed Aug 21, 2016 904 905 906 907 908 909  -- Deconstruct and rebuild the application, floating any non-atomic -- arguments to the outside. We collect the type of the expression, -- the head of the application, and the number of actual value arguments, -- all of which are used to possibly saturate this application if it -- has a constructor or primop at the head. rebuild_app  Simon Peyton Jones committed Nov 02, 2016 910  :: [ArgInfo] -- The arguments (inner to outer)  Edward Z. Yang committed Aug 21, 2016 911 912 913 914 915 916 917 918 919  -> CpeApp -> Type -> Floats -> [Demand] -> UniqSM (CpeApp, Floats) rebuild_app [] app _ floats ss = do MASSERT(null ss) -- make sure we used all the strictness info return (app, floats) rebuild_app (a : as) fun' fun_ty floats ss = case a of  Simon Peyton Jones committed Nov 02, 2016 920  CpeApp arg@(Type arg_ty) ->  Edward Z. Yang committed Aug 21, 2016 921  rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss  Simon Peyton Jones committed Nov 02, 2016 922  CpeApp arg@(Coercion {}) ->  Edward Z. Yang committed Aug 21, 2016 923  rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss  Simon Peyton Jones committed Nov 02, 2016 924  CpeApp arg -> do  Edward Z. Yang committed Aug 21, 2016 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940  let (ss1, ss_rest) -- See Note [lazyId magic] in MkId = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) (ss1 : ss_rest, False) -> (ss1, ss_rest) ([], _) -> (topDmd, []) (arg_ty, res_ty) = expectJust "cpeBody:collect_args"$ splitFunTy_maybe fun_ty (fs, arg') <- cpeArg top_env ss1 arg arg_ty rebuild_app as (App fun' arg') res_ty (fs appendFloats floats) ss_rest CpeCast co -> let Pair _ty1 ty2 = coercionKind co in rebuild_app as (Cast fun' co) ty2 floats ss CpeTick tickish -> -- See [Floating Ticks in CorePrep] rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss  Simon Peyton Jones committed Mar 09, 2016 941 942 943 944 945 946 947 isLazyExpr :: CoreExpr -> Bool -- See Note [lazyId magic] in MkId isLazyExpr (Cast e _) = isLazyExpr e isLazyExpr (Tick _ e) = isLazyExpr e isLazyExpr (Var f App _ App _) = f hasKey lazyIdKey isLazyExpr _ = False  Simon Peyton Jones committed Dec 19, 2017 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 {- Note [runRW magic] ~~~~~~~~~~~~~~~~~~~~~ Some definitions, for instance @runST@, must have careful control over float out of the bindings in their body. Consider this use of @runST@, f x = runST ( \ s -> let (a, s') = newArray# 100 [] s (_, s'') = fill_in_array_or_something a x s' in freezeArray# a s'' ) If we inline @runST@, we'll get: f x = let (a, s') = newArray# 100 [] realWorld#{-NB-} (_, s'') = fill_in_array_or_something a x s' in freezeArray# a s'' And now if we allow the @newArray#@ binding to float out to become a CAF, we end up with a result that is totally and utterly wrong: f = let (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! in \ x -> let (_, s'') = fill_in_array_or_something a x s' in freezeArray# a s'' All calls to @f@ will share a {\em single} array! Clearly this is nonsense and must be prevented. This is what @runRW#@ gives us: by being inlined extremely late in the optimization (right before lowering to STG, in CorePrep), we can ensure that no further floating will occur. This allows us to safely inline things like @runST@, which are otherwise needlessly expensive (see #10678 and #5916). 'runRW' is defined (for historical reasons) in GHC.Magic, with a NOINLINE pragma. It is levity-polymorphic. runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r) => (State# RealWorld -> (# State# RealWorld, o #)) -> (# State# RealWorld, o #) It needs no special treatment in GHC except this special inlining here in CorePrep (and in ByteCodeGen).  simonpj@microsoft.com committed Jan 13, 2009 989 -- ---------------------------------------------------------------------------  Ian Lynagh committed May 29, 2012 990 -- CpeArg: produces a result satisfying CpeArg  simonpj@microsoft.com committed Jan 13, 2009 991 992 -- ---------------------------------------------------------------------------  Ben Gamari committed Nov 02, 2016 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 Note [ANF-ising literal string arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a program like, data Foo = Foo Addr# foo = Foo "turtle"# When we go to ANFise this we might think that we want to float the string literal like we do any other non-trivial argument. This would look like, foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s } However, this 1) isn't necessary since strings are in a sense "trivial"; and 2) wreaks havoc on the CAF annotations that we produce here since we the result above is caffy since it is updateable. Ideally at some point in the future we would like to just float the literal to the top level as suggested in #11312, s = "turtle"# foo = Foo s However, until then we simply add a special case excluding literals from the floating done by cpeArg. -} -- | Is an argument okay to CPE? okCpeArg :: CoreExpr -> Bool -- Don't float literals. See Note [ANF-ising literal string arguments]. okCpeArg (Lit _) = False -- Do not eta expand a trivial argument okCpeArg expr = not (exprIsTrivial expr)  simonpj@microsoft.com committed Jan 13, 2009 1026 -- This is where we arrange that a non-trivial argument is let-bound  Austin Seipp committed Dec 03, 2014 1027 cpeArg :: CorePrepEnv -> Demand