CoreUtils.hs 82.6 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Simon Marlow's avatar
Simon Marlow committed
5
6

Utility functions on @Core@ syntax
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9
10
{-# LANGUAGE CPP #-}

batterseapower's avatar
batterseapower committed
11
-- | Commonly useful utilites for manipulating the Core language
12
module CoreUtils (
13
        -- * Constructing expressions
14
        mkCast,
Peter Wortmann's avatar
Peter Wortmann committed
15
        mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,
Simon Marlow's avatar
Simon Marlow committed
16
        bindNonRec, needsCaseBinding,
17
        mkAltExpr,
18

19
        -- * Taking expressions apart
20
21
        findDefault, findAlt, isDefaultAlt,
        mergeAlts, trimConArgs, filterAlts,
22

23
        -- * Properties of expressions
Simon Marlow's avatar
Simon Marlow committed
24
        exprType, coreAltType, coreAltsType,
25
        exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
26
        exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
27
        exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
28
29
        exprIsBig, exprIsConLike,
        rhsIsStatic, isCheapApp, isExpandableApp,
30

31
32
33
        -- * Expression and bindings size
        coreBindsSize, exprSize,
        CoreStats(..), coreBindsStats,
34

35
        -- * Equality
Peter Wortmann's avatar
Peter Wortmann committed
36
        cheapEqExpr, cheapEqExpr', eqExpr,
Peter Wortmann's avatar
Peter Wortmann committed
37
        diffExpr, diffBinds,
38

39
40
        -- * Eta reduction
        tryEtaReduce,
41

42
43
        -- * Manipulating data constructors and types
        applyTypeToArgs, applyTypeToArg,
Peter Wortmann's avatar
Peter Wortmann committed
44
45
46
47
        dataConRepInstPat, dataConRepFSInstPat,

        -- * Working with ticks
        stripTicksTop, stripTicksTopE, stripTicksTopT, stripTicks,
48
    ) where
49

50
#include "HsVersions.h"
51

52
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
53
import PprCore
54
import CoreFVs( exprFreeVars )
Simon Marlow's avatar
Simon Marlow committed
55
56
import Var
import SrcLoc
57
import VarEnv
58
import VarSet
Simon Marlow's avatar
Simon Marlow committed
59
60
61
62
63
64
65
66
67
68
import Name
import Literal
import DataCon
import PrimOp
import Id
import IdInfo
import Type
import Coercion
import TyCon
import Unique
69
import Outputable
Simon Marlow's avatar
Simon Marlow committed
70
import TysPrim
71
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
72
import FastString
73
import Maybes
74
import Platform
Simon Marlow's avatar
Simon Marlow committed
75
import Util
76
import Pair
Peter Wortmann's avatar
Peter Wortmann committed
77
import Data.Function       ( on )
78
import Data.List
Peter Wortmann's avatar
Peter Wortmann committed
79
import Data.Ord            ( comparing )
Peter Wortmann's avatar
Peter Wortmann committed
80
81
82
83
84
import Control.Applicative
#if __GLASGOW_HASKELL__ < 709
import Data.Traversable    ( traverse )
#endif
import OrdList
85

Austin Seipp's avatar
Austin Seipp committed
86
87
88
{-
************************************************************************
*                                                                      *
89
\subsection{Find the type of a Core atom/expression}
Austin Seipp's avatar
Austin Seipp committed
90
91
92
*                                                                      *
************************************************************************
-}
93

94
exprType :: CoreExpr -> Type
batterseapower's avatar
batterseapower committed
95
96
97
-- ^ 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
98
99
100
exprType (Var var)           = idType var
exprType (Lit lit)           = literalType lit
exprType (Coercion co)       = coercionType co
Austin Seipp's avatar
Austin Seipp committed
101
exprType (Let bind body)
102
103
104
  | NonRec tv rhs <- bind    -- See Note [Type bindings]
  , Type ty <- rhs           = substTyWith [tv] [ty] (exprType body)
  | otherwise                = exprType body
105
exprType (Case _ _ ty _)     = ty
106
exprType (Cast _ co)         = pSnd (coercionKind co)
107
exprType (Tick _ e)          = exprType e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
108
exprType (Lam binder expr)   = mkPiType binder (exprType expr)
109
exprType e@(App _ _)
110
  = case collectArgs e of
111
        (fun, args) -> applyTypeToArgs e (exprType fun) args
112

113
exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
114

115
coreAltType :: CoreAlt -> Type
batterseapower's avatar
batterseapower committed
116
-- ^ Returns the type of the alternatives right hand side
117
coreAltType (_,bs,rhs)
118
119
120
121
122
  | any bad_binder bs = expandTypeSynonyms ty
  | otherwise         = ty    -- Note [Existential variables and silly type synonyms]
  where
    ty           = exprType rhs
    free_tvs     = tyVarsOfType ty
123
    bad_binder b = isTyVar b && b `elemVarSet` free_tvs
124
125

coreAltsType :: [CoreAlt] -> Type
batterseapower's avatar
batterseapower committed
126
-- ^ Returns the type of the first alternative, which should be the same as for all alternatives
127
coreAltsType (alt:_) = coreAltType alt
128
coreAltsType []      = panic "corAltsType"
129

Austin Seipp's avatar
Austin Seipp committed
130
{-
131
132
133
134
135
136
Note [Type bindings]
~~~~~~~~~~~~~~~~~~~~
Core does allow type bindings, although such bindings are
not much used, except in the output of the desuguarer.
Example:
     let a = Int in (\x:a. x)
Austin Seipp's avatar
Austin Seipp committed
137
Given this, exprType must be careful to substitute 'a' in the
138
139
result type (Trac #8522).

140
141
142
Note [Existential variables and silly type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
143
144
145
146
        data T = forall a. T (Funny a)
        type Funny a = Bool
        f :: T -> Bool
        f (T x) = x
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162

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.
Austin Seipp's avatar
Austin Seipp committed
163
-}
164

165
applyTypeToArg :: Type -> CoreExpr -> Type
166
167
-- ^ Determines the type resulting from applying an expression with given type
-- to a given argument expression
168
applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
169
applyTypeToArg fun_ty _             = funResultTy fun_ty
170

171
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
batterseapower's avatar
batterseapower committed
172
173
-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
-- The first argument is just for debugging, and gives some context
174
175
applyTypeToArgs e op_ty args
  = go op_ty args
176
  where
177
178
179
180
181
182
183
    go op_ty []               = op_ty
    go op_ty (Type ty : args) = go_ty_args op_ty [ty] args
    go op_ty (_ : args)       | Just (_, res_ty) <- splitFunTy_maybe op_ty
                              = go res_ty args
    go _ _ = pprPanic "applyTypeToArgs" panic_msg

    -- go_ty_args: accumulate type arguments so we can instantiate all at once
Simon Peyton Jones's avatar
Simon Peyton Jones committed
184
    go_ty_args op_ty rev_tys (Type ty : args)
185
186
187
       = go_ty_args op_ty (ty:rev_tys) args
    go_ty_args op_ty rev_tys args
       = go (applyTysD panic_msg_w_hdr op_ty (reverse rev_tys)) args
Simon Peyton Jones's avatar
Simon Peyton Jones committed
188

189
190
191
192
    panic_msg_w_hdr = hang (ptext (sLit "applyTypeToArgs")) 2 panic_msg
    panic_msg = vcat [ ptext (sLit "Expression:") <+> pprCoreExpr e
                     , ptext (sLit "Type:") <+> ppr op_ty
                     , ptext (sLit "Args:") <+> ppr args ]
193

Austin Seipp's avatar
Austin Seipp committed
194
195
196
{-
************************************************************************
*                                                                      *
197
\subsection{Attaching notes}
Austin Seipp's avatar
Austin Seipp committed
198
199
200
*                                                                      *
************************************************************************
-}
201

202
203
-- | Wrap the given expression in the coercion safely, dropping
-- identity coercions and coalescing nested coercions
204
mkCast :: CoreExpr -> Coercion -> CoreExpr
205
206
mkCast e co | ASSERT2( coercionRole co == Representational
                     , ptext (sLit "coercion") <+> ppr co <+> ptext (sLit "passed to mkCast") <+> ppr e <+> ptext (sLit "has wrong role") <+> ppr (coercionRole co) )
207
              isReflCo co = e
208

Austin Seipp's avatar
Austin Seipp committed
209
mkCast (Coercion e_co) co
210
211
212
213
  | isCoVarType (pSnd (coercionKind co))
       -- The guard here checks that g has a (~#) on both sides,
       -- otherwise decomposeCo fails.  Can in principle happen
       -- with unsafeCoerce
214
  = Coercion (mkCoCast e_co co)
215
216

mkCast (Cast expr co2) co
217
218
219
220
221
222
  = WARN(let { Pair  from_ty  _to_ty  = coercionKind co;
               Pair _from_ty2  to_ty2 = coercionKind co2} in
            not (from_ty `eqType` to_ty2),
             vcat ([ ptext (sLit "expr:") <+> ppr expr
                   , ptext (sLit "co2:") <+> ppr co2
                   , ptext (sLit "co:") <+> ppr co ]) )
223
    mkCast expr (mkTransCo co2 co)
224

Peter Wortmann's avatar
Peter Wortmann committed
225
226
227
mkCast (Tick t expr) co
   = Tick t (mkCast expr co)

228
mkCast expr co
229
230
  = let Pair from_ty _to_ty = coercionKind co in
--    if to_ty `eqType` from_ty
231
--    then expr
232
--    else
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
233
        WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co))
234
         (Cast expr co)
235

236
237
238
-- | Wraps the given expression in the source annotation, dropping the
-- annotation if possible.
mkTick :: Tickish Id -> CoreExpr -> CoreExpr
Peter Wortmann's avatar
Peter Wortmann committed
239
240
241
242
243
mkTick t orig_expr = mkTick' id id orig_expr
 where
  -- Some ticks (cost-centres) can be split in two, with the
  -- non-counting part having laxer placement properties.
  canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t
244

Peter Wortmann's avatar
Peter Wortmann committed
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
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
  mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through)
          -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with)
          -> CoreExpr               -- ^ current expression
          -> CoreExpr
  mkTick' top rest expr = case expr of

    -- Cost centre ticks should never be reordered relative to each
    -- other. Therefore we can stop whenever two collide.
    Tick t2 e
      | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr

    -- Otherwise we assume that ticks of different placements float
    -- through each other.
      | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e

    -- For annotations this is where we make sure to not introduce
    -- redundant ticks.
      | tickishContains t t2              -> mkTick' top rest e
      | tickishContains t2 t              -> orig_expr
      | otherwise                         -> mkTick' top (rest . Tick t2) e

    -- Ticks don't care about types, so we just float all ticks
    -- through them. Note that it's not enough to check for these
    -- cases top-level. While mkTick will never produce Core with type
    -- expressions below ticks, such constructs can be the result of
    -- unfoldings. We therefore make an effort to put everything into
    -- the right place no matter what we start with.
    Cast e co   -> mkTick' (top . flip Cast co) rest e
    Coercion co -> Coercion co

    Lam x e
      -- Always float through type lambdas. Even for non-type lambdas,
      -- floating is allowed for all but the most strict placement rule.
      | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime
      -> mkTick' (top . Lam x) rest e

      -- If it is both counting and scoped, we split the tick into its
      -- two components, often allowing us to 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.
      | canSplit
      -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e

    App f arg
      -- Always float through type applications.
      | not (isRuntimeArg arg)
      -> mkTick' (top . flip App arg) rest f

      -- We can also float through constructor applications, placement
      -- permitting. Again we can split.
      | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit)
      -> if tickishPlace t == PlaceCostCentre
         then top $ rest $ tickHNFArgs t expr
         else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr

    Var x
      | not (isFunTy (idType x)) && tickishPlace t == PlaceCostCentre
      -> orig_expr
      | canSplit
      -> top $ Tick (mkNoScope t) $ rest expr

    Lit{}
      | tickishPlace t == PlaceCostCentre
      -> orig_expr

    -- Catch-all: Annotate where we stand
    _any -> top $ Tick t $ rest expr

mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr
mkTicks ticks expr = foldr mkTick expr ticks
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337

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
338

Peter Wortmann's avatar
Peter Wortmann committed
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
-- | Strip ticks satisfying a predicate from top of an expression
stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
stripTicksTop p = go []
  where go ts (Tick t e) | p t = go (t:ts) e
        go ts other            = (reverse ts, other)

-- | Strip ticks satisfying a predicate from top of an expression,
-- returning the remaining expresion
stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksTopE p = go
  where go (Tick t e) | p t = go e
        go other            = other

-- | Strip ticks satisfying a predicate from top of an expression,
-- returning the ticks
stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
stripTicksTopT p = go []
  where go ts (Tick t e) | p t = go (t:ts) e
        go ts _                = ts

-- | Completely strip ticks satisfying a predicate from an
-- expression. Note this is O(n) in the size of the expression!
stripTicks :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
stripTicks p expr = (fromOL ticks, expr')
  where (ticks, expr') = go expr
        -- Note that  OrdList (Tickish Id) is a Monoid, which makes
        -- ((,) (OrdList (Tickish Id))) an Applicative.
        go (App e a)        = App <$> go e <*> go a
        go (Lam b e)        = Lam b <$> go e
        go (Let b e)        = Let <$> go_bs b <*> go e
        go (Case e b t as)  = Case <$> go e <*> pure b <*> pure t
                                   <*> traverse go_a as
        go (Cast e c)       = Cast <$> go e <*> pure c
        go (Tick t e)
          | p t             = let (ts, e') = go e in (t `consOL` ts, e')
          | otherwise       = Tick t <$> go e
        go other            = pure other
        go_bs (NonRec b e)  = NonRec b <$> go e
        go_bs (Rec bs)      = Rec <$> traverse go_b bs
        go_b (b, e)         = (,) <$> pure b <*> go e
        go_a (c,bs,e)       = (,,) <$> pure c <*> pure bs <*> go e

Austin Seipp's avatar
Austin Seipp committed
381
382
383
{-
************************************************************************
*                                                                      *
384
\subsection{Other expression construction}
Austin Seipp's avatar
Austin Seipp committed
385
386
387
*                                                                      *
************************************************************************
-}
388
389

bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
batterseapower's avatar
batterseapower committed
390
391
392
393
394
395
396
-- ^ @bindNonRec x r b@ produces either:
--
-- > let x = r in b
--
-- or:
--
-- > case r of x { _DEFAULT_ -> b }
397
--
batterseapower's avatar
batterseapower committed
398
399
-- depending on whether we have to use a @case@ or @let@
-- binding for the expression (see 'needsCaseBinding').
400
-- It's used by the desugarer to avoid building bindings
batterseapower's avatar
batterseapower committed
401
402
403
-- that give Core Lint a heart attack, although actually
-- the simplifier deals with them perfectly well. See
-- also 'MkCore.mkCoreLet'
404
bindNonRec bndr rhs body
batterseapower's avatar
batterseapower committed
405
  | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
406
  | otherwise                          = Let (NonRec bndr rhs) body
407

batterseapower's avatar
batterseapower committed
408
409
-- | 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"
410
needsCaseBinding :: Type -> CoreExpr -> Bool
411
needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
412
413
414
        -- Make a case expression instead of a let
        -- These can arise either from the desugarer,
        -- or from beta reductions: (\x.e) (x +# y)
415

batterseapower's avatar
batterseapower committed
416
417
418
419
420
421
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
422
mkAltExpr (DataAlt con) args inst_tys
423
  = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
424
425
mkAltExpr (LitAlt lit) [] []
  = Lit lit
426
427
mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
428

Austin Seipp's avatar
Austin Seipp committed
429
430
431
{-
************************************************************************
*                                                                      *
432
\subsection{Taking expressions apart}
Austin Seipp's avatar
Austin Seipp committed
433
434
*                                                                      *
************************************************************************
435

436
437
The default alternative must be first, if it exists at all.
This makes it easy to find, though it makes matching marginally harder.
Austin Seipp's avatar
Austin Seipp committed
438
-}
439

batterseapower's avatar
batterseapower committed
440
-- | Extract the default case alternative
441
findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
442
findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
443
findDefault alts                        =                     (alts, Nothing)
444

445
isDefaultAlt :: (AltCon, a, b) -> Bool
446
447
448
449
isDefaultAlt (DEFAULT, _, _) = True
isDefaultAlt _               = False


450
-- | Find the case alternative corresponding to a particular
batterseapower's avatar
batterseapower committed
451
-- constructor: panics if no such constructor exists
452
findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
453
454
    -- A "Nothing" result *is* legitmiate
    -- See Note [Unreachable code]
455
findAlt con alts
456
  = case alts of
457
        (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)
458
        _                          -> go alts Nothing
459
  where
460
    go []                     deflt = deflt
461
    go (alt@(con1,_,_) : alts) deflt
462
463
464
465
      = 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
466

467
---------------------------------
468
mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
batterseapower's avatar
batterseapower committed
469
470
-- ^ Merge alternatives preserving order; alternatives in
-- the first argument shadow ones in the second
471
472
473
474
mergeAlts [] as2 = as2
mergeAlts as1 [] = as1
mergeAlts (a1:as1) (a2:as2)
  = case a1 `cmpAlt` a2 of
475
476
477
        LT -> a1 : mergeAlts as1      (a2:as2)
        EQ -> a1 : mergeAlts as1      as2       -- Discard a2
        GT -> a2 : mergeAlts (a1:as1) as2
478
479
480
481


---------------------------------
trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
batterseapower's avatar
batterseapower committed
482
483
484
485
486
487
-- ^ Given:
--
-- > case (C a b x y) of
-- >        C b x y -> ...
--
-- We want to drop the leading type argument of the scrutinee
488
489
490
-- leaving the arguments to match agains the pattern

trimConArgs DEFAULT      args = ASSERT( null args ) []
491
trimConArgs (LitAlt _)   args = ASSERT( null args ) []
492
trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
493

494
495
filterAlts :: [Unique]             -- ^ Supply of uniques used in case we have to manufacture a new AltCon
           -> Type                 -- ^ Type of scrutinee (used to prune possibilities)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
496
           -> [AltCon]             -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee
497
498
499
           -> [(AltCon, [Var], a)] -- ^ Alternatives
           -> ([AltCon], Bool, [(AltCon, [Var], a)])
             -- Returns:
Austin Seipp's avatar
Austin Seipp committed
500
             --  1. Constructors that will never be encountered by the
Simon Peyton Jones's avatar
Simon Peyton Jones committed
501
502
503
504
505
506
507
             --     *default* case (if any).  A superset of imposs_cons
             --  2. Whether we managed to refine the default alternative into a specific constructor (for statistics only)
             --  3. The new alternatives, trimmed by
             --        a) remove imposs_cons
             --        b) remove constructors which can't match because of GADTs
             --      and with the DEFAULT expanded to a DataAlt if there is exactly
             --      remaining constructor that can match
508
509
510
             --
             -- NB: the final list of alternatives may be empty:
             -- This is a tricky corner case.  If the data type has no constructors,
Austin Seipp's avatar
Austin Seipp committed
511
             -- which GHC allows, or if the imposs_cons covers all constructors (after taking
Simon Peyton Jones's avatar
Simon Peyton Jones committed
512
             -- account of GADTs), then no alternatives can match.
513
514
515
516
             --
             -- If callers need to preserve the invariant that there is always at least one branch
             -- in a "case" statement then they will need to manually add a dummy case branch that just
             -- calls "error" or similar.
Austin Seipp's avatar
Austin Seipp committed
517
filterAlts us ty imposs_cons alts
518
519
520
521
  | Just (tycon, inst_tys) <- splitTyConApp_maybe ty
  = filter_alts tycon inst_tys
  | otherwise
  = (imposs_cons, False, alts)
522
523
524
  where
    (alts_wo_default, maybe_deflt) = findDefault alts
    alt_cons = [con | (con,_,_) <- alts_wo_default]
525

Austin Seipp's avatar
Austin Seipp committed
526
    filter_alts tycon inst_tys
527
528
529
530
531
      = (imposs_deflt_cons, refined_deflt, merged_alts)
     where
       trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default

       imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
Austin Seipp's avatar
Austin Seipp committed
532
533
         -- "imposs_deflt_cons" are handled
         --   EITHER by the context,
534
535
536
         --   OR by a non-DEFAULT branch in this case expression.

       merged_alts  = mergeAlts trimmed_alts (maybeToList maybe_deflt')
Austin Seipp's avatar
Austin Seipp committed
537
         -- We need the mergeAlts in case the new default_alt
538
539
540
541
542
543
         -- has turned into a constructor alternative.
         -- The merge keeps the inner DEFAULT at the front, if there is one
         -- and interleaves the alternatives in the right order

       (refined_deflt, maybe_deflt') = case maybe_deflt of
          Nothing -> (False, Nothing)
Austin Seipp's avatar
Austin Seipp committed
544
545
          Just deflt_rhs
             | isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.
546
547
548
549
             , not (isNewTyCon tycon)      -- We can have a newtype, if we are just doing an eval:
                                           --      case x of { DEFAULT -> e }
                                           -- and we don't want to fill in a default for them!
             , Just all_cons <- tyConDataCons_maybe tycon
Austin Seipp's avatar
Austin Seipp committed
550
             , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons]   -- We now know it's a data type
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
                   impossible con   = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
             -> case filterOut impossible all_cons of
                  -- Eliminate the default alternative
                  -- altogether if it can't match:
                  []    -> (False, Nothing)
                  -- It matches exactly one constructor, so fill it in:
                  [con] -> (True, Just (DataAlt con, ex_tvs ++ arg_ids, deflt_rhs))
                    where (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys
                  _     -> (False, Just (DEFAULT, [], deflt_rhs))

             | debugIsOn, isAlgTyCon tycon
             , null (tyConDataCons tycon)
             , not (isFamilyTyCon tycon || isAbstractTyCon tycon)
                   -- Check for no data constructors
                   -- This can legitimately happen for abstract types and type families,
                   -- so don't report that
             -> pprTrace "prepareDefault" (ppr tycon)
                (False, Just (DEFAULT, [], deflt_rhs))

             | otherwise -> (False, Just (DEFAULT, [], deflt_rhs))

    impossible_alt :: [Type] -> (AltCon, a, b) -> Bool
    impossible_alt _ (con, _, _) | con `elem` imposs_cons = True
    impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con
    impossible_alt _  _                         = False
576

Austin Seipp's avatar
Austin Seipp committed
577
{-
578
579
580
Note [Unreachable code]
~~~~~~~~~~~~~~~~~~~~~~~
It is possible (although unusual) for GHC to find a case expression
581
that cannot match.  For example:
582
583
584

     data Col = Red | Green | Blue
     x = Red
585
     f v = case x of
586
              Red -> ...
587
              _ -> ...(case x of { Green -> e1; Blue -> e2 })...
588
589
590
591
592
593
594
595

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 })
596
     f v = case x of
597
             Red -> ...
598
             _ -> ...lvl...
599
600
601
602
603
604
605
606
607

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.


Austin Seipp's avatar
Austin Seipp committed
608
609
************************************************************************
*                                                                      *
610
             exprIsTrivial
Austin Seipp's avatar
Austin Seipp committed
611
612
*                                                                      *
************************************************************************
613

614
615
Note [exprIsTrivial]
~~~~~~~~~~~~~~~~~~~~
616
@exprIsTrivial@ is true of expressions we are unconditionally happy to
617
618
619
                duplicate; simple variables and constants, and type
                applications.  Note that primop Ids aren't considered
                trivial unless
620

621
622
Note [Variable are trivial]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
623
624
There used to be a gruesome test for (hasNoBinding v) in the
Var case:
625
        exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
batterseapower's avatar
batterseapower committed
626
The idea here is that a constructor worker, like \$wJust, is
Gabor Greif's avatar
typos    
Gabor Greif committed
627
really short for (\x -> \$wJust x), because \$wJust has no binding.
628
629
630
631
632
633
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.

634
635
Note [Tick trivial]
~~~~~~~~~~~~~~~~~~~
Peter Wortmann's avatar
Peter Wortmann committed
636
637
638
639
640

Ticks are only trivial if they are pure annotations. 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.
Austin Seipp's avatar
Austin Seipp committed
641
-}
642

643
exprIsTrivial :: CoreExpr -> Bool
644
exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
Peter Wortmann's avatar
Peter Wortmann committed
645
exprIsTrivial (Type _)         = True
646
exprIsTrivial (Coercion _)     = True
647
648
exprIsTrivial (Lit lit)        = litIsTrivial lit
exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
Peter Wortmann's avatar
Peter Wortmann committed
649
650
exprIsTrivial (Tick t e)       = not (tickishIsCode t) && exprIsTrivial e
                                 -- See Note [Tick trivial]
651
652
653
exprIsTrivial (Cast e _)       = exprIsTrivial e
exprIsTrivial (Lam b body)     = not (isRuntimeVar b) && exprIsTrivial body
exprIsTrivial _                = False
654

Austin Seipp's avatar
Austin Seipp committed
655
{-
656
657
658
659
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.
Austin Seipp's avatar
Austin Seipp committed
660
-}
661
662
663
664
665
666
667
668
669

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)

