CoreUtils.lhs 63.7 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5
6

Utility functions on @Core@ syntax
7
8

\begin{code}
batterseapower's avatar
batterseapower committed
9
-- | Commonly useful utilites for manipulating the Core language
10
module CoreUtils (
11
        -- * Constructing expressions
12
13
        mkCast,
        mkTick, mkTickNoHNF,
Simon Marlow's avatar
Simon Marlow committed
14
        bindNonRec, needsCaseBinding,
15
        mkAltExpr,
16

17
18
        -- * Taking expressions apart
        findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
19

20
        -- * Properties of expressions
Simon Marlow's avatar
Simon Marlow committed
21
        exprType, coreAltType, coreAltsType,
22
        exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
23
        exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
24
25
        exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
        rhsIsStatic, isCheapApp, isExpandableApp,
26

27
28
29
        -- * Expression and bindings size
        coreBindsSize, exprSize,
        CoreStats(..), coreBindsStats,
30

31
32
        -- * Hashing
        hashExpr,
33

34
35
        -- * Equality
        cheapEqExpr, eqExpr, eqExprX,
36

37
38
        -- * Eta reduction
        tryEtaReduce,
39

40
41
        -- * Manipulating data constructors and types
        applyTypeToArgs, applyTypeToArg,
42
        dataConRepInstPat, dataConRepFSInstPat
43
    ) where
44

45
#include "HsVersions.h"
46

47
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
48
49
50
import PprCore
import Var
import SrcLoc
51
import VarEnv
52
import VarSet
Simon Marlow's avatar
Simon Marlow committed
53
54
55
56
57
58
59
60
61
62
import Name
import Literal
import DataCon
import PrimOp
import Id
import IdInfo
import Type
import Coercion
import TyCon
import Unique
63
import Outputable
Simon Marlow's avatar
Simon Marlow committed
64
65
import TysPrim
import FastString
66
import Maybes
Simon Marlow's avatar
Simon Marlow committed
67
import Util
68
import Pair
69
70
import Data.Word
import Data.Bits
dreixel's avatar
dreixel committed
71
import Data.List ( mapAccumL )
72
\end{code}
73

74

75
%************************************************************************
76
%*                                                                      *
77
\subsection{Find the type of a Core atom/expression}
78
%*                                                                      *
79
80
81
%************************************************************************

\begin{code}
82
exprType :: CoreExpr -> Type
batterseapower's avatar
batterseapower committed
83
84
85
-- ^ Recover the type of a well-typed Core expression. Fails when
-- applied to the actual 'CoreSyn.Type' expression as it cannot
-- really be said to have a type
86
87
88
89
exprType (Var var)           = idType var
exprType (Lit lit)           = literalType lit
exprType (Coercion co)       = coercionType co
exprType (Let _ body)        = exprType body
90
exprType (Case _ _ ty _)     = ty
91
exprType (Cast _ co)         = pSnd (coercionKind co)
92
exprType (Tick _ e)          = exprType e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
93
exprType (Lam binder expr)   = mkPiType binder (exprType expr)
94
exprType e@(App _ _)
95
  = case collectArgs e of
96
        (fun, args) -> applyTypeToArgs e (exprType fun) args
97

98
exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
99

100
coreAltType :: CoreAlt -> Type
batterseapower's avatar
batterseapower committed
101
-- ^ Returns the type of the alternatives right hand side
102
coreAltType (_,bs,rhs)
103
104
105
106
107
  | any bad_binder bs = expandTypeSynonyms ty
  | otherwise         = ty    -- Note [Existential variables and silly type synonyms]
  where
    ty           = exprType rhs
    free_tvs     = tyVarsOfType ty
108
    bad_binder b = isTyVar b && b `elemVarSet` free_tvs
109
110

coreAltsType :: [CoreAlt] -> Type
batterseapower's avatar
batterseapower committed
111
-- ^ Returns the type of the first alternative, which should be the same as for all alternatives
112
coreAltsType (alt:_) = coreAltType alt
113
coreAltsType []      = panic "corAltsType"
114
115
\end{code}

