CorePrep.hs 66.6 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The University of Glasgow, 1994-2006

Simon Marlow's avatar
Simon Marlow committed
4 5

Core pass to saturate constructors and PrimOps
Austin Seipp's avatar
Austin Seipp committed
6
-}
7

8
{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}
Ian Lynagh's avatar
Ian Lynagh committed
9

10
module CorePrep (
11 12 13
      corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural,
      lookupMkIntegerName, lookupIntegerSDataConName,
      lookupMkNaturalName, lookupNaturalSDataConName
14 15 16 17
  ) where

#include "HsVersions.h"

18 19
import GhcPrelude

20 21
import OccurAnal

22
import HscTypes
23
import PrelNames
24
import MkId             ( realWorldPrimId )
25 26
import CoreUtils
import CoreArity
Simon Marlow's avatar
Simon Marlow committed
27
import CoreFVs
28 29
import CoreMonad        ( CoreToDo(..) )
import CoreLint         ( endPassIO )
30
import CoreSyn
31
import CoreSubst
32
import MkCore hiding( FloatBind(..) )   -- We use our own FloatBind here
Simon Marlow's avatar
Simon Marlow committed
33
import Type
34
import Literal
Simon Marlow's avatar
Simon Marlow committed
35
import Coercion
36
import TcEnv
Simon Marlow's avatar
Simon Marlow committed
37
import TyCon
38
import Demand
Simon Marlow's avatar
Simon Marlow committed
39
import Var
40
import VarSet
41
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
42
import Id
43
import IdInfo
44
import TysWiredIn
Simon Marlow's avatar
Simon Marlow committed
45 46
import DataCon
import BasicTypes
47
import Module
48 49
import UniqSupply
import Maybes
50
import OrdList
51
import ErrUtils
52
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
53
import Util
54
import Pair
55
import Outputable
John Ericson's avatar
John Ericson committed
56
import GHC.Platform
57
import FastString
Peter Wortmann's avatar
Peter Wortmann committed
58 59
import Name             ( NamedThing(..), nameSrcSpan )
import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
60
import Data.Bits
61
import MonadUtils       ( mapAccumLM )
David Eichmann's avatar
David Eichmann committed
62
import Data.List        ( mapAccumL )
63
import Control.Monad
64 65
import CostCentre       ( CostCentre, ccFromThisModule )
import qualified Data.Set as S
66