Austin Seipp's avatar
Austin Seipp committed
670
{-
671
exprIsBottom is a very cheap and cheerful function; it may return
672
673
False for bottoming expressions, but it never costs much to ask.  See
also CoreArity.exprBotStrictness_maybe, but that's a bit more
674
expensive.
Austin Seipp's avatar
Austin Seipp committed
675
-}
676
677

exprIsBottom :: CoreExpr -> Bool
678
exprIsBottom e
679
680
  = go 0 e
  where
681
682
683
    go n (Var v) = isBottomingId v &&  n >= idArity v
    go n (App e a) | isTypeArg a = go n e
                   | otherwise   = go (n+1) e
684
    go n (Tick _ e)              = go n e
685
686
687
    go n (Cast e _)              = go n e
    go n (Let _ e)               = go n e
    go _ _                       = False
688

Austin Seipp's avatar
Austin Seipp committed
689
690
691
{-
************************************************************************
*                                                                      *
692
             exprIsDupable
Austin Seipp's avatar
Austin Seipp committed
693
694
*                                                                      *
************************************************************************
695
696
697

Note [exprIsDupable]
~~~~~~~~~~~~~~~~~~~~
698
699
700
@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.
701

702
703
                That is, exprIsDupable returns True of (f x) even if
                f is very very expensive to call.
704

705
706
                Its only purpose is to avoid fruitless let-binding
                and then inlining of case join points
Austin Seipp's avatar
Austin Seipp committed
707
-}
708

