CorePrep.hs 65.9 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
56
import Platform
57
import FastString
58
import Config
Peter Wortmann's avatar
Peter Wortmann committed
59
60
import Name             ( NamedThing(..), nameSrcSpan )
import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
61
import Data.Bits
62
import MonadUtils       ( mapAccumLM )
63
import Data.List        ( mapAccumL, foldl' )
64
import Control.Monad
65
66
import CostCentre       ( CostCentre, ccFromThisModule )
import qualified Data.Set as S
67

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

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

75
1.  Saturate constructor and primop applications.
76

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

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

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

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

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

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

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

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

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

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

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

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

125
126
127
11. Same for LitNatural.

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

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

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.
138

139

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

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

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

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

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

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

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

179
corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
180
            -> IO (CoreProgram, S.Set CostCentre)
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
185
    us <- mkSplitUniqSupply 's'
186
    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
187

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
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
199
200
                      floats1 <- corePrepTopBinds initialCorePrepEnv binds
                      floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
201
202
                      return (deFloatTop (floats1 `appendFloats` floats2))

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

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

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

Peter Wortmann's avatar
Peter Wortmann committed
231
mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
232
-- See Note [Data constructor workers]
233
-- c.f. Note [Injecting implicit bindings] in TidyPgm
Peter Wortmann's avatar
Peter Wortmann committed
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
237
    | tycon <- data_tycons,     -- CorePrep will eta-expand it
238
      data_con <- tyConDataCons tycon,
Peter Wortmann's avatar
Peter Wortmann committed
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
245
     | debugLevel dflags == 0                = id
Peter Wortmann's avatar
Peter Wortmann committed
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
251

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

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

Note [CafInfo and floating]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
271
What happens when we try to float bindings to the top level?  At this
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...
290

291
   So, gruesomely, we must set the NoCafRefs flag on the sat bindings,
292
   *and* substitute the modified 'sat' into the old RHS.
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
300
out CafInfo later, after CorePrep.  We'll do that in due course.
301
302
Meanwhile this horrible hack works.

lukemaurer's avatar
lukemaurer committed
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.
326
327
328

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

332
        $wC = \x y -> $wC x y
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.

344

345
346
Note [Dead code in CorePrep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Simon Peyton Jones's avatar
Simon Peyton Jones committed
347
Imagine that we got an input program like this (see Trac #4962):
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
361
      {-# RULES g $dBool = g$Bool
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 = ...

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.
375

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.
380
381
382

The way we fix this is to:
 * In cloneBndr, drop all unfoldings/rules
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.
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:
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's avatar
Austin Seipp committed
407
408
************************************************************************
*                                                                      *
409
                The main code
Austin Seipp's avatar
Austin Seipp committed
410
411
412
*                                                                      *
************************************************************************
-}
413

414
cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
lukemaurer's avatar
lukemaurer committed
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
419
cpeBind top_lvl env (NonRec bndr rhs)
lukemaurer's avatar
lukemaurer committed
420
  | not (isJoinId bndr)
421
  = do { (_, bndr1) <- cpCloneBndr env bndr
422
       ; let dmd         = idDemandInfo bndr
423
             is_unlifted = isUnliftedType (idType bndr)
424
425
426
       ; (floats, rhs1) <- cpePair top_lvl NonRecursive
                                   dmd is_unlifted
                                   env bndr1 rhs
427
       -- See Note [Inlining in CorePrep]
428
429
       ; if exprIsTrivial rhs1 && isNotTopLevel top_lvl
            then return (extendCorePrepEnvExpr env bndr rhs1, floats, Nothing)
430
431
            else do {

432
       ; let new_float = mkFloat dmd is_unlifted bndr1 rhs1
433

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

  | otherwise -- A join point; see Note [Join points and floating]
lukemaurer's avatar
lukemaurer committed
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)) }
445
446

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

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

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

lukemaurer's avatar
lukemaurer committed
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)) }
468
  where
lukemaurer's avatar
lukemaurer committed
469
470
    (bndrs, rhss) = unzip pairs

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

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

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
491
       ; (floats3, rhs3)
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)
497
                        ; let float = mkFloat topDmd False v rhs2
498
                        ; return ( addFloat floats2 float
499
                                 , cpeEtaExpand arity (Var v)) })