Austin Seipp's avatar
Austin Seipp committed
67
{-
68
-- ---------------------------------------------------------------------------
69
-- Note [CorePrep Overview]
70
-- ---------------------------------------------------------------------------
71

72
The goal of this pass is to prepare for code generation.
73

74
1.  Saturate constructor applications.
75

76 77
2.  Convert to A-normal form; that is, function arguments
    are always variables.
78

79
    * Use case for strict arguments:
80 81
        f E ==> case E of x -> f x
        (where f is strict)
82

83
    * Use let for non-trivial lazy arguments
84 85
        f E ==> let x = E in f x
        (were f is lazy and x is non-trivial)
86

87
3.  Similarly, convert any unboxed lets into cases.
88
    [I'm experimenting with leaving 'ok-for-speculation'
89
     rhss in let-form right up to this point.]
90

91
4.  Ensure that *value* lambdas only occur as the RHS of a binding
92
    (The code generator can't deal with anything else.)
93
    Type lambdas are ok, however, because the code gen discards them.
94

95
5.  [Not any more; nuked Jun 2002] Do the seq/par munging.
96

97
6.  Clone all local Ids.
98
    This means that all such Ids are unique, rather than the
99 100 101
    weaker guarantee of no clashes which the simplifier provides.
    And that is what the code generator needs.

102
    We don't clone TyVars or CoVars. The code gen doesn't need that,
103
    and doing so would be tiresome because then we'd need
104
    to substitute in types and coercions.
105

106 107 108
7.  Give each dynamic CCall occurrence a fresh unique; this is
    rather like the cloning step above.

109
8.  Inject bindings for the "implicit" Ids:
110 111
        * Constructor wrappers
        * Constructor workers
112 113
    We want curried definitions for all of these in case they
    aren't inlined by some caller.
114

115
9.  Replace (lazy e) by e.  See Note [lazyId magic] in MkId.hs
116
    Also replace (noinline e) by e.
117

118 119
10. Convert (LitInteger i t) into the core representation
    for the Integer i. Normally this uses mkInteger, but if
120 121 122 123
    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.

124 125 126
11. Same for LitNatural.

12. Uphold tick consistency while doing this: We move ticks out of
127 128 129
    (non-type) applications where we can, and make sure that we
    annotate according to scoping rules when floating.

130
13. Collect cost centres (including cost centres in unfoldings) if we're in
131 132 133
    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].

134 135 136
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.
137

138

139 140
Note [CorePrep invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~
141
Here is the syntax of the Core produced by CorePrep:
142

143
    Trivial expressions
144 145 146
       arg ::= lit |  var
              | arg ty  |  /\a. arg
              | truv co  |  /\c. arg  |  arg |> co
147 148

    Applications
149
       app ::= lit  |  var  |  app arg  |  app ty  | app co | app |> co
150 151

    Expressions
152
       body ::= app
153 154
              | let(rec) x = rhs in body     -- Boxed only
              | case body of pat -> body
155
              | /\a. body | /\c. body
156 157
              | body |> co

158
    Right hand sides (only place where value lambdas can occur)
159 160 161 162
       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's avatar
Austin Seipp committed
163
-}
164

165
type CpeArg  = CoreExpr    -- Non-terminal 'arg'
166 167 168
type CpeApp  = CoreExpr    -- Non-terminal 'app'
type CpeBody = CoreExpr    -- Non-terminal 'body'
type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
169

Austin Seipp's avatar
Austin Seipp committed
170 171 172
{-
************************************************************************
*                                                                      *
173
                Top level stuff
Austin Seipp's avatar
Austin Seipp committed
174 175 176
*                                                                      *
************************************************************************
-}
177

178
corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
179
            -> IO (CoreProgram, S.Set CostCentre)
180 181 182 183
corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
    withTiming (pure dflags)
               (text "CorePrep"<+>brackets (ppr this_mod))
               (const ()) $ do
184
    us <- mkSplitUniqSupply 's'
185
    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
186

187 188 189 190 191 192 193
    let cost_centres
          | WayProf `elem` ways dflags
          = collectCostCentres this_mod binds
          | otherwise
          = S.empty

        implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
194 195 196 197
            -- NB: we must feed mkImplicitBinds through corePrep too
            -- so that they are suitably cloned and eta-expanded

        binds_out = initUs_ us $ do
198 199
                      floats1 <- corePrepTopBinds initialCorePrepEnv binds
                      floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
200 201
                      return (deFloatTop (floats1 `appendFloats` floats2))

202
    endPassIO hsc_env alwaysQualify CorePrep binds_out []
203
    return (binds_out, cost_centres)
204 205
  where
    dflags = hsc_dflags hsc_env
206

207
corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
208 209
corePrepExpr dflags hsc_env expr =
    withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $ do
210
    us <- mkSplitUniqSupply 's'
211
    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
212
    let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
213 214
    dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
    return new_expr
215

216
corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
217
-- Note [Floating out of top level bindings]
218 219
corePrepTopBinds initialCorePrepEnv binds
  = go initialCorePrepEnv binds
220 221
  where
    go _   []             = return emptyFloats
lukemaurer's avatar
lukemaurer committed
222 223 224 225 226 227 228
    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)
229