709
710
exprIsDupable :: DynFlags -> CoreExpr -> Bool
exprIsDupable dflags e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
711
  = isJust (go dupAppSize e)
712
  where
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
713
    go :: Int -> CoreExpr -> Maybe Int
714
715
716
    go n (Type {})     = Just n
    go n (Coercion {}) = Just n
    go n (Var {})      = decrement n
717
    go n (Tick _ e)    = go n e
718
    go n (Cast e _)    = go n e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
719
    go n (App f a) | Just n' <- go n a = go n' f
720
    go n (Lit lit) | litIsDupable dflags lit = decrement n
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
721
722
723
724
725
    go _ _ = Nothing

    decrement :: Int -> Maybe Int
    decrement 0 = Nothing
    decrement n = Just (n-1)
726
727

dupAppSize :: Int
728
729
730
731
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.
732

Austin Seipp's avatar
Austin Seipp committed
733
734
735
{-
************************************************************************
*                                                                      *
736
             exprIsCheap, exprIsExpandable
Austin Seipp's avatar
Austin Seipp committed
737
738
*                                                                      *
************************************************************************
739

740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
Note [exprIsWorkFree]
~~~~~~~~~~~~~~~~~~~~~
exprIsWorkFree is used when deciding whether to inline something; we
don't inline it if doing so might duplicate work, by peeling off a
complete copy of the expression.  Here we do not want even to
duplicate a primop (Trac #5623):
   eg   let x = a #+ b in x +# x
   we do not want to inline/duplicate x

Previously we were a bit more liberal, which led to the primop-duplicating
problem.  However, being more conservative did lead to a big regression in
one nofib benchmark, wheel-sieve1.  The situation looks like this:

   let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool
       noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs ->
         case GHC.Prim.<=# x_aRs 2 of _ {
           GHC.Types.False -> notDivBy ps_adM qs_adN;
           GHC.Types.True -> lvl_r2Eb }}
       go = \x. ...(noFactor (I# y))....(go x')...

The function 'noFactor' is heap-allocated and then called.  Turns out
that 'notDivBy' is strict in its THIRD arg, but that is invisible to
the caller of noFactor, which therefore cannot do w/w and
heap-allocates noFactor's argument.  At the moment (May 12) we are just
Austin Seipp's avatar
Austin Seipp committed
764
765
going to put up with this, because the previous more aggressive inlining
(which treated 'noFactor' as work-free) was duplicating primops, which
766
in turn was making inner loops of array calculations runs slow (#5623)
Austin Seipp's avatar
Austin Seipp committed
767
-}
768
769
770
771
772
773
774
775
776

exprIsWorkFree :: CoreExpr -> Bool
-- See Note [exprIsWorkFree]
exprIsWorkFree e = go 0 e
  where    -- n is the number of value arguments
    go _ (Lit {})                     = True
    go _ (Type {})                    = True
    go _ (Coercion {})                = True
    go n (Cast e _)                   = go n e
Austin Seipp's avatar
Austin Seipp committed
777
    go n (Case scrut _ _ alts)        = foldl (&&) (exprIsWorkFree scrut)
778
779
780
                                              [ go n rhs | (_,_,rhs) <- alts ]
         -- See Note [Case expressions are work-free]
    go _ (Let {})                     = False
781
    go n (Var v)                      = isCheapApp v n
782
783
784
785
786
787
788
    go n (Tick t e) | tickishCounts t = False
                    | otherwise       = go n e
    go n (Lam x e)  | isRuntimeVar x = n==0 || go (n-1) e
                    | otherwise      = go n e
    go n (App f e)  | isRuntimeArg e = exprIsWorkFree e && go (n+1) f
                    | otherwise      = go n f

Austin Seipp's avatar
Austin Seipp committed
789
{-
790
791
792
793
794
795
796
797
798
Note [Case expressions are work-free]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Are case-expressions work-free?  Consider
    let v = case x of (p,q) -> p
        go = \y -> ...case v of ...
Should we inline 'v' at its use site inside the loop?  At the moment
we do.  I experimented with saying that case are *not* work-free, but
that increased allocation slightly.  It's a fairly small effect, and at
the moment we go for the slightly more aggressive version which treats
Krzysztof Gogolewski's avatar
Typos    
Krzysztof Gogolewski committed
799
(case x of ....) as work-free if the alternatives are.
800
801


802
803
Note [exprIsCheap]   See also Note [Interaction of exprIsCheap and lone variables]
~~~~~~~~~~~~~~~~~~   in CoreUnfold.lhs
804
805
806
807
@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.]
808
809

By ``cheap'' we mean a computation we're willing to:
810
811
        push inside a lambda, or
        inline at more than one place
812
813
814
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:
815

816
817
818
  *     case e of
          pi -> ei
        (where e, and all the ei are cheap)
819

820
821
  *     let x = e in b
        (where e and b are cheap)
822

823
824
  *     op x1 ... xn
        (where op is a cheap primitive operator)
825

826
827
  *     error "foo"
        (because we are happy to substitute it inside a lambda)
828

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

832
833
834
Note [exprIsCheap and exprIsHNF]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note that exprIsHNF does not imply exprIsCheap.  Eg
835
        let x = fac 20 in Just x
836
837
This responds True to exprIsHNF (you can discard a seq), but
False to exprIsCheap.
Austin Seipp's avatar
Austin Seipp committed
838
-}
839

840
exprIsCheap :: CoreExpr -> Bool
841
exprIsCheap = exprIsCheap' isCheapApp
842
843

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

846
exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
847
exprIsCheap' _        (Lit _)      = True
848
exprIsCheap' _        (Type _)    = True
849
850
851
852
853
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
854

855
856
857
858
859
860
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
861

862
863
864
exprIsCheap' good_app (Tick t e)
  | tickishCounts t = False
  | otherwise       = exprIsCheap' good_app e
Peter Wortmann's avatar
Peter Wortmann committed
865
866
867
     -- never duplicate counting ticks.  If we get this wrong, then
     -- HPC's entry counts will be off (check test in
     -- libraries/hpc/tests/raytrace)