116
117
118
Note [Existential variables and silly type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
119
120
121
122
        data T = forall a. T (Funny a)
        type Funny a = Bool
        f :: T -> Bool
        f (T x) = x
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139

Now, the type of 'x' is (Funny a), where 'a' is existentially quantified.
That means that 'exprType' and 'coreAltsType' may give a result that *appears*
to mention an out-of-scope type variable.  See Trac #3409 for a more real-world
example.

Various possibilities suggest themselves:

 - Ignore the problem, and make Lint not complain about such variables

 - Expand all type synonyms (or at least all those that discard arguments)
      This is tricky, because at least for top-level things we want to
      retain the type the user originally specified.

 - Expand synonyms on the fly, when the problem arises. That is what
   we are doing here.  It's not too expensive, I think.

140
\begin{code}
141
applyTypeToArg :: Type -> CoreExpr -> Type
batterseapower's avatar
batterseapower committed
142
-- ^ Determines the type resulting from applying an expression to a function with the given type
143
applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
144
applyTypeToArg fun_ty _             = funResultTy fun_ty
145

146
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
batterseapower's avatar
batterseapower committed
147
148
-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
-- The first argument is just for debugging, and gives some context
149
applyTypeToArgs _ op_ty [] = op_ty
150

151
applyTypeToArgs e op_ty (Type ty : args)
152
  =     -- Accumulate type arguments so we can instantiate all at once
153
    go [ty] args
154
  where
155
    go rev_tys (Type ty : args) = go (ty:rev_tys) args
156
    go rev_tys rest_args         = applyTypeToArgs e op_ty' rest_args
157
158
159
160
                                 where
                                   op_ty' = applyTysD msg op_ty (reverse rev_tys)
                                   msg = ptext (sLit "applyTypeToArgs") <+>
                                         panic_msg e op_ty
161

162
applyTypeToArgs e op_ty (_ : args)
163
  = case (splitFunTy_maybe op_ty) of
164
165
        Just (_, res_ty) -> applyTypeToArgs e res_ty args
        Nothing -> pprPanic "applyTypeToArgs" (panic_msg e op_ty)
166
167
168

panic_msg :: CoreExpr -> Type -> SDoc
panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
169
170
\end{code}

171
%************************************************************************
172
%*                                                                      *
173
\subsection{Attaching notes}
174
%*                                                                      *
175
176
177
%************************************************************************

\begin{code}
178
179
-- | Wrap the given expression in the coercion safely, dropping
-- identity coercions and coalescing nested coercions
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
mkCast :: CoreExpr -> Coercion -> CoreExpr
mkCast e co | isReflCo co = e

mkCast (Coercion e_co) co 
  = Coercion new_co
  where
       -- g :: (s1 ~# s2) ~# (t1 ~#  t2)
       -- g1 :: s1 ~# t1
       -- g2 :: s2 ~# t2
       new_co = mkSymCo g1 `mkTransCo` e_co `mkTransCo` g2
       [_reflk, g1, g2] = decomposeCo 3 co
            -- Remember, (~#) :: forall k. k -> k -> *
            -- so it takes *three* arguments, not two

mkCast (Cast expr co2) co
195
  = ASSERT(let { Pair  from_ty  _to_ty  = coercionKind co;
196
197
                 Pair _from_ty2  to_ty2 = coercionKind co2} in
           from_ty `eqType` to_ty2 )
198
    mkCast expr (mkTransCo co2 co)
199

200
mkCast expr co
201
202
  = let Pair from_ty _to_ty = coercionKind co in
--    if to_ty `eqType` from_ty
203
--    then expr
204
--    else
205
        WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
206
         (Cast expr co)
207
208
209
\end{code}

\begin{code}
210
211
212
213
-- | Wraps the given expression in the source annotation, dropping the
-- annotation if possible.
mkTick :: Tickish Id -> CoreExpr -> CoreExpr

214
215
216
217
218
219
220
221
222
mkTick t (Var x)
  | isFunTy (idType x) = Tick t (Var x)
  | otherwise
  = if tickishCounts t
       then if tickishScoped t && tickishCanSplit t
               then Tick (mkNoScope t) (Var x)
               else Tick t (Var x)
       else Var x

223
224
225
mkTick t (Cast e co)
  = Cast (mkTick t e) co -- Move tick inside cast

Simon Marlow's avatar
Simon Marlow committed
226
mkTick _ (Coercion co) = Coercion co
227

228
229
mkTick t (Lit l)
  | not (tickishCounts t) = Lit l
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275

mkTick t expr@(App f arg)
  | not (isRuntimeArg arg) = App (mkTick t f) arg
  | isSaturatedConApp expr
    = if not (tickishCounts t)
         then tickHNFArgs t expr
         else if tickishScoped t && tickishCanSplit t
                 then Tick (mkNoScope t) (tickHNFArgs (mkNoTick t) expr)
                 else Tick t expr

mkTick t (Lam x e)
     -- if this is a type lambda, or the tick does not count entries,
     -- then we can push the tick inside:
  | not (isRuntimeVar x) || not (tickishCounts t) = Lam x (mkTick t e)
     -- if it is both counting and scoped, we split the tick into its
     -- two components, keep the counting tick on the outside of the lambda
     -- and push the scoped tick inside.  The point of this is that the
     -- counting tick can probably be floated, and the lambda may then be
     -- in a position to be beta-reduced.
  | tickishScoped t && tickishCanSplit t
         = Tick (mkNoScope t) (Lam x (mkTick (mkNoTick t) e))
     -- just a counting tick: leave it on the outside
  | otherwise        = Tick t (Lam x e)

mkTick t other = Tick t other

isSaturatedConApp :: CoreExpr -> Bool
isSaturatedConApp e = go e []
  where go (App f a) as = go f (a:as)
        go (Var fun) args
           = isConLikeId fun && idArity fun == valArgCount args
        go (Cast f _) as = go f as
        go _ _ = False

mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr
mkTickNoHNF t e
  | exprIsHNF e = tickHNFArgs t e
  | otherwise   = mkTick t e

-- push a tick into the arguments of a HNF (call or constructor app)
tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr
tickHNFArgs t e = push t e
 where
  push t (App f (Type u)) = App (push t f) (Type u)
  push t (App f arg) = App (push t f) (mkTick t arg)
  push _t e = e
276
277
\end{code}

278
%************************************************************************
279
%*                                                                      *
280
\subsection{Other expression construction}
281
%*                                                                      *
282
283
284
285
%************************************************************************

\begin{code}
bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
batterseapower's avatar
batterseapower committed
286
287
288
289
290
291
292
-- ^ @bindNonRec x r b@ produces either:
--
-- > let x = r in b
--
-- or:
--
-- > case r of x { _DEFAULT_ -> b }
293
--
batterseapower's avatar
batterseapower committed
294
295
-- depending on whether we have to use a @case@ or @let@
-- binding for the expression (see 'needsCaseBinding').
296
-- It's used by the desugarer to avoid building bindings
batterseapower's avatar
batterseapower committed
297
298
299
-- that give Core Lint a heart attack, although actually
-- the simplifier deals with them perfectly well. See
-- also 'MkCore.mkCoreLet'
300
bindNonRec bndr rhs body
batterseapower's avatar
batterseapower committed
301
  | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
302
  | otherwise                          = Let (NonRec bndr rhs) body
303

batterseapower's avatar
batterseapower committed
304
305
-- | Tests whether we have to use a @case@ rather than @let@ binding for this expression
-- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"
306
needsCaseBinding :: Type -> CoreExpr -> Bool
307
needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
308
309
310
        -- Make a case expression instead of a let
        -- These can arise either from the desugarer,
        -- or from beta reductions: (\x.e) (x +# y)
311
312
313
\end{code}

\begin{code}
batterseapower's avatar
batterseapower committed
314
315
316
317
318
319
mkAltExpr :: AltCon     -- ^ Case alternative constructor
          -> [CoreBndr] -- ^ Things bound by the pattern match
          -> [Type]     -- ^ The type arguments to the case alternative
          -> CoreExpr
-- ^ This guy constructs the value that the scrutinee must have
-- given that you are in one particular branch of a case
320
mkAltExpr (DataAlt con) args inst_tys
321
  = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
322
323
mkAltExpr (LitAlt lit) [] []
  = Lit lit
324
325
mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
326
327
\end{code}

328
329

%************************************************************************
330
%*                                                                      *
331
\subsection{Taking expressions apart}
332
%*                                                                      *
333
334
%************************************************************************

335
336
The default alternative must be first, if it exists at all.
This makes it easy to find, though it makes matching marginally harder.
337
338

\begin{code}
batterseapower's avatar
batterseapower committed
339
-- | Extract the default case alternative
340
findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
341
findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
342
findDefault alts                        =                     (alts, Nothing)
343

344
345
346
347
348
isDefaultAlt :: CoreAlt -> Bool
isDefaultAlt (DEFAULT, _, _) = True
isDefaultAlt _               = False


349
-- | Find the case alternative corresponding to a particular
batterseapower's avatar
batterseapower committed
350
-- constructor: panics if no such constructor exists
351
352
353
findAlt :: AltCon -> [CoreAlt] -> Maybe CoreAlt
    -- A "Nothing" result *is* legitmiate
    -- See Note [Unreachable code]
354
findAlt con alts
355
  = case alts of
356
        (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)
357
        _                          -> go alts Nothing
358
  where
359
    go []                     deflt = deflt
360
    go (alt@(con1,_,_) : alts) deflt
361
362
363
364
      = case con `cmpAltCon` con1 of
          LT -> deflt   -- Missed it already; the alts are in increasing order
          EQ -> Just alt
          GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
365

366
367
---------------------------------
mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
batterseapower's avatar
batterseapower committed
368
369
-- ^ Merge alternatives preserving order; alternatives in
-- the first argument shadow ones in the second
370
371
372
373
mergeAlts [] as2 = as2
mergeAlts as1 [] = as1
mergeAlts (a1:as1) (a2:as2)
  = case a1 `cmpAlt` a2 of
374
375
376
        LT -> a1 : mergeAlts as1      (a2:as2)
        EQ -> a1 : mergeAlts as1      as2       -- Discard a2
        GT -> a2 : mergeAlts (a1:as1) as2
377
378
379
380


---------------------------------
trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
batterseapower's avatar
batterseapower committed
381
382
383
384
385
386
-- ^ Given:
--
-- > case (C a b x y) of
-- >        C b x y -> ...
--
-- We want to drop the leading type argument of the scrutinee
387
388
389
-- leaving the arguments to match agains the pattern

trimConArgs DEFAULT      args = ASSERT( null args ) []
390
trimConArgs (LitAlt _)   args = ASSERT( null args ) []
391
trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
392
393
\end{code}

394
395
396
Note [Unreachable code]
~~~~~~~~~~~~~~~~~~~~~~~
It is possible (although unusual) for GHC to find a case expression
397
that cannot match.  For example:
398
399
400

     data Col = Red | Green | Blue
     x = Red
401
     f v = case x of
402
              Red -> ...
403
              _ -> ...(case x of { Green -> e1; Blue -> e2 })...
404
405
406
407
408
409
410
411

Suppose that for some silly reason, x isn't substituted in the case
expression.  (Perhaps there's a NOINLINE on it, or profiling SCC stuff
gets in the way; cf Trac #3118.)  Then the full-lazines pass might produce
this

     x = Red
     lvl = case x of { Green -> e1; Blue -> e2 })
412
     f v = case x of
413
             Red -> ...
414
             _ -> ...lvl...
415
416
417
418
419
420
421
422
423

Now if x gets inlined, we won't be able to find a matching alternative
for 'Red'.  That's because 'lvl' is unreachable.  So rather than crashing
we generate (error "Inaccessible alternative").

Similar things can happen (augmented by GADTs) when the Simplifier
filters down the matching alternatives in Simplify.rebuildCase.


424
%************************************************************************
425
%*                                                                      *
426
             exprIsTrivial
427
%*                                                                      *
428
429
%************************************************************************

430
431
Note [exprIsTrivial]
~~~~~~~~~~~~~~~~~~~~
432
@exprIsTrivial@ is true of expressions we are unconditionally happy to
433
434
435
                duplicate; simple variables and constants, and type
                applications.  Note that primop Ids aren't considered
                trivial unless
436

437
438
Note [Variable are trivial]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
439
440
There used to be a gruesome test for (hasNoBinding v) in the
Var case:
441
        exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
batterseapower's avatar
batterseapower committed
442
443
The idea here is that a constructor worker, like \$wJust, is
really short for (\x -> \$wJust x), becuase \$wJust has no binding.
444
445
446
447
448
449
So it should be treated like a lambda.  Ditto unsaturated primops.
But now constructor workers are not "have-no-binding" Ids.  And
completely un-applied primops and foreign-call Ids are sufficiently
rare that I plan to allow them to be duplicated and put up with
saturating them.

450
451
452
453
454
Note [Tick trivial]
~~~~~~~~~~~~~~~~~~~
Ticks are not trivial.  If we treat "tick<n> x" as trivial, it will be
inlined inside lambdas and the entry count will be skewed, for
example.  Furthermore "scc<n> x" will turn into just "x" in mkTick.
455

456
\begin{code}
457
exprIsTrivial :: CoreExpr -> Bool
458
exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
459
460
exprIsTrivial (Type _)        = True
exprIsTrivial (Coercion _)     = True
461
462
exprIsTrivial (Lit lit)        = litIsTrivial lit
exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
463
exprIsTrivial (Tick _ _)       = False  -- See Note [Tick trivial]
464
465
466
exprIsTrivial (Cast e _)       = exprIsTrivial e
exprIsTrivial (Lam b body)     = not (isRuntimeVar b) && exprIsTrivial body
exprIsTrivial _                = False
467
468
\end{code}

469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
When substituting in a breakpoint we need to strip away the type cruft
from a trivial expression and get back to the Id.  The invariant is
that the expression we're substituting was originally trivial
according to exprIsTrivial.

\begin{code}
getIdFromTrivialExpr :: CoreExpr -> Id
getIdFromTrivialExpr e = go e
  where go (Var v) = v
        go (App f t) | not (isRuntimeArg t) = go f
        go (Cast e _) = go e
        go (Lam b e) | not (isRuntimeVar b) = go e
        go e = pprPanic "getIdFromTrivialExpr" (ppr e)
\end{code}

484
485
exprIsBottom is a very cheap and cheerful function; it may return
False for bottoming expressions, but it never costs much to ask.
486
See also CoreArity.exprBotStrictness_maybe, but that's a bit more
487
488
489
490
expensive.

\begin{code}
exprIsBottom :: CoreExpr -> Bool
491
exprIsBottom e
492
493
  = go 0 e
  where
494
495
496
    go n (Var v) = isBottomingId v &&  n >= idArity v
    go n (App e a) | isTypeArg a = go n e
                   | otherwise   = go (n+1) e
497
    go n (Tick _ e)              = go n e
498
499
500
    go n (Cast e _)              = go n e
    go n (Let _ e)               = go n e
    go _ _                       = False
501
502
\end{code}

503

504
%************************************************************************
505
%*                                                                      *
506
             exprIsDupable
507
%*                                                                      *
508
509
510
511
%************************************************************************

Note [exprIsDupable]
~~~~~~~~~~~~~~~~~~~~
512
513
514
@exprIsDupable@ is true of expressions that can be duplicated at a modest
                cost in code size.  This will only happen in different case
                branches, so there's no issue about duplicating work.
515

516
517
                That is, exprIsDupable returns True of (f x) even if
                f is very very expensive to call.
518

519
520
                Its only purpose is to avoid fruitless let-binding
                and then inlining of case join points
521
522


523
\begin{code}
524
exprIsDupable :: CoreExpr -> Bool
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
525
526
exprIsDupable e
  = isJust (go dupAppSize e)
527
  where
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
528
    go :: Int -> CoreExpr -> Maybe Int
529
530
531
    go n (Type {})     = Just n
    go n (Coercion {}) = Just n
    go n (Var {})      = decrement n
532
    go n (Tick _ e)    = go n e
533
    go n (Cast e _)    = go n e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
534
535
536
537
538
539
540
    go n (App f a) | Just n' <- go n a = go n' f
    go n (Lit lit) | litIsDupable lit = decrement n
    go _ _ = Nothing

    decrement :: Int -> Maybe Int
    decrement 0 = Nothing
    decrement n = Just (n-1)
541
542

dupAppSize :: Int
543
544
545
546
dupAppSize = 8   -- Size of term we are prepared to duplicate
                 -- This is *just* big enough to make test MethSharing
                 -- inline enough join points.  Really it should be
                 -- smaller, and could be if we fixed Trac #4960.
547
\end{code}
548

549
%************************************************************************
550
%*                                                                      *
551
             exprIsCheap, exprIsExpandable
552
%*                                                                      *
553
554
%************************************************************************

555
556
Note [exprIsCheap]   See also Note [Interaction of exprIsCheap and lone variables]
~~~~~~~~~~~~~~~~~~   in CoreUnfold.lhs
557
558
559
560
@exprIsCheap@ looks at a Core expression and returns \tr{True} if
it is obviously in weak head normal form, or is cheap to get to WHNF.
[Note that that's not the same as exprIsDupable; an expression might be
big, and hence not dupable, but still cheap.]
561
562

By ``cheap'' we mean a computation we're willing to:
563
564
        push inside a lambda, or
        inline at more than one place
565
566
567
That might mean it gets evaluated more than once, instead of being
shared.  The main examples of things which aren't WHNF but are
``cheap'' are:
568

569
570
571
  *     case e of
          pi -> ei
        (where e, and all the ei are cheap)
572

573
574
  *     let x = e in b
        (where e and b are cheap)
575

576
577
  *     op x1 ... xn
        (where op is a cheap primitive operator)
578

579
580
  *     error "foo"
        (because we are happy to substitute it inside a lambda)
581

582
583
584
Notice that a variable is considered 'cheap': we can push it inside a lambda,
because sharing will make sure it is only evaluated once.

585
586
587
Note [exprIsCheap and exprIsHNF]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note that exprIsHNF does not imply exprIsCheap.  Eg
588
        let x = fac 20 in Just x
589
590
591
This responds True to exprIsHNF (you can discard a seq), but
False to exprIsCheap.

592
\begin{code}
593
594
595
596
exprIsCheap :: CoreExpr -> Bool
exprIsCheap = exprIsCheap' isCheapApp

exprIsExpandable :: CoreExpr -> Bool
597
exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes
598

599
600
type CheapAppFun = Id -> Int -> Bool
exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
601
602
603
604
605
606
607
exprIsCheap' _        (Lit _)      = True
exprIsCheap' _        (Type _)    = True
exprIsCheap' _        (Coercion _) = True
exprIsCheap' _        (Var _)      = True
exprIsCheap' good_app (Cast e _)   = exprIsCheap' good_app e
exprIsCheap' good_app (Lam x e)    = isRuntimeVar x
                                  || exprIsCheap' good_app e
608

609
610
611
612
613
614
exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e &&
                                          and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts]
        -- Experimentally, treat (case x of ...) as cheap
        -- (and case __coerce x etc.)
        -- This improves arities of overloaded functions where
        -- there is only dictionary selection (no construction) involved
615

616
617
618
619
620
621
exprIsCheap' good_app (Tick t e)
  | tickishCounts t = False
  | otherwise       = exprIsCheap' good_app e
     -- never duplicate ticks.  If we get this wrong, then HPC's entry
     -- counts will be off (check test in libraries/hpc/tests/raytrace)

622
exprIsCheap' good_app (Let (NonRec x _) e)
623
  | isUnLiftedType (idType x) = exprIsCheap' good_app e
624
625
626
627
628
  | otherwise                 = False
        -- Strict lets always have cheap right hand sides,
        -- and do no allocation, so just look at the body
        -- Non-strict lets do allocation so we don't treat them as cheap
        -- See also
629

630
exprIsCheap' good_app other_expr        -- Applications and variables
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
631
  = go other_expr []
632
  where
633
        -- Accumulate value arguments, then decide
634
    go (Cast e _) val_args                 = go e val_args
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
635
    go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
636
                          | otherwise      = go f val_args
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
637

638
639
    go (Var _) [] = True        -- Just a type application of a variable
                                -- (f t1 t2 t3) counts as WHNF
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
640
    go (Var f) args
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
641
        = case idDetails f of
642
643
644
645
646
647
648
649
650
651
                RecSelId {}                  -> go_sel args
                ClassOpId {}                 -> go_sel args
                PrimOpId op                  -> go_primop op args
                _ | good_app f (length args) -> go_pap args
                  | isBottomingId f          -> True
                  | otherwise                -> False
                        -- Application of a function which
                        -- always gives bottom; we treat this as cheap
                        -- because it certainly doesn't need to be shared!

652
    go _ _ = False
653

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
654
    --------------
655
656
657
    go_pap args = all (exprIsCheap' good_app) args
        -- Used to be "all exprIsTrivial args" due to concerns about
        -- duplicating nested constructor applications, but see #4978.
658
659
        -- The principle here is that
        --    let x = a +# b in c *# x
Simon Peyton Jones's avatar
Simon Peyton Jones committed
660
661
        -- should behave equivalently to
        --    c *# (a +# b)
662
        -- Since lets with cheap RHSs are accepted,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
663
        -- so should paps with cheap arguments
664

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
665
    --------------
666
    go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args
667
668
669
670
671
        -- In principle we should worry about primops
        -- that return a type variable, since the result
        -- might be applied to something, but I'm not going
        -- to bother to check the number of args

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
672
    --------------
673
674
675
676
677
    go_sel [arg] = exprIsCheap' good_app arg    -- I'm experimenting with making record selection
    go_sel _     = False                -- look cheap, so we will substitute it inside a
                                        -- lambda.  Particularly for dictionary field selection.
                -- BUT: Take care with (sel d x)!  The (sel d) might be cheap, but
                --      there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)
678

679
isCheapApp :: CheapAppFun
680
isCheapApp fn n_val_args
681
  = isDataConWorkId fn
682
  || n_val_args < idArity fn
683

684
isExpandableApp :: CheapAppFun
685
686
687
688
689
690
691
692
isExpandableApp fn n_val_args
  =  isConLikeId fn
  || n_val_args < idArity fn
  || go n_val_args (idType fn)
  where
  -- See if all the arguments are PredTys (implicit params or classes)
  -- If so we'll regard it as expandable; see Note [Expandable overloadings]
     go 0 _ = True
693
     go n_val_args ty
694
695
       | Just (_, ty) <- splitForAllTy_maybe ty   = go n_val_args ty
       | Just (arg, ty) <- splitFunTy_maybe ty
696
       , isPredTy arg                             = go (n_val_args-1) ty
697
       | otherwise                                = False
698
699
\end{code}

700
701
702
703
704
705
706
707
708
709
710
711
712
Note [Expandable overloadings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose the user wrote this
   {-# RULE  forall x. foo (negate x) = h x #-}
   f x = ....(foo (negate x))....
He'd expect the rule to fire. But since negate is overloaded, we might
get this:
    f = \d -> let n = negate d in \x -> ...foo (n x)...
So we treat the application of a function (negate in this case) to a
*dictionary* as expandable.  In effect, every function is CONLIKE when
it's applied only to dictionaries.


713
%************************************************************************
714
%*                                                                      *
715
             exprOkForSpeculation
716
%*                                                                      *
717
718
%************************************************************************

719
\begin{code}
720
-----------------------------
batterseapower's avatar
batterseapower committed
721
722
-- | 'exprOkForSpeculation' returns True of an expression that is:
--
723
--  * Safe to evaluate even if normal order eval might not
batterseapower's avatar
batterseapower committed
724
725
726
727
--    evaluate the expression at all, or
--
--  * Safe /not/ to evaluate even if normal order would do so
--
728
729
-- It is usually called on arguments of unlifted type, but not always
-- In particular, Simplify.rebuildCase calls it on lifted types
730
-- when a 'case' is a plain 'seq'. See the example in
731
732
-- Note [exprOkForSpeculation: case expressions] below
--
batterseapower's avatar
batterseapower committed
733
734
-- Precisely, it returns @True@ iff:
--
735
736
--  * The expression guarantees to terminate,
--  * soon,
batterseapower's avatar
batterseapower committed
737
738
739
740
741
742
743
744
745
746
747
--  * without raising an exception,
--  * without causing a side effect (e.g. writing a mutable variable)
--
-- Note that if @exprIsHNF e@, then @exprOkForSpecuation e@.
-- As an example of the considerations in this test, consider:
--
-- > let x = case y# +# 1# of { r# -> I# r# }
-- > in E
--
-- being translated to:
--
748
-- > case y# +# 1# of { r# ->
batterseapower's avatar
batterseapower committed
749
-- >    let x = I# r#
750
-- >    in E
batterseapower's avatar
batterseapower committed
751
-- > }
752
--
batterseapower's avatar
batterseapower committed
753
754
-- We can only do this if the @y + 1@ is ok for speculation: it has no
-- side effects, and can't diverge or raise an exception.
755
756
757
exprOkForSpeculation :: Expr b -> Bool
  -- Polymorphic in binder type
  -- There is one call at a non-Id binder type, in SetLevels
758
759
760
exprOkForSpeculation (Lit _)      = True
exprOkForSpeculation (Type _)     = True
exprOkForSpeculation (Coercion _) = True
761
762
exprOkForSpeculation (Var v)      = appOkForSpeculation v []
exprOkForSpeculation (Cast e _)   = exprOkForSpeculation e
763
764
765
766
767
768
769

-- Tick annotations that *tick* cannot be speculated, because these
-- are meant to identify whether or not (and how often) the particular
-- source expression was evaluated at runtime.
exprOkForSpeculation (Tick tickish e)
   | tickishCounts tickish = False
   | otherwise             = exprOkForSpeculation e
770

771
exprOkForSpeculation (Case e _ _ alts)
772
773
  =  exprOkForSpeculation e  -- Note [exprOkForSpeculation: case expressions]
  && all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts
774
  && altsAreExhaustive alts     -- Note [exprOkForSpeculation: exhaustive alts]
775

776
exprOkForSpeculation other_expr
777
  = case collectArgs other_expr of
778
        (Var f, args) -> appOkForSpeculation f args
779
        _             -> False
780

781
782
783
784
785
786
787
788
789
790
-----------------------------
appOkForSpeculation :: Id -> [Expr b] -> Bool
appOkForSpeculation fun args
  = case idDetails fun of
      DFunId new_type ->  not new_type
         -- DFuns terminate, unless the dict is implemented 
         -- with a newtype in which case they may not

      DataConWorkId {} -> True
                -- The strictness of the constructor has already
791
792
                -- been expressed by its "wrapper", so we don't need
                -- to take the arguments into account
793

794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
      PrimOpId op
        | isDivOp op              -- Special case for dividing operations that fail
        , [arg1, Lit lit] <- args -- only if the divisor is zero
        -> not (isZeroLit lit) && exprOkForSpeculation arg1
                  -- Often there is a literal divisor, and this
                  -- can get rid of a thunk in an inner looop

        | DataToTagOp <- op      -- See Note [dataToTag speculation]
        -> True

        | otherwise
        -> primOpOkForSpeculation op &&
           all exprOkForSpeculation args
                                  -- A bit conservative: we don't really need
                                  -- to care about lazy arguments, but this is easy

      _other -> isUnLiftedType (idType fun)          -- c.f. the Var case of exprIsHNF
             || idArity fun > n_val_args             -- Partial apps
             || (n_val_args ==0 && 
                 isEvaldUnfolding (idUnfolding fun)) -- Let-bound values
             where
               n_val_args = valArgCount args

-----------------------------
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
altsAreExhaustive :: [Alt b] -> Bool
-- True  <=> the case alterantives are definiely exhaustive
-- False <=> they may or may not be
altsAreExhaustive []
  = False    -- Should not happen
altsAreExhaustive ((con1,_,_) : alts)
  = case con1 of
      DEFAULT   -> True
      LitAlt {} -> False
      DataAlt c -> 1 + length alts == tyConFamilySize (dataConTyCon c)
      -- It is possible to have an exhaustive case that does not
      -- enumerate all constructors, notably in a GADT match, but
      -- we behave conservatively here -- I don't think it's important
      -- enough to deserve special treatment

batterseapower's avatar
batterseapower committed
833
-- | True of dyadic operators that can fail only if the second arg is zero!
834
isDivOp :: PrimOp -> Bool
835
836
-- This function probably belongs in PrimOp, or even in
-- an automagically generated file.. but it's such a
837
-- special case I thought I'd leave it here for now.
838
839
840
841
isDivOp IntQuotOp        = True
isDivOp IntRemOp         = True
isDivOp WordQuotOp       = True
isDivOp WordRemOp        = True
842
843
isDivOp FloatDivOp       = True
isDivOp DoubleDivOp      = True
844
isDivOp _                = False
845
846
\end{code}

847
Note [exprOkForSpeculation: case expressions]
848
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
849
850
It's always sound for exprOkForSpeculation to return False, and we
don't want it to take too long, so it bales out on complicated-looking
851
terms.  Notably lets, which can be stacked very deeply; and in any
852
853
854
855
case the argument of exprOkForSpeculation is usually in a strict context,
so any lets will have been floated away.

However, we keep going on case-expressions.  An example like this one
856
showed up in DPH code (Trac #3717):
857
858
859
860
861
862
863
864
865
    foo :: Int -> Int
    foo 0 = 0
    foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)

If exprOkForSpeculation doesn't look through case expressions, you get this:
    T.$wfoo =
      \ (ww :: GHC.Prim.Int#) ->
        case ww of ds {
          __DEFAULT -> case (case <# ds 5 of _ {
Ian Lynagh's avatar
Ian Lynagh committed
866
867
                          GHC.Types.False -> lvl1;
                          GHC.Types.True -> lvl})
868
869
870
871
872
873
874
                       of _ { __DEFAULT ->
                       T.$wfoo (GHC.Prim.-# ds_XkE 1) };
          0 -> 0
        }

The inner case is redundant, and should be nuked.

875
876
877
Note [exprOkForSpeculation: exhaustive alts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We might have something like
878
  case x of {
879
880
    A -> ...
    _ -> ...(case x of { B -> ...; C -> ... })...
881
882
Here, the inner case is fine, becuase the A alternative
can't happen, but it's not ok to float the inner case outside
883
884
885
886
887
the outer one (even if we know x is evaluated outside), because
then it would be non-exhaustive. See Trac #5453.

Similarly, this is a valid program (albeit a slightly dodgy one)
   let v = case x of { B -> ...; C -> ... }
888
   in case x of
889
890
891
892
893
894
895
896
         A -> ...
         _ ->  ...v...v....
But we don't want to speculate the v binding.

One could try to be clever, but the easy fix is simpy to regard
a non-exhaustive case as *not* okForSpeculation.


897
898
899
900
901
902
903
904
905
906
907
908
909
Note [dataToTag speculation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Is this OK?
   f x = let v::Int# = dataToTag# x
         in ...
We say "yes", even though 'x' may not be evaluated.  Reasons

  * dataToTag#'s strictness means that its argument often will be
    evaluated, but FloatOut makes that temporarily untrue
         case x of y -> let v = dataToTag# y in ...
    -->
         case x of y -> let v = dataToTag# x in ...
    Note that we look at 'x' instead of 'y' (this is to improve
910
911
    floating in FloatOut).  So Lint complains.

912
913
    Moreover, it really *might* improve floating to let the
    v-binding float out
914

915
916
917
  * CorePrep makes sure dataToTag#'s argument is evaluated, just
    before code gen.  Until then, it's not guaranteed

918

919
%************************************************************************
920
%*                                                                      *
921
             exprIsHNF, exprIsConLike
922
%*                                                                      *
923
924
%************************************************************************

925
\begin{code}
926
-- Note [exprIsHNF]             See also Note [exprIsCheap and exprIsHNF]
927
-- ~~~~~~~~~~~~~~~~
928
929
-- | exprIsHNF returns true for expressions that are certainly /already/
-- evaluated to /head/ normal form.  This is used to decide whether it's ok
930
931
932
933
934
935
936
937
938
-- to change:
--
-- > case x of _ -> e
--
--    into:
--
-- > e
--
-- and to decide whether it's safe to discard a 'seq'.
939
--
940
941
942
943
944
945
946
947
948
949
950
951
952
953
-- So, it does /not/ treat variables as evaluated, unless they say they are.
-- However, it /does/ treat partial applications and constructor applications
-- as values, even if their arguments are non-trivial, provided the argument
-- type is lifted. For example, both of these are values:
--
-- > (:) (f x) (map f xs)
-- > map (...redex...)
--
-- because 'seq' on such things completes immediately.
--
-- For unlifted argument types, we have to be careful:
--
-- > C (f x :: Int#)
--
954
-- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't
955
956
-- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
-- unboxed type must be ok-for-speculation (or trivial).
957
exprIsHNF :: CoreExpr -> Bool           -- True => Value-lambda, constructor, PAP
958
exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding
959
960
\end{code}

961
\begin{code}
962
963
964
-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as
-- data constructors. Conlike arguments are considered interesting by the
-- inliner.
965
exprIsConLike :: CoreExpr -> Bool       -- True => lambda, conlike, PAP
966
967
exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding

968
969
970
971
972
973
974
-- | Returns true for values or value-like expressions. These are lambdas,
-- constructors / CONLIKE functions (as determined by the function argument)
-- or PAPs.
--
exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike is_con is_con_unf = is_hnf_like
  where
975
    is_hnf_like (Var v) -- NB: There are no value args at this point
976
977
978
      =  is_con v       -- Catches nullary constructors,
                        --      so that [] and () are values, for example
      || idArity v > 0  -- Catches (e.g.) primops that don't have unfoldings
979
      || is_con_unf (idUnfolding v)
980
981
982
983
        -- Check the thing's unfolding; it might be bound to a value
        -- We don't look through loop breakers here, which is a bit conservative
        -- but otherwise I worry that if an Id's unfolding is just itself,
        -- we could get an infinite loop
984
985

    is_hnf_like (Lit _)          = True
986
    is_hnf_like (Type _)         = True       -- Types are honorary Values;
987
                                              -- we don't mind copying them
988
    is_hnf_like (Coercion _)     = True       -- Same for coercions
989
    is_hnf_like (Lam b e)        = isRuntimeVar b || is_hnf_like e
990
991
992
    is_hnf_like (Tick tickish e) = not (tickishCounts tickish)
                                      && is_hnf_like e
                                      -- See Note [exprIsHNF Tick]
993
994
    is_hnf_like (Cast e _)           = is_hnf_like e
    is_hnf_like (App e (Type _))     = is_hnf_like e
995
    is_hnf_like (App e (Coercion _)) = is_hnf_like e
996
997
998
    is_hnf_like (App e a)            = app_is_value e [a]
    is_hnf_like (Let _ e)            = is_hnf_like e  -- Lazy let(rec)s don't affect us
    is_hnf_like _                    = False
999
1000

    -- There is at least one value argument