Peter Wortmann's avatar
Peter Wortmann committed
230
mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
231
-- See Note [Data constructor workers]
232
-- c.f. Note [Injecting implicit bindings] in TidyPgm
Peter Wortmann's avatar
Peter Wortmann committed
233 234 235
mkDataConWorkers dflags mod_loc data_tycons
  = [ NonRec id (tick_it (getName data_con) (Var id))
                                -- The ice is thin here, but it works
236
    | tycon <- data_tycons,     -- CorePrep will eta-expand it
237
      data_con <- tyConDataCons tycon,
Peter Wortmann's avatar
Peter Wortmann committed
238 239 240 241 242 243
      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
244
     | debugLevel dflags == 0                = id
Peter Wortmann's avatar
Peter Wortmann committed
245 246 247 248 249
     | 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
250

Austin Seipp's avatar
Austin Seipp committed
251
{-
252 253 254
Note [Floating out of top level bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
NB: we do need to float out of top-level bindings
255
Consider        x = length [True,False]
256
We want to get
257 258 259
                s1 = False : []
                s2 = True  : s1
                x  = length s2
260 261

We return a *list* of bindings, because we may start with
262
        x* = f (g y)
263
where x is demanded, in which case we want to finish with
264 265
        a = g y
        x* = f a
266 267 268 269
And then x will actually end up case-bound

Note [CafInfo and floating]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
270
What happens when we try to float bindings to the top level?  At this
271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288
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...
289

290
   So, gruesomely, we must set the NoCafRefs flag on the sat bindings,
291
   *and* substitute the modified 'sat' into the old RHS.
292 293 294 295 296 297 298

   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
299
out CafInfo later, after CorePrep.  We'll do that in due course.
300 301
Meanwhile this horrible hack works.

lukemaurer's avatar
lukemaurer committed
302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
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.
325 326 327

Note [Data constructor workers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
328 329
Create any necessary "implicit" bindings for data con workers.  We
create the rather strange (non-recursive!) binding
330

331
        $wC = \x y -> $wC x y
332 333 334 335 336 337 338 339 340 341 342

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.

343

344 345
Note [Dead code in CorePrep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
346
Imagine that we got an input program like this (see #4962):
347 348 349 350 351 352 353 354 355 356 357 358 359

  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
360
      {-# RULES g $dBool = g$Bool
361 362 363 364 365 366 367 368 369
                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 = ...

370 371 372 373
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.
374

375 376 377 378
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.
379 380 381

The way we fix this is to:
 * In cloneBndr, drop all unfoldings/rules
382 383 384 385 386 387

 * 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.
388 389 390 391 392 393

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:
394 395 396 397 398 399 400 401 402 403 404 405

  Rec {
  f = ... f ...
  }

Into this one:

  f = ... f ...

(Since f is not considered to be free in its own RHS.)


Austin Seipp's avatar
Austin Seipp committed
406 407
************************************************************************
*                                                                      *
408
                The main code
Austin Seipp's avatar
Austin Seipp committed
409 410 411
*                                                                      *
************************************************************************
-}
412

413
cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
lukemaurer's avatar
lukemaurer committed
414 415 416 417
        -> UniqSM (CorePrepEnv,
                   Floats,         -- Floating value bindings
                   Maybe CoreBind) -- Just bind' <=> returned new bind; no float
                                   -- Nothing <=> added bind' to floats instead
418
cpeBind top_lvl env (NonRec bndr rhs)
lukemaurer's avatar
lukemaurer committed
419
  | not (isJoinId bndr)
420
  = do { (_, bndr1) <- cpCloneBndr env bndr
421
       ; let dmd         = idDemandInfo bndr
422
             is_unlifted = isUnliftedType (idType bndr)
423 424 425
       ; (floats, rhs1) <- cpePair top_lvl NonRecursive
                                   dmd is_unlifted
                                   env bndr1 rhs
426
       -- See Note [Inlining in CorePrep]
427 428
       ; if exprIsTrivial rhs1 && isNotTopLevel top_lvl
            then return (extendCorePrepEnvExpr env bndr rhs1, floats, Nothing)
429 430
            else do {

431
       ; let new_float = mkFloat dmd is_unlifted bndr1 rhs1
432

433
       ; return (extendCorePrepEnv env bndr bndr1,
lukemaurer's avatar
lukemaurer committed
434 435
                 addFloat floats new_float,
                 Nothing) }}
436 437

  | otherwise -- A join point; see Note [Join points and floating]
lukemaurer's avatar
lukemaurer committed
438 439 440 441 442 443
  = 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)) }
444 445

cpeBind top_lvl env (Rec pairs)
lukemaurer's avatar
lukemaurer committed
446 447
  | not (isJoinId (head bndrs))
  = do { (env', bndrs1) <- cpCloneBndrs env bndrs
448 449
       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')
                           bndrs1 rhss
450

451 452
       ; let (floats_s, rhss1) = unzip stuff
             all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)
453
                                           (concatFloats floats_s)
454 455

       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),
lukemaurer's avatar
lukemaurer committed
456 457
                 unitFloat (FloatLet (Rec all_pairs)),
                 Nothing) }
458

lukemaurer's avatar
lukemaurer committed
459 460 461 462 463 464 465 466
  | 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)) }
467
  where
lukemaurer's avatar
lukemaurer committed
468 469
    (bndrs, rhss) = unzip pairs

Gabor Greif's avatar
Gabor Greif committed
470
        -- Flatten all the floats, and the current
471
        -- group into a single giant Rec
472 473 474 475 476
    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)

---------------
477
cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
478 479
        -> CorePrepEnv -> OutId -> CoreExpr
        -> UniqSM (Floats, CpeRhs)
480
-- Used for all bindings
481
-- The binder is already cloned, hence an OutId
482
cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
lukemaurer's avatar
lukemaurer committed
483 484
  = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair
    do { (floats1, rhs1) <- cpeRhsE env rhs
485

486 487 488 489
       -- 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
490
       ; (floats3, rhs3)
491 492 493 494 495
            <- 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)
496
                        ; let float = mkFloat topDmd False v rhs2