868

869
870
871
872
exprIsCheap' good_app (Let (NonRec _ b) e)
  = exprIsCheap' good_app b && exprIsCheap' good_app e
exprIsCheap' good_app (Let (Rec prs) e)
  = all (exprIsCheap' good_app . snd) prs && exprIsCheap' good_app e
873

874
exprIsCheap' good_app other_expr        -- Applications and variables
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
875
  = go other_expr []
876
  where
877
        -- Accumulate value arguments, then decide
878
    go (Cast e _) val_args                 = go e val_args
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
879
    go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
880
                          | otherwise      = go f val_args
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
881

Austin Seipp's avatar
Austin Seipp committed
882
    go (Var _) [] = True
883
884
885
886
887
         -- Just a type application of a variable
         -- (f t1 t2 t3) counts as WHNF
         -- This case is probably handeld by the good_app case
         -- below, which should have a case for n=0, but putting
         -- it here too is belt and braces; and it's such a common
Austin Seipp's avatar
Austin Seipp committed
888
         -- case that checking for null directly seems like a
889
890
         -- good plan

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
891
    go (Var f) args
Austin Seipp's avatar
Austin Seipp committed
892
       | good_app f (length args)
893
894
895
       = go_pap args

       | otherwise
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
896
        = case idDetails f of
897
898
899
900
901
                RecSelId {}         -> go_sel args
                ClassOpId {}        -> go_sel args
                PrimOpId op         -> go_primop op args
                _ | isBottomingId f -> True
                  | otherwise       -> False
902
903
904
905
                        -- Application of a function which
                        -- always gives bottom; we treat this as cheap
                        -- because it certainly doesn't need to be shared!

Peter Wortmann's avatar
Peter Wortmann committed
906
907
908
909
    go (Tick t e) args
      | not (tickishCounts t) -- don't duplicate counting ticks, see above
      = go e args

910
    go _ _ = False
911

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
912
    --------------
913
914
915
    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.
916
917
        -- The principle here is that
        --    let x = a +# b in c *# x
Simon Peyton Jones's avatar
Simon Peyton Jones committed
918
919
        -- should behave equivalently to
        --    c *# (a +# b)
920
        -- Since lets with cheap RHSs are accepted,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
921
        -- so should paps with cheap arguments
922

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
923
    --------------
924
    go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args
925
926
927
928
929
        -- 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
930
    --------------
931
932
933
934
935
    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)