500

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

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

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

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

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

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

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

      | otherwise
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) }
544

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

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

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

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

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

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

lukemaurer's avatar
lukemaurer committed
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') }
629

630
cpeRhsE env (Tick tickish expr)
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
636
  = do { body <- cpeBodyNF env expr
637
       ; return (emptyFloats, mkTick tickish' body) }
638
639
  where
    tickish' | Breakpoint n fvs <- tickish
640
641
             -- See also 'substTickish'
             = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)
642
643
             | otherwise
             = tickish
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
651
        ; (env', bndrs') <- cpCloneBndrs env bndrs
652
653
        ; body' <- cpeBodyNF env' body
        ; return (emptyFloats, mkLams bndrs' body') }
654
655
656

cpeRhsE env (Case scrut bndr ty alts)
  = do { (floats, scrut') <- cpeBody env scrut
657
       ; (env', bndr2) <- cpCloneBndr env bndr
Ben Gamari's avatar
Ben Gamari committed
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'') }
673
674
  where
    sat_alt env (con, bs, rhs)
675
       = do { (env2, bs') <- cpCloneBndrs env bs
676
677
            ; rhs' <- cpeBodyNF env2 rhs
            ; return (con, bs', rhs') }
678

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

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

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

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

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

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 ...
--
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) }
748

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

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

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

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

777
778
rhsToBody expr = return (emptyFloats, expr)

779

780
781

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

785
786
787
data ArgInfo = CpeApp  CoreArg
             | CpeCast Coercion
             | CpeTick (Tickish Id)
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
-}

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

  where
808
809
    -- We have a nested data structure of the form
    -- e `App` a1 `App` a2 ... `App` an, convert it into
810
811
    -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)
    -- We use 'ArgInfo' because we may also need to
812
813
814
    -- record casts and ticks.  Depth counts the number
    -- of arguments that would consume strictness information
    -- (so, no type or coercion arguments.)
815
    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)
816
817
    collect_args e = go e [] 0
      where
818
        go (App fun arg)      as !depth
819
            = go fun (CpeApp arg : as)
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
831
            -> [ArgInfo]
832
            -> Int
833
            -> UniqSM (Floats, CpeRhs)
834
    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth
835
836
        | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and
       || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a
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)
852
    cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1
853
        | f `hasKey` runRWKey
Simon Peyton Jones's avatar
Simon Peyton Jones committed
854
        -- See Note [runRW magic]
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
859
            _          -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1
860
    cpe_app env (Var v) args depth
861
      = do { v1 <- fiddleCCall v
862
           ; let e2 = lookupCorePrepEnv env v1
863
864
                 hd = getIdFromTrivialExpr_maybe e2
           -- NB: depth from collect_args is right, because e2 is a trivial expression
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.
867
           -- exprIsTrivial).  But note that we need the type of the
868
           -- expression, not the id.
869
           ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts
870
           ; mb_saturate hd app floats depth }
871
872
        where
          stricts = case idStrictness v of
873
874
                            StrictSig (DmdType _ demands _)
                              | listLengthCmp demands depth /= GT -> demands
875
                                    -- length demands <= depth
876
                              | otherwise                         -> []
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
882

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

887
        -- N-variable fun, better let-bind it
888
    cpe_app env fun args depth
889
890
      = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty
                          -- The evalDmd says that it's sure to be evaluated,
891
                          -- so we'll end up case-binding it
892
           ; (app, floats) <- rebuild_app args fun' ty fun_floats []
893
           ; mb_saturate Nothing app floats depth }
894
        where
895
          ty = exprType fun
896

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)

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
910
        :: [ArgInfo]                  -- The arguments (inner to outer)
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
920
      CpeApp arg@(Type arg_ty) ->
921
        rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss
922
      CpeApp arg@(Coercion {}) ->
923
        rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss
924
      CpeApp arg -> do
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

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's avatar
Simon Peyton Jones committed
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).

989
-- ---------------------------------------------------------------------------
990
--      CpeArg: produces a result satisfying CpeArg
991
992
-- ---------------------------------------------------------------------------

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)

1026
-- This is where we arrange that a non-trivial argument is let-bound
Austin Seipp's avatar
Austin Seipp committed
1027
cpeArg :: CorePrepEnv -> Demand
Simon Peyton Jones's avatar