497
                        ; return ( addFloat floats2 float
498
                                 , cpeEtaExpand arity (Var v)) })
499

500 501 502
        -- Wrap floating ticks
       ; let (floats4, rhs4) = wrapTicks floats3 rhs3

503
       ; return (floats4, rhs4) }
504
  where
505 506
    platform = targetPlatform (cpe_dynFlags env)

507
    arity = idArity bndr        -- We must match this arity
508 509

    ---------------------
510 511
    float_from_rhs floats rhs
      | isEmptyFloats floats = return (emptyFloats, rhs)
512 513
      | isTopLevel top_lvl   = float_top    floats rhs
      | otherwise            = float_nested floats rhs
514 515

    ---------------------
516
    float_nested floats rhs
517
      | wantFloatNested is_rec dmd is_unlifted floats rhs
518
                  = return (floats, rhs)
519
      | otherwise = dontFloat floats rhs
520 521

    ---------------------
522
    float_top floats rhs        -- Urhgh!  See Note [CafInfo and floating]
523
      | mayHaveCafRefs (idCafInfo bndr)
524 525 526 527
      , allLazyTop floats
      = return (floats, rhs)

      -- So the top-level binding is marked NoCafRefs
528
      | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs
529
      = return (floats', rhs')
530 531

      | otherwise
532 533 534 535 536 537 538 539 540 541 542
      = 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) }
543

544 545 546
{- Note [Silly extra arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we had this
547
        f{arity=1} = \x\y. e
548 549
We *must* match the arity on the Id, so we have to generate
        f' = \x\y. e
550
        f  = \x. f' x
551 552

It's a bizarre case: why is the arity on the Id wrong?  Reason
553
(in the days of __inline_me__):
554 555 556 557
        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.
-}
558

lukemaurer's avatar
lukemaurer committed
559 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
---------------
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.
-}

597
-- ---------------------------------------------------------------------------
598
--              CpeRhs: produces a result satisfying CpeRhs
599 600
-- ---------------------------------------------------------------------------

601
cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
602
-- If
603 604 605
--      e  ===>  (bs, e')
-- then
--      e = let bs in e'        (semantically, that is!)
606 607
--
-- For example
608
--      f (g x)   ===>   ([v = g x], f v)
609

610 611
cpeRhsE _env expr@(Type {})      = return (emptyFloats, expr)
cpeRhsE _env expr@(Coercion {})  = return (emptyFloats, expr)
612
cpeRhsE env (Lit (LitNumber LitNumInteger i _))
613 614
    = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)
                   (cpe_integerSDataCon env) i)
615 616 617
cpeRhsE env (Lit (LitNumber LitNumNatural i _))
    = cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env)
                   (cpe_naturalSDataCon env) i)
618 619
cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
cpeRhsE env expr@(Var {})  = cpeApp env expr
620 621
cpeRhsE env expr@(App {}) = cpeApp env expr

lukemaurer's avatar
lukemaurer committed
622 623 624 625 626 627
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') }
628

629
cpeRhsE env (Tick tickish expr)
630 631 632 633 634
  | 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
635
  = do { body <- cpeBodyNF env expr
636
       ; return (emptyFloats, mkTick tickish' body) }
637 638
  where
    tickish' | Breakpoint n fvs <- tickish
639 640
             -- See also 'substTickish'
             = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)
641 642
             | otherwise
             = tickish
643 644 645 646 647 648 649

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
650
        ; (env', bndrs') <- cpCloneBndrs env bndrs
651 652
        ; body' <- cpeBodyNF env' body
        ; return (emptyFloats, mkLams bndrs' body') }
653 654 655