936

937
-------------------------------------
Austin Seipp's avatar
Austin Seipp committed
938
939
940
type CheapAppFun = Id -> Int -> Bool
  -- Is an application of this function to n *value* args
  -- always cheap, assuming the arguments are cheap?
941
942
943
  -- Mainly true of partial applications, data constructors,
  -- and of course true if the number of args is zero

944
945
isCheapApp :: CheapAppFun
isCheapApp fn n_val_args
Austin Seipp's avatar
Austin Seipp committed
946
947
  =  isDataConWorkId fn
  || n_val_args == 0
948
949
950
951
952
953
954
955
956
957
  || n_val_args < idArity fn

isExpandableApp :: CheapAppFun
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]
958
  -- This incidentally picks up the (n_val_args = 0) case
959
960
961
962
963
964
     go 0 _ = True
     go n_val_args ty
       | Just (_, ty) <- splitForAllTy_maybe ty   = go n_val_args ty
       | Just (arg, ty) <- splitFunTy_maybe ty
       , isPredTy arg                             = go (n_val_args-1) ty
       | otherwise                                = False
965

Austin Seipp's avatar
Austin Seipp committed
966
{-
967
968
969
970
971
972
973
974
975
976
977
978
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.

979

Austin Seipp's avatar
Austin Seipp committed
980
981
************************************************************************
*                                                                      *
982
             exprOkForSpeculation
Austin Seipp's avatar
Austin Seipp committed
983
984
985
*                                                                      *
************************************************************************
-}
986