cpeRhsE env (Case scrut bndr ty alts)
  = do { (floats, scrut') <- cpeBody env scrut
656
       ; (env', bndr2) <- cpCloneBndr env bndr
Ben Gamari's avatar
Ben Gamari committed
657 658 659 660 661 662 663 664 665 666 667 668 669 670 671
       ; 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'') }
672 673
  where
    sat_alt env (con, bs, rhs)
674
       = do { (env2, bs') <- cpCloneBndrs env bs
675 676
            ; rhs' <- cpeBodyNF env2 rhs
            ; return (con, bs', rhs') }
677

678
cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
679
-- Here we convert a literal Integer to the low-level
680
-- representation. Exactly how we do this depends on the
681 682
-- library that implements Integer.  If it's GMP we
-- use the S# data constructor for small literals.
683
-- See Note [Integer literals] in Literal
684 685
cvtLitInteger dflags _ (Just sdatacon) i
  | inIntRange dflags i -- Special case for small integers
Sylvain Henry's avatar
Sylvain Henry committed
686
    = mkConApp sdatacon [Lit (mkLitInt dflags i)]
687

688
cvtLitInteger dflags mk_integer _ i
689
    = mkApps (Var mk_integer) [isNonNegative, ints]
690 691 692 693 694 695
  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's avatar
Sylvain Henry committed
696
              in mkConApp intDataCon [Lit (mkLitInt dflags low)] : f high
697 698
        bits = 31
        mask = 2 ^ bits - 1
699

700 701 702 703 704 705
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's avatar
Sylvain Henry committed
706
    = mkConApp sdatacon [Lit (mkLitWord dflags i)]
707 708 709 710 711 712 713

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's avatar
Sylvain Henry committed
714
              in mkConApp wordDataCon [Lit (mkLitWord dflags low)] : f high
715 716 717
        bits = 32
        mask = 2 ^ bits - 1

718
-- ---------------------------------------------------------------------------
719
--              CpeBody: produces a result satisfying CpeBody
720
-- ---------------------------------------------------------------------------
721

722 723 724 725 726
-- | 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.
727
cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
728
cpeBodyNF env expr
729 730
  = do { (floats, body) <- cpeBody env expr
       ; return (wrapBinds floats body) }
731

732 733 734 735 736 737 738 739 740 741
-- | 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 ...
--
742 743 744 745 746
cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
cpeBody env expr
  = do { (floats1, rhs) <- cpeRhsE env expr
       ; (floats2, body) <- rhsToBody rhs
       ; return (floats1 `appendFloats` floats2, body) }
747

748 749
--------
rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
750
-- Remove top level lambdas by let-binding
751

752
rhsToBody (Tick t expr)
Peter Wortmann's avatar
Peter Wortmann committed
753
  | tickishScoped t == NoScope  -- only float out of non-scoped annotations
754
  = do { (floats, expr') <- rhsToBody expr
755
       ; return (floats, mkTick t expr') }
756

757
rhsToBody (Cast e co)
758 759
        -- You can get things like
        --      case e of { p -> coerce t (\s -> ...) }
760 761
  = do { (floats, e') <- rhsToBody e
       ; return (floats, Cast e' co) }
762

763
rhsToBody expr@(Lam {})
764
  | Just no_lam_result <- tryEtaReducePrep bndrs body
765
  = return (emptyFloats, no_lam_result)
766
  | all isTyVar bndrs           -- Type lambdas are ok
767
  = return (emptyFloats, expr)
768
  | otherwise                   -- Some value lambdas
769 770
  = do { fn <- newVar (exprType expr)
       ; let rhs   = cpeEtaExpand (exprArity expr) expr
771
             float = FloatLet (NonRec fn rhs)
772
       ; return (unitFloat float, Var fn) }
773 774
  where
    (bndrs,body) = collectBinders expr
775

776 777
rhsToBody expr = return (emptyFloats, expr)

778

779 780

-- ---------------------------------------------------------------------------
781
--              CpeApp: produces a result satisfying CpeApp
782 783
-- ---------------------------------------------------------------------------

784 785 786
data ArgInfo = CpeApp  CoreArg
             | CpeCast Coercion
             | CpeTick (Tickish Id)
787 788 789 790 791

{- Note [runRW arg]
~~~~~~~~~~~~~~~~~~~
If we got, say
   runRW# (case bot of {})
792
which happened in #11291, we do /not/ want to turn it into
793 794 795 796 797 798
   (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
-}

799 800
cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
-- May return a CpeRhs because of saturating primops
801 802
cpeApp top_env expr
  = do { let (terminal, args, depth) = collect_args expr
803 804
       ; cpe_app top_env terminal args depth
       }
805 806

  where
807 808
    -- We have a nested data structure of the form
    -- e `App` a1 `App` a2 ... `App` an, convert it into
809 810
    -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)
    -- We use 'ArgInfo' because we may also need to
811 812 813
    -- record casts and ticks.  Depth counts the number
    -- of arguments that would consume strictness information
    -- (so, no type or coercion arguments.)
814
    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)
815 816
    collect_args e = go e [] 0
      where
817
        go (App fun arg)      as !depth
818
            = go fun (CpeApp arg : as)
819 820 821 822 823 824 825 826 827 828 829
                (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
830
            -> [ArgInfo]
831
            -> Int
832
            -> UniqSM (Floats, CpeRhs)
833
    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth
834 835
        | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and
       || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a
836 837 838 839 840 841 842 843 844 845 846 847 848 849 850
        -- 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)
851
    cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1
852
        | f `hasKey` runRWKey
Simon Peyton Jones's avatar