987
-----------------------------
batterseapower's avatar
batterseapower committed
988
989
-- | 'exprOkForSpeculation' returns True of an expression that is:
--
990
--  * Safe to evaluate even if normal order eval might not
batterseapower's avatar
batterseapower committed
991
992
993
994
--    evaluate the expression at all, or
--
--  * Safe /not/ to evaluate even if normal order would do so
--
995
996
-- It is usually called on arguments of unlifted type, but not always
-- In particular, Simplify.rebuildCase calls it on lifted types
997
-- when a 'case' is a plain 'seq'. See the example in
998
999
-- Note [exprOkForSpeculation: case expressions] below
--
batterseapower's avatar
batterseapower committed
1000
-- Precisely, it returns @True@ iff:
1001
1002
1003
1004
1005
--  a) The expression guarantees to terminate,
--  b) soon,
--  c) without causing a write side effect (e.g. writing a mutable variable)
--  d) without throwing a Haskell exception
--  e) without risking an unchecked runtime exception (array out of bounds,
1006
--     divide by zero)
batterseapower's avatar
batterseapower committed
1007
--
1008
1009
1010
1011
1012
1013
1014
-- For @exprOkForSideEffects@ the list is the same, but omitting (e).
--
-- Note that
--    exprIsHNF            implies exprOkForSpeculation
--    exprOkForSpeculation implies exprOkForSideEffects
--
-- See Note [PrimOp can_fail and has_side_effects] in PrimOp
1015
-- and Note [Implementation: how can_fail/has_side_effects affect transformations]
batterseapower's avatar
batterseapower committed
1016
1017
1018
1019
1020
1021
1022
1023
--
-- As an example of the considerations in this test, consider:
--
-- > let x = case y# +# 1# of { r# -> I# r# }
-- > in E
--
-- being translated to:
--
1024
-- > case y# +# 1# of { r# ->
batterseapower's avatar
batterseapower committed
1025
-- >    let x = I# r#
1026
-- >    in E</