{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


Utility functions on @Core@ syntax
-}

{-# LANGUAGE CPP #-}

-- | Commonly useful utilites for manipulating the Core language
module CoreUtils (
        -- * Constructing expressions
        mkCast,
        mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,
        bindNonRec, needsCaseBinding,
        mkAltExpr,

        -- * Taking expressions apart
        findDefault, addDefault, findAlt, isDefaultAlt,
        mergeAlts, trimConArgs,
        filterAlts, combineIdenticalAlts, refineDefaultAlt,

        -- * Properties of expressions
        exprType, coreAltType, coreAltsType, isExprLevPoly,
        exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
        getIdFromTrivialExpr_maybe,
        exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,
        exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
        exprIsBig, exprIsConLike,
        rhsIsStatic, isCheapApp, isExpandableApp,
        exprIsTickedString, exprIsTickedString_maybe,
        exprIsTopLevelBindable,
        altsAreExhaustive,

        -- * Equality
        cheapEqExpr, cheapEqExpr', eqExpr,
        diffExpr, diffBinds,

        -- * Eta reduction
        tryEtaReduce,

        -- * Manipulating data constructors and types
        exprToType, exprToCoercion_maybe,
        applyTypeToArgs, applyTypeToArg,
        dataConRepInstPat, dataConRepFSInstPat,
        isEmptyTy,

        -- * Working with ticks
        stripTicksTop, stripTicksTopE, stripTicksTopT,
        stripTicksE, stripTicksT,

        -- * StaticPtr
        collectMakeStaticArgs,

        -- * Join points
        isJoinBind
    ) where

#include "HsVersions.h"

import GhcPrelude

import CoreSyn
import PrelNames ( makeStaticName )
import PprCore
import CoreFVs( exprFreeVars )
import Var
import SrcLoc
import VarEnv
import VarSet
import Name
import Literal
import DataCon
import PrimOp
import Id
import IdInfo
import PrelNames( absentErrorIdKey )
import Type
import TyCoRep( TyCoBinder(..), TyBinder )
import Coercion
import TyCon
import Unique
import Outputable
import TysPrim
import DynFlags
import FastString
import Maybes
import ListSetOps       ( minusList )
import BasicTypes       ( Arity, isConLike )
import Platform
import Util
import Pair
import Data.ByteString     ( ByteString )
import Data.Function       ( on )
import Data.List
import Data.Ord            ( comparing )
import OrdList
import qualified Data.Set as Set
import UniqSet

{-
************************************************************************
*                                                                      *
\subsection{Find the type of a Core atom/expression}
*                                                                      *
************************************************************************
-}

exprType :: CoreExpr -> Type
-- ^ 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
exprType :: CoreExpr -> Type
exprType (Var var :: Id
var)           = Id -> Type
idType Id
var
exprType (Lit lit :: Literal
lit)           = Literal -> Type
literalType Literal
lit
exprType (Coercion co :: Coercion
co)       = Coercion -> Type
coercionType Coercion
co
exprType (Let bind :: Bind Id
bind body :: CoreExpr
body)
  | NonRec tv :: Id
tv rhs :: CoreExpr
rhs <- Bind Id
bind    -- See Note [Type bindings]
  , Type ty :: Type
ty <- CoreExpr
rhs           = [Id] -> [Type] -> Type -> Type
substTyWithUnchecked [Id
tv] [Type
ty] (CoreExpr -> Type
exprType CoreExpr
body)
  | Bool
otherwise                = CoreExpr -> Type
exprType CoreExpr
body
exprType (Case _ _ ty :: Type
ty _)     = Type
ty
exprType (Cast _ co :: Coercion
co)         = Pair Type -> Type
forall a. Pair a -> a
pSnd (Coercion -> Pair Type
coercionKind Coercion
co)
exprType (Tick _ e :: CoreExpr
e)          = CoreExpr -> Type
exprType CoreExpr
e
exprType (Lam binder :: Id
binder expr :: CoreExpr
expr)   = Id -> Type -> Type
mkLamType Id
binder (CoreExpr -> Type
exprType CoreExpr
expr)
exprType e :: CoreExpr
e@(App _ _)
  = case CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e of
        (fun :: CoreExpr
fun, args :: [CoreExpr]
args) -> CoreExpr -> Type -> [CoreExpr] -> Type
applyTypeToArgs CoreExpr
e (CoreExpr -> Type
exprType CoreExpr
fun) [CoreExpr]
args

exprType other :: CoreExpr
other = String -> SDoc -> Type -> Type
forall a. String -> SDoc -> a -> a
pprTrace "exprType" (CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
other) Type
alphaTy

coreAltType :: CoreAlt -> Type
-- ^ Returns the type of the alternatives right hand side
coreAltType :: CoreAlt -> Type
coreAltType alt :: CoreAlt
alt@(_,bs :: [Id]
bs,rhs :: CoreExpr
rhs)
  = case [Id] -> Type -> Maybe Type
occCheckExpand [Id]
bs Type
rhs_ty of
      -- Note [Existential variables and silly type synonyms]
      Just ty :: Type
ty -> Type
ty
      Nothing -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic "coreAltType" (CoreAlt -> SDoc
forall a. OutputableBndr a => (AltCon, [a], Expr a) -> SDoc
pprCoreAlt CoreAlt
alt SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty)
  where
    rhs_ty :: Type
rhs_ty = CoreExpr -> Type
exprType CoreExpr
rhs

coreAltsType :: [CoreAlt] -> Type
-- ^ Returns the type of the first alternative, which should be the same as for all alternatives
coreAltsType :: [CoreAlt] -> Type
coreAltsType (alt :: CoreAlt
alt:_) = CoreAlt -> Type
coreAltType CoreAlt
alt
coreAltsType []      = String -> Type
forall a. String -> a
panic "corAltsType"

-- | Is this expression levity polymorphic? This should be the
-- same as saying (isKindLevPoly . typeKind . exprType) but
-- much faster.
isExprLevPoly :: CoreExpr -> Bool
isExprLevPoly :: CoreExpr -> Bool
isExprLevPoly = CoreExpr -> Bool
go
  where
   go :: CoreExpr -> Bool
go (Var _)                      = Bool
False  -- no levity-polymorphic binders
   go (Lit _)                      = Bool
False  -- no levity-polymorphic literals
   go e :: CoreExpr
e@(App f :: CoreExpr
f _) | Bool -> Bool
not (CoreExpr -> Bool
forall b. OutputableBndr b => Expr b -> Bool
go_app CoreExpr
f) = Bool
False
                  | Bool
otherwise      = CoreExpr -> Bool
check_type CoreExpr
e
   go (Lam _ _)                    = Bool
False
   go (Let _ e :: CoreExpr
e)                    = CoreExpr -> Bool
go CoreExpr
e
   go e :: CoreExpr
e@(Case {})                  = CoreExpr -> Bool
check_type CoreExpr
e -- checking type is fast
   go e :: CoreExpr
e@(Cast {})                  = CoreExpr -> Bool
check_type CoreExpr
e
   go (Tick _ e :: CoreExpr
e)                   = CoreExpr -> Bool
go CoreExpr
e
   go e :: CoreExpr
e@(Type {})                  = String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic "isExprLevPoly ty" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)
   go (Coercion {})                = Bool
False  -- this case can happen in SetLevels

   check_type :: CoreExpr -> Bool
check_type = Type -> Bool
isTypeLevPoly (Type -> Bool) -> (CoreExpr -> Type) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Type
exprType  -- slow approach

      -- if the function is a variable (common case), check its
      -- levityInfo. This might mean we don't need to look up and compute
      -- on the type. Spec of these functions: return False if there is
      -- no possibility, ever, of this expression becoming levity polymorphic,
      -- no matter what it's applied to; return True otherwise.
      -- returning True is always safe. See also Note [Levity info] in
      -- IdInfo
   go_app :: Expr b -> Bool
go_app (Var id :: Id
id)        = Bool -> Bool
not (Id -> Bool
isNeverLevPolyId Id
id)
   go_app (Lit _)         = Bool
False
   go_app (App f :: Expr b
f _)       = Expr b -> Bool
go_app Expr b
f
   go_app (Lam _ e :: Expr b
e)       = Expr b -> Bool
go_app Expr b
e
   go_app (Let _ e :: Expr b
e)       = Expr b -> Bool
go_app Expr b
e
   go_app (Case _ _ ty :: Type
ty _) = Type -> Bool
resultIsLevPoly Type
ty
   go_app (Cast _ co :: Coercion
co)     = Type -> Bool
resultIsLevPoly (Pair Type -> Type
forall a. Pair a -> a
pSnd (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co)
   go_app (Tick _ e :: Expr b
e)      = Expr b -> Bool
go_app Expr b
e
   go_app e :: Expr b
e@(Type {})     = String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic "isExprLevPoly app ty" (Expr b -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr b
e)
   go_app e :: Expr b
e@(Coercion {}) = String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic "isExprLevPoly app co" (Expr b -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr b
e)


{-
Note [Type bindings]
~~~~~~~~~~~~~~~~~~~~
Core does allow type bindings, although such bindings are
not much used, except in the output of the desugarer.
Example:
     let a = Int in (\x:a. x)
Given this, exprType must be careful to substitute 'a' in the
result type (Trac #8522).

Note [Existential variables and silly type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
        data T = forall a. T (Funny a)
        type Funny a = Bool
        f :: T -> Bool
        f (T x) = x

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.

Note that there might be existentially quantified coercion variables, too.
-}

-- Not defined with applyTypeToArg because you can't print from CoreSyn.
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
-- The first argument is just for debugging, and gives some context
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
applyTypeToArgs e :: CoreExpr
e op_ty :: Type
op_ty args :: [CoreExpr]
args
  = Type -> [CoreExpr] -> Type
forall b. Type -> [Expr b] -> Type
go Type
op_ty [CoreExpr]
args
  where
    go :: Type -> [Expr b] -> Type
go op_ty :: Type
op_ty []                   = Type
op_ty
    go op_ty :: Type
op_ty (Type ty :: Type
ty : args :: [Expr b]
args)     = Type -> [Type] -> [Expr b] -> Type
go_ty_args Type
op_ty [Type
ty] [Expr b]
args
    go op_ty :: Type
op_ty (Coercion co :: Coercion
co : args :: [Expr b]
args) = Type -> [Type] -> [Expr b] -> Type
go_ty_args Type
op_ty [Coercion -> Type
mkCoercionTy Coercion
co] [Expr b]
args
    go op_ty :: Type
op_ty (_ : args :: [Expr b]
args)           | Just (_, res_ty :: Type
res_ty) <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
op_ty
                                  = Type -> [Expr b] -> Type
go Type
res_ty [Expr b]
args
    go _ _ = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic "applyTypeToArgs" SDoc
panic_msg

    -- go_ty_args: accumulate type arguments so we can
    -- instantiate all at once with piResultTys
    go_ty_args :: Type -> [Type] -> [Expr b] -> Type
go_ty_args op_ty :: Type
op_ty rev_tys :: [Type]
rev_tys (Type ty :: Type
ty : args :: [Expr b]
args)
       = Type -> [Type] -> [Expr b] -> Type
go_ty_args Type
op_ty (Type
tyType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
rev_tys) [Expr b]
args
    go_ty_args op_ty :: Type
op_ty rev_tys :: [Type]
rev_tys (Coercion co :: Coercion
co : args :: [Expr b]
args)
       = Type -> [Type] -> [Expr b] -> Type
go_ty_args Type
op_ty (Coercion -> Type
mkCoercionTy Coercion
co Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
rev_tys) [Expr b]
args
    go_ty_args op_ty :: Type
op_ty rev_tys :: [Type]
rev_tys args :: [Expr b]
args
       = Type -> [Expr b] -> Type
go (HasDebugCallStack => Type -> [Type] -> Type
Type -> [Type] -> Type
piResultTys Type
op_ty ([Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
rev_tys)) [Expr b]
args

    panic_msg :: SDoc
panic_msg = [SDoc] -> SDoc
vcat [ String -> SDoc
text "Expression:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
e
                     , String -> SDoc
text "Type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
op_ty
                     , String -> SDoc
text "Args:" SDoc -> SDoc -> SDoc
<+> [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args ]


{-
************************************************************************
*                                                                      *
\subsection{Attaching notes}
*                                                                      *
************************************************************************
-}

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

mkCast (Coercion e_co :: Coercion
e_co) co :: Coercion
co
  | Type -> Bool
isCoVarType (Pair Type -> Type
forall a. Pair a -> a
pSnd (Coercion -> Pair Type
coercionKind Coercion
co))
       -- The guard here checks that g has a (~#) on both sides,
       -- otherwise decomposeCo fails.  Can in principle happen
       -- with unsafeCoerce
  = Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion (Coercion -> Coercion -> Coercion
mkCoCast Coercion
e_co Coercion
co)

mkCast (Cast expr :: CoreExpr
expr co2 :: Coercion
co2) co :: Coercion
co
  = WARN(let { Pair  from_ty  _to_ty  = coercionKind co;
               Pair _from_ty2  to_ty2 = coercionKind co2} in
            not (from_ty `eqType` to_ty2),
             vcat ([ text "expr:" <+> ppr expr
                   , text "co2:" <+> ppr co2
                   , text "co:" <+> ppr co ]) )
    CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
expr (Coercion -> Coercion -> Coercion
mkTransCo Coercion
co2 Coercion
co)

mkCast (Tick t :: Tickish Id
t expr :: CoreExpr
expr) co :: Coercion
co
   = Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t (CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
expr Coercion
co)

mkCast expr :: CoreExpr
expr co :: Coercion
co
  = let Pair from_ty :: Type
from_ty _to_ty :: Type
_to_ty = Coercion -> Pair Type
coercionKind Coercion
co in
    WARN( not (from_ty `eqType` exprType expr),
          text "Trying to coerce" <+> text "(" <> ppr expr
          $$ text "::" <+> ppr (exprType expr) <> text ")"
          $$ ppr co $$ ppr (coercionType co) )
    (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
expr Coercion
co)

-- | Wraps the given expression in the source annotation, dropping the
-- annotation if possible.
mkTick :: Tickish Id -> CoreExpr -> CoreExpr
mkTick :: Tickish Id -> CoreExpr -> CoreExpr
mkTick t :: Tickish Id
t orig_expr :: CoreExpr
orig_expr = (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' CoreExpr -> CoreExpr
forall a. a -> a
id CoreExpr -> CoreExpr
forall a. a -> a
id CoreExpr
orig_expr
 where
  -- Some ticks (cost-centres) can be split in two, with the
  -- non-counting part having laxer placement properties.
  canSplit :: Bool
canSplit = Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishCanSplit Tickish Id
t Bool -> Bool -> Bool
&& Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace (Tickish Id -> Tickish Id
forall id. Tickish id -> Tickish id
mkNoCount Tickish Id
t) TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
/= Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
t

  mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through)
          -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with)
          -> CoreExpr               -- ^ current expression
          -> CoreExpr
  mkTick' :: (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' top :: CoreExpr -> CoreExpr
top rest :: CoreExpr -> CoreExpr
rest expr :: CoreExpr
expr = case CoreExpr
expr of

    -- Cost centre ticks should never be reordered relative to each
    -- other. Therefore we can stop whenever two collide.
    Tick t2 :: Tickish Id
t2 e :: CoreExpr
e
      | ProfNote{} <- Tickish Id
t2, ProfNote{} <- Tickish Id
t -> CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest CoreExpr
expr

    -- Otherwise we assume that ticks of different placements float
    -- through each other.
      | Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
t2 TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
/= Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
t -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' (CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t2) CoreExpr -> CoreExpr
rest CoreExpr
e

    -- For annotations this is where we make sure to not introduce
    -- redundant ticks.
      | Tickish Id -> Tickish Id -> Bool
forall b. Eq b => Tickish b -> Tickish b -> Bool
tickishContains Tickish Id
t Tickish Id
t2              -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' CoreExpr -> CoreExpr
top CoreExpr -> CoreExpr
rest CoreExpr
e
      | Tickish Id -> Tickish Id -> Bool
forall b. Eq b => Tickish b -> Tickish b -> Bool
tickishContains Tickish Id
t2 Tickish Id
t              -> CoreExpr
orig_expr
      | Bool
otherwise                         -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr
rest (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t2) CoreExpr
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 :: CoreExpr
e co :: Coercion
co   -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' (CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreExpr -> Coercion -> CoreExpr)
-> Coercion -> CoreExpr -> CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast Coercion
co) CoreExpr -> CoreExpr
rest CoreExpr
e
    Coercion co :: Coercion
co -> Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
co

    Lam x :: Id
x e :: CoreExpr
e
      -- Always float through type lambdas. Even for non-type lambdas,
      -- floating is allowed for all but the most strict placement rule.
      | Bool -> Bool
not (Id -> Bool
isRuntimeVar Id
x) Bool -> Bool -> Bool
|| Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
t TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
/= TickishPlacement
PlaceRuntime
      -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' (CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
x) CoreExpr -> CoreExpr
rest CoreExpr
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.
      | Bool
canSplit
      -> CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick (Tickish Id -> Tickish Id
forall id. Tickish id -> Tickish id
mkNoScope Tickish Id
t) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
x (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Tickish Id -> CoreExpr -> CoreExpr
mkTick (Tickish Id -> Tickish Id
forall id. Tickish id -> Tickish id
mkNoCount Tickish Id
t) CoreExpr
e

    App f :: CoreExpr
f arg :: CoreExpr
arg
      -- Always float through type applications.
      | Bool -> Bool
not (CoreExpr -> Bool
isRuntimeArg CoreExpr
arg)
      -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' (CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> CoreExpr -> CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
arg) CoreExpr -> CoreExpr
rest CoreExpr
f

      -- We can also float through constructor applications, placement
      -- permitting. Again we can split.
      | CoreExpr -> Bool
isSaturatedConApp CoreExpr
expr Bool -> Bool -> Bool
&& (Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
tTickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
==TickishPlacement
PlaceCostCentre Bool -> Bool -> Bool
|| Bool
canSplit)
      -> if Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
t TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceCostCentre
         then CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Tickish Id -> CoreExpr -> CoreExpr
tickHNFArgs Tickish Id
t CoreExpr
expr
         else CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick (Tickish Id -> Tickish Id
forall id. Tickish id -> Tickish id
mkNoScope Tickish Id
t) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Tickish Id -> CoreExpr -> CoreExpr
tickHNFArgs (Tickish Id -> Tickish Id
forall id. Tickish id -> Tickish id
mkNoCount Tickish Id
t) CoreExpr
expr

    Var x :: Id
x
      | Bool
notFunction Bool -> Bool -> Bool
&& Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
t TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceCostCentre
      -> CoreExpr
orig_expr
      | Bool
notFunction Bool -> Bool -> Bool
&& Bool
canSplit
      -> CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick (Tickish Id -> Tickish Id
forall id. Tickish id -> Tickish id
mkNoScope Tickish Id
t) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest CoreExpr
expr
      where
        -- SCCs can be eliminated on variables provided the variable
        -- is not a function.  In these cases the SCC makes no difference:
        -- the cost of evaluating the variable will be attributed to its
        -- definition site.  When the variable refers to a function, however,
        -- an SCC annotation on the variable affects the cost-centre stack
        -- when the function is called, so we must retain those.
        notFunction :: Bool
notFunction = Bool -> Bool
not (Type -> Bool
isFunTy (Id -> Type
idType Id
x))

    Lit{}
      | Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
t TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceCostCentre
      -> CoreExpr
orig_expr

    -- Catch-all: Annotate where we stand
    _any :: CoreExpr
_any -> CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
rest CoreExpr
expr

mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr
mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr
mkTicks ticks :: [Tickish Id]
ticks expr :: CoreExpr
expr = (Tickish Id -> CoreExpr -> CoreExpr)
-> CoreExpr -> [Tickish Id] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tickish Id -> CoreExpr -> CoreExpr
mkTick CoreExpr
expr [Tickish Id]
ticks

isSaturatedConApp :: CoreExpr -> Bool
isSaturatedConApp :: CoreExpr -> Bool
isSaturatedConApp e :: CoreExpr
e = CoreExpr -> [CoreExpr] -> Bool
forall b. Expr b -> [Expr b] -> Bool
go CoreExpr
e []
  where go :: Expr b -> [Expr b] -> Bool
go (App f :: Expr b
f a :: Expr b
a) as :: [Expr b]
as = Expr b -> [Expr b] -> Bool
go Expr b
f (Expr b
aExpr b -> [Expr b] -> [Expr b]
forall a. a -> [a] -> [a]
:[Expr b]
as)
        go (Var fun :: Id
fun) args :: [Expr b]
args
           = Id -> Bool
isConLikeId Id
fun Bool -> Bool -> Bool
&& Id -> Int
idArity Id
fun Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Expr b] -> Int
forall b. [Arg b] -> Int
valArgCount [Expr b]
args
        go (Cast f :: Expr b
f _) as :: [Expr b]
as = Expr b -> [Expr b] -> Bool
go Expr b
f [Expr b]
as
        go _ _ = Bool
False

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

-- push a tick into the arguments of a HNF (call or constructor app)
tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr
tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr
tickHNFArgs t :: Tickish Id
t e :: CoreExpr
e = Tickish Id -> CoreExpr -> CoreExpr
push Tickish Id
t CoreExpr
e
 where
  push :: Tickish Id -> CoreExpr -> CoreExpr
push t :: Tickish Id
t (App f :: CoreExpr
f (Type u :: Type
u)) = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Tickish Id -> CoreExpr -> CoreExpr
push Tickish Id
t CoreExpr
f) (Type -> CoreExpr
forall b. Type -> Expr b
Type Type
u)
  push t :: Tickish Id
t (App f :: CoreExpr
f arg :: CoreExpr
arg) = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Tickish Id -> CoreExpr -> CoreExpr
push Tickish Id
t CoreExpr
f) (Tickish Id -> CoreExpr -> CoreExpr
mkTick Tickish Id
t CoreExpr
arg)
  push _t :: Tickish Id
_t e :: CoreExpr
e = CoreExpr
e

-- | Strip ticks satisfying a predicate from top of an expression
stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
stripTicksTop p :: Tickish Id -> Bool
p = [Tickish Id] -> Expr b -> ([Tickish Id], Expr b)
forall b. [Tickish Id] -> Expr b -> ([Tickish Id], Expr b)
go []
  where go :: [Tickish Id] -> Expr b -> ([Tickish Id], Expr b)
go ts :: [Tickish Id]
ts (Tick t :: Tickish Id
t e :: Expr b
e) | Tickish Id -> Bool
p Tickish Id
t = [Tickish Id] -> Expr b -> ([Tickish Id], Expr b)
go (Tickish Id
tTickish Id -> [Tickish Id] -> [Tickish Id]
forall a. a -> [a] -> [a]
:[Tickish Id]
ts) Expr b
e
        go ts :: [Tickish Id]
ts other :: Expr b
other            = ([Tickish Id] -> [Tickish Id]
forall a. [a] -> [a]
reverse [Tickish Id]
ts, Expr b
other)

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

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

-- | Completely strip ticks satisfying a predicate from an
-- expression. Note this is O(n) in the size of the expression!
stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksE p :: Tickish Id -> Bool
p expr :: Expr b
expr = Expr b -> Expr b
forall b. Expr b -> Expr b
go Expr b
expr
  where go :: Expr b -> Expr b
go (App e :: Expr b
e a :: Expr b
a)        = Expr b -> Expr b -> Expr b
forall b. Expr b -> Expr b -> Expr b
App (Expr b -> Expr b
go Expr b
e) (Expr b -> Expr b
go Expr b
a)
        go (Lam b :: b
b e :: Expr b
e)        = b -> Expr b -> Expr b
forall b. b -> Expr b -> Expr b
Lam b
b (Expr b -> Expr b
go Expr b
e)
        go (Let b :: Bind b
b e :: Expr b
e)        = Bind b -> Expr b -> Expr b
forall b. Bind b -> Expr b -> Expr b
Let (Bind b -> Bind b
go_bs Bind b
b) (Expr b -> Expr b
go Expr b
e)
        go (Case e :: Expr b
e b :: b
b t :: Type
t as :: [Alt b]
as)  = Expr b -> b -> Type -> [Alt b] -> Expr b
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Expr b -> Expr b
go Expr b
e) b
b Type
t ((Alt b -> Alt b) -> [Alt b] -> [Alt b]
forall a b. (a -> b) -> [a] -> [b]
map Alt b -> Alt b
go_a [Alt b]
as)
        go (Cast e :: Expr b
e c :: Coercion
c)       = Expr b -> Coercion -> Expr b
forall b. Expr b -> Coercion -> Expr b
Cast (Expr b -> Expr b
go Expr b
e) Coercion
c
        go (Tick t :: Tickish Id
t e :: Expr b
e)
          | Tickish Id -> Bool
p Tickish Id
t             = Expr b -> Expr b
go Expr b
e
          | Bool
otherwise       = Tickish Id -> Expr b -> Expr b
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t (Expr b -> Expr b
go Expr b
e)
        go other :: Expr b
other            = Expr b
other
        go_bs :: Bind b -> Bind b
go_bs (NonRec b :: b
b e :: Expr b
e)  = b -> Expr b -> Bind b
forall b. b -> Expr b -> Bind b
NonRec b
b (Expr b -> Expr b
go Expr b
e)
        go_bs (Rec bs :: [(b, Expr b)]
bs)      = [(b, Expr b)] -> Bind b
forall b. [(b, Expr b)] -> Bind b
Rec (((b, Expr b) -> (b, Expr b)) -> [(b, Expr b)] -> [(b, Expr b)]
forall a b. (a -> b) -> [a] -> [b]
map (b, Expr b) -> (b, Expr b)
go_b [(b, Expr b)]
bs)
        go_b :: (b, Expr b) -> (b, Expr b)
go_b (b :: b
b, e :: Expr b
e)         = (b
b, Expr b -> Expr b
go Expr b
e)
        go_a :: Alt b -> Alt b
go_a (c :: AltCon
c,bs :: [b]
bs,e :: Expr b
e)       = (AltCon
c,[b]
bs, Expr b -> Expr b
go Expr b
e)

stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
stripTicksT p :: Tickish Id -> Bool
p expr :: Expr b
expr = OrdList (Tickish Id) -> [Tickish Id]
forall a. OrdList a -> [a]
fromOL (OrdList (Tickish Id) -> [Tickish Id])
-> OrdList (Tickish Id) -> [Tickish Id]
forall a b. (a -> b) -> a -> b
$ Expr b -> OrdList (Tickish Id)
forall b. Expr b -> OrdList (Tickish Id)
go Expr b
expr
  where go :: Expr b -> OrdList (Tickish Id)
go (App e :: Expr b
e a :: Expr b
a)        = Expr b -> OrdList (Tickish Id)
go Expr b
e OrdList (Tickish Id)
-> OrdList (Tickish Id) -> OrdList (Tickish Id)
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Expr b -> OrdList (Tickish Id)
go Expr b
a
        go (Lam _ e :: Expr b
e)        = Expr b -> OrdList (Tickish Id)
go Expr b
e
        go (Let b :: Bind b
b e :: Expr b
e)        = Bind b -> OrdList (Tickish Id)
go_bs Bind b
b OrdList (Tickish Id)
-> OrdList (Tickish Id) -> OrdList (Tickish Id)
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Expr b -> OrdList (Tickish Id)
go Expr b
e
        go (Case e :: Expr b
e _ _ as :: [Alt b]
as)  = Expr b -> OrdList (Tickish Id)
go Expr b
e OrdList (Tickish Id)
-> OrdList (Tickish Id) -> OrdList (Tickish Id)
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [OrdList (Tickish Id)] -> OrdList (Tickish Id)
forall a. [OrdList a] -> OrdList a
concatOL ((Alt b -> OrdList (Tickish Id))
-> [Alt b] -> [OrdList (Tickish Id)]
forall a b. (a -> b) -> [a] -> [b]
map Alt b -> OrdList (Tickish Id)
go_a [Alt b]
as)
        go (Cast e :: Expr b
e _)       = Expr b -> OrdList (Tickish Id)
go Expr b
e
        go (Tick t :: Tickish Id
t e :: Expr b
e)
          | Tickish Id -> Bool
p Tickish Id
t             = Tickish Id
t Tickish Id -> OrdList (Tickish Id) -> OrdList (Tickish Id)
forall a. a -> OrdList a -> OrdList a
`consOL` Expr b -> OrdList (Tickish Id)
go Expr b
e
          | Bool
otherwise       = Expr b -> OrdList (Tickish Id)
go Expr b
e
        go _                = OrdList (Tickish Id)
forall a. OrdList a
nilOL
        go_bs :: Bind b -> OrdList (Tickish Id)
go_bs (NonRec _ e :: Expr b
e)  = Expr b -> OrdList (Tickish Id)
go Expr b
e
        go_bs (Rec bs :: [(b, Expr b)]
bs)      = [OrdList (Tickish Id)] -> OrdList (Tickish Id)
forall a. [OrdList a] -> OrdList a
concatOL (((b, Expr b) -> OrdList (Tickish Id))
-> [(b, Expr b)] -> [OrdList (Tickish Id)]
forall a b. (a -> b) -> [a] -> [b]
map (b, Expr b) -> OrdList (Tickish Id)
go_b [(b, Expr b)]
bs)
        go_b :: (b, Expr b) -> OrdList (Tickish Id)
go_b (_, e :: Expr b
e)         = Expr b -> OrdList (Tickish Id)
go Expr b
e
        go_a :: Alt b -> OrdList (Tickish Id)
go_a (_, _, e :: Expr b
e)      = Expr b -> OrdList (Tickish Id)
go Expr b
e

{-
************************************************************************
*                                                                      *
\subsection{Other expression construction}
*                                                                      *
************************************************************************
-}

bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
-- ^ @bindNonRec x r b@ produces either:
--
-- > let x = r in b
--
-- or:
--
-- > case r of x { _DEFAULT_ -> b }
--
-- depending on whether we have to use a @case@ or @let@
-- binding for the expression (see 'needsCaseBinding').
-- It's used by the desugarer to avoid building bindings
-- that give Core Lint a heart attack, although actually
-- the simplifier deals with them perfectly well. See
-- also 'MkCore.mkCoreLet'
bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec bndr :: Id
bndr rhs :: CoreExpr
rhs body :: CoreExpr
body
  | Id -> Bool
isTyVar Id
bndr                       = CoreExpr
let_bind
  | Id -> Bool
isCoVar Id
bndr                       = if CoreExpr -> Bool
forall b. Expr b -> Bool
isCoArg CoreExpr
rhs then CoreExpr
let_bind
    {- See Note [Binding coercions] -}                  else CoreExpr
case_bind
  | Id -> Bool
isJoinId Id
bndr                      = CoreExpr
let_bind
  | Type -> CoreExpr -> Bool
needsCaseBinding (Id -> Type
idType Id
bndr) CoreExpr
rhs = CoreExpr
case_bind
  | Bool
otherwise                          = CoreExpr
let_bind
  where
    case_bind :: CoreExpr
case_bind = CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
rhs Id
bndr (CoreExpr -> Type
exprType CoreExpr
body) [(AltCon
DEFAULT, [], CoreExpr
body)]
    let_bind :: CoreExpr
let_bind  = Bind Id -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
bndr CoreExpr
rhs) CoreExpr
body

-- | 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"
needsCaseBinding :: Type -> CoreExpr -> Bool
needsCaseBinding :: Type -> CoreExpr -> Bool
needsCaseBinding ty :: Type
ty rhs :: CoreExpr
rhs = HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
ty Bool -> Bool -> Bool
&& Bool -> Bool
not (CoreExpr -> Bool
exprOkForSpeculation CoreExpr
rhs)
        -- Make a case expression instead of a let
        -- These can arise either from the desugarer,
        -- or from beta reductions: (\x.e) (x +# y)

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
mkAltExpr :: AltCon -> [Id] -> [Type] -> CoreExpr
mkAltExpr (DataAlt con :: DataCon
con) args :: [Id]
args inst_tys :: [Type]
inst_tys
  = DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
con ((Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type [Type]
inst_tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [Id] -> [CoreExpr]
forall b. [Id] -> [Expr b]
varsToCoreExprs [Id]
args)
mkAltExpr (LitAlt lit :: Literal
lit) [] []
  = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit
mkAltExpr (LitAlt _) _ _ = String -> CoreExpr
forall a. String -> a
panic "mkAltExpr LitAlt"
mkAltExpr DEFAULT _ _ = String -> CoreExpr
forall a. String -> a
panic "mkAltExpr DEFAULT"

{- Note [Binding coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider binding a CoVar, c = e.  Then, we must atisfy
Note [CoreSyn type and coercion invariant] in CoreSyn,
which allows only (Coercion co) on the RHS.

************************************************************************
*                                                                      *
               Operations oer case alternatives
*                                                                      *
************************************************************************

The default alternative must be first, if it exists at all.
This makes it easy to find, though it makes matching marginally harder.
-}

-- | Extract the default case alternative
findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
findDefault ((DEFAULT,args :: [a]
args,rhs :: b
rhs) : alts :: [(AltCon, [a], b)]
alts) = ASSERT( null args ) (alts, Just rhs)
findDefault alts :: [(AltCon, [a], b)]
alts                        =                     ([(AltCon, [a], b)]
alts, Maybe b
forall a. Maybe a
Nothing)

addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)]
addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)]
addDefault alts :: [(AltCon, [a], b)]
alts Nothing    = [(AltCon, [a], b)]
alts
addDefault alts :: [(AltCon, [a], b)]
alts (Just rhs :: b
rhs) = (AltCon
DEFAULT, [], b
rhs) (AltCon, [a], b) -> [(AltCon, [a], b)] -> [(AltCon, [a], b)]
forall a. a -> [a] -> [a]
: [(AltCon, [a], b)]
alts

isDefaultAlt :: (AltCon, a, b) -> Bool
isDefaultAlt :: (AltCon, a, b) -> Bool
isDefaultAlt (DEFAULT, _, _) = Bool
True
isDefaultAlt _               = Bool
False

-- | Find the case alternative corresponding to a particular
-- constructor: panics if no such constructor exists
findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
    -- A "Nothing" result *is* legitimate
    -- See Note [Unreachable code]
findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
findAlt con :: AltCon
con alts :: [(AltCon, a, b)]
alts
  = case [(AltCon, a, b)]
alts of
        (deflt :: (AltCon, a, b)
deflt@(DEFAULT,_,_):alts :: [(AltCon, a, b)]
alts) -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) -> Maybe (AltCon, a, b)
forall b c.
[(AltCon, b, c)] -> Maybe (AltCon, b, c) -> Maybe (AltCon, b, c)
go [(AltCon, a, b)]
alts ((AltCon, a, b) -> Maybe (AltCon, a, b)
forall a. a -> Maybe a
Just (AltCon, a, b)
deflt)
        _                          -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) -> Maybe (AltCon, a, b)
forall b c.
[(AltCon, b, c)] -> Maybe (AltCon, b, c) -> Maybe (AltCon, b, c)
go [(AltCon, a, b)]
alts Maybe (AltCon, a, b)
forall a. Maybe a
Nothing
  where
    go :: [(AltCon, b, c)] -> Maybe (AltCon, b, c) -> Maybe (AltCon, b, c)
go []                     deflt :: Maybe (AltCon, b, c)
deflt = Maybe (AltCon, b, c)
deflt
    go (alt :: (AltCon, b, c)
alt@(con1 :: AltCon
con1,_,_) : alts :: [(AltCon, b, c)]
alts) deflt :: Maybe (AltCon, b, c)
deflt
      = case AltCon
con AltCon -> AltCon -> Ordering
`cmpAltCon` AltCon
con1 of
          LT -> Maybe (AltCon, b, c)
deflt   -- Missed it already; the alts are in increasing order
          EQ -> (AltCon, b, c) -> Maybe (AltCon, b, c)
forall a. a -> Maybe a
Just (AltCon, b, c)
alt
          GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt

{- Note [Unreachable code]
~~~~~~~~~~~~~~~~~~~~~~~~~~
It is possible (although unusual) for GHC to find a case expression
that cannot match.  For example:

     data Col = Red | Green | Blue
     x = Red
     f v = case x of
              Red -> ...
              _ -> ...(case x of { Green -> e1; Blue -> e2 })...

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 })
     f v = case x of
             Red -> ...
             _ -> ...lvl...

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

---------------------------------
mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
-- ^ Merge alternatives preserving order; alternatives in
-- the first argument shadow ones in the second
mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
mergeAlts [] as2 :: [(AltCon, a, b)]
as2 = [(AltCon, a, b)]
as2
mergeAlts as1 :: [(AltCon, a, b)]
as1 [] = [(AltCon, a, b)]
as1
mergeAlts (a1 :: (AltCon, a, b)
a1:as1 :: [(AltCon, a, b)]
as1) (a2 :: (AltCon, a, b)
a2:as2 :: [(AltCon, a, b)]
as2)
  = case (AltCon, a, b)
a1 (AltCon, a, b) -> (AltCon, a, b) -> Ordering
forall a b. (AltCon, a, b) -> (AltCon, a, b) -> Ordering
`cmpAlt` (AltCon, a, b)
a2 of
        LT -> (AltCon, a, b)
a1 (AltCon, a, b) -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a. a -> [a] -> [a]
: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a b.
[(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
mergeAlts [(AltCon, a, b)]
as1      ((AltCon, a, b)
a2(AltCon, a, b) -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a. a -> [a] -> [a]
:[(AltCon, a, b)]
as2)
        EQ -> (AltCon, a, b)
a1 (AltCon, a, b) -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a. a -> [a] -> [a]
: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a b.
[(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
mergeAlts [(AltCon, a, b)]
as1      [(AltCon, a, b)]
as2       -- Discard a2
        GT -> (AltCon, a, b)
a2 (AltCon, a, b) -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a. a -> [a] -> [a]
: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a b.
[(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
mergeAlts ((AltCon, a, b)
a1(AltCon, a, b) -> [(AltCon, a, b)] -> [(AltCon, a, b)]
forall a. a -> [a] -> [a]
:[(AltCon, a, b)]
as1) [(AltCon, a, b)]
as2


---------------------------------
trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
-- ^ Given:
--
-- > case (C a b x y) of
-- >        C b x y -> ...
--
-- We want to drop the leading type argument of the scrutinee
-- leaving the arguments to match against the pattern

trimConArgs :: AltCon -> [CoreExpr] -> [CoreExpr]
trimConArgs DEFAULT      args :: [CoreExpr]
args = ASSERT( null args ) []
trimConArgs (LitAlt _)   args :: [CoreExpr]
args = ASSERT( null args ) []
trimConArgs (DataAlt dc :: DataCon
dc) args :: [CoreExpr]
args = [Id] -> [CoreExpr] -> [CoreExpr]
forall b a. [b] -> [a] -> [a]
dropList (DataCon -> [Id]
dataConUnivTyVars DataCon
dc) [CoreExpr]
args

filterAlts :: TyCon                -- ^ Type constructor of scrutinee's type (used to prune possibilities)
           -> [Type]               -- ^ And its type arguments
           -> [AltCon]             -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee
           -> [(AltCon, [Var], a)] -- ^ Alternatives
           -> ([AltCon], [(AltCon, [Var], a)])
             -- Returns:
             --  1. Constructors that will never be encountered by the
             --     *default* case (if any).  A superset of imposs_cons
             --  2. The new alternatives, trimmed by
             --        a) remove imposs_cons
             --        b) remove constructors which can't match because of GADTs
             --
             -- NB: the final list of alternatives may be empty:
             -- This is a tricky corner case.  If the data type has no constructors,
             -- which GHC allows, or if the imposs_cons covers all constructors (after taking
             -- account of GADTs), then no alternatives can match.
             --
             -- 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.
filterAlts :: TyCon
-> [Type]
-> [AltCon]
-> [(AltCon, [Id], a)]
-> ([AltCon], [(AltCon, [Id], a)])
filterAlts _tycon :: TyCon
_tycon inst_tys :: [Type]
inst_tys imposs_cons :: [AltCon]
imposs_cons alts :: [(AltCon, [Id], a)]
alts
  = ([AltCon]
imposs_deflt_cons, [(AltCon, [Id], a)] -> Maybe a -> [(AltCon, [Id], a)]
forall a b. [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)]
addDefault [(AltCon, [Id], a)]
trimmed_alts Maybe a
maybe_deflt)
  where
    (alts_wo_default :: [(AltCon, [Id], a)]
alts_wo_default, maybe_deflt :: Maybe a
maybe_deflt) = [(AltCon, [Id], a)] -> ([(AltCon, [Id], a)], Maybe a)
forall a b. [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
findDefault [(AltCon, [Id], a)]
alts
    alt_cons :: [AltCon]
alt_cons = [AltCon
con | (con :: AltCon
con,_,_) <- [(AltCon, [Id], a)]
alts_wo_default]

    trimmed_alts :: [(AltCon, [Id], a)]
trimmed_alts = ((AltCon, [Id], a) -> Bool)
-> [(AltCon, [Id], a)] -> [(AltCon, [Id], a)]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ([Type] -> (AltCon, [Id], a) -> Bool
forall a b. [Type] -> (AltCon, a, b) -> Bool
impossible_alt [Type]
inst_tys) [(AltCon, [Id], a)]
alts_wo_default

    imposs_cons_set :: Set AltCon
imposs_cons_set = [AltCon] -> Set AltCon
forall a. Ord a => [a] -> Set a
Set.fromList [AltCon]
imposs_cons
    imposs_deflt_cons :: [AltCon]
imposs_deflt_cons =
      [AltCon]
imposs_cons [AltCon] -> [AltCon] -> [AltCon]
forall a. [a] -> [a] -> [a]
++ (AltCon -> Bool) -> [AltCon] -> [AltCon]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (AltCon -> Set AltCon -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set AltCon
imposs_cons_set) [AltCon]
alt_cons
         -- "imposs_deflt_cons" are handled
         --   EITHER by the context,
         --   OR by a non-DEFAULT branch in this case expression.

    impossible_alt :: [Type] -> (AltCon, a, b) -> Bool
    impossible_alt :: [Type] -> (AltCon, a, b) -> Bool
impossible_alt _ (con :: AltCon
con, _, _) | AltCon
con AltCon -> Set AltCon -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set AltCon
imposs_cons_set = Bool
True
    impossible_alt inst_tys :: [Type]
inst_tys (DataAlt con :: DataCon
con, _, _) = [Type] -> DataCon -> Bool
dataConCannotMatch [Type]
inst_tys DataCon
con
    impossible_alt _  _                         = Bool
False

-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so.
-- See Note [Refine Default Alts]
refineDefaultAlt :: [Unique]          -- ^ Uniques for constructing new binders
                 -> TyCon             -- ^ Type constructor of scrutinee's type
                 -> [Type]            -- ^ Type arguments of scrutinee's type
                 -> [AltCon]          -- ^ Constructors that cannot match the DEFAULT (if any)
                 -> [CoreAlt]
                 -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt'
refineDefaultAlt :: [Unique]
-> TyCon -> [Type] -> [AltCon] -> [CoreAlt] -> (Bool, [CoreAlt])
refineDefaultAlt us :: [Unique]
us tycon :: TyCon
tycon tys :: [Type]
tys imposs_deflt_cons :: [AltCon]
imposs_deflt_cons all_alts :: [CoreAlt]
all_alts
  | (DEFAULT,_,rhs :: CoreExpr
rhs) : rest_alts :: [CoreAlt]
rest_alts <- [CoreAlt]
all_alts
  , TyCon -> Bool
isAlgTyCon TyCon
tycon            -- It's a data type, tuple, or unboxed tuples.
  , Bool -> Bool
not (TyCon -> Bool
isNewTyCon TyCon
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 :: [DataCon]
all_cons <- TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tycon
  , let imposs_data_cons :: UniqSet DataCon
imposs_data_cons = [DataCon] -> UniqSet DataCon
forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet [DataCon
con | DataAlt con :: DataCon
con <- [AltCon]
imposs_deflt_cons]
                             -- We now know it's a data type, so we can use
                             -- UniqSet rather than Set (more efficient)
        impossible :: DataCon -> Bool
impossible con :: DataCon
con   = DataCon
con DataCon -> UniqSet DataCon -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` UniqSet DataCon
imposs_data_cons
                             Bool -> Bool -> Bool
|| [Type] -> DataCon -> Bool
dataConCannotMatch [Type]
tys DataCon
con
  = case (DataCon -> Bool) -> [DataCon] -> [DataCon]
forall a. (a -> Bool) -> [a] -> [a]
filterOut DataCon -> Bool
impossible [DataCon]
all_cons of
       -- Eliminate the default alternative
       -- altogether if it can't match:
       []    -> (Bool
False, [CoreAlt]
rest_alts)

       -- It matches exactly one constructor, so fill it in:
       [con :: DataCon
con] -> (Bool
True, [CoreAlt] -> [CoreAlt] -> [CoreAlt]
forall a b.
[(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
mergeAlts [CoreAlt]
rest_alts [(DataCon -> AltCon
DataAlt DataCon
con, [Id]
ex_tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
arg_ids, CoreExpr
rhs)])
                       -- We need the mergeAlts to keep the alternatives in the right order
             where
                (ex_tvs :: [Id]
ex_tvs, arg_ids :: [Id]
arg_ids) = [Unique] -> DataCon -> [Type] -> ([Id], [Id])
dataConRepInstPat [Unique]
us DataCon
con [Type]
tys

       -- It matches more than one, so do nothing
       _  -> (Bool
False, [CoreAlt]
all_alts)

  | Bool
debugIsOn, TyCon -> Bool
isAlgTyCon TyCon
tycon, [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TyCon -> [DataCon]
tyConDataCons TyCon
tycon)
  , Bool -> Bool
not (TyCon -> Bool
isFamilyTyCon TyCon
tycon Bool -> Bool -> Bool
|| TyCon -> Bool
isAbstractTyCon TyCon
tycon)
        -- Check for no data constructors
        -- This can legitimately happen for abstract types and type families,
        -- so don't report that
  = (Bool
False, [CoreAlt]
all_alts)

  | Bool
otherwise      -- The common case
  = (Bool
False, [CoreAlt]
all_alts)

{- Note [Refine Default Alts]

refineDefaultAlt replaces the DEFAULT alt with a constructor if there is one
possible value it could be.

The simplest example being

foo :: () -> ()
foo x = case x of !_ -> ()

rewrites to

foo :: () -> ()
foo x = case x of () -> ()

There are two reasons in general why this is desirable.

1. We can simplify inner expressions

In this example we can eliminate the inner case by refining the outer case.
If we don't refine it, we are left with both case expressions.

```
{-# LANGUAGE BangPatterns #-}
module Test where

mid x = x
{-# NOINLINE mid #-}

data Foo = Foo1 ()

test :: Foo -> ()
test x =
  case x of
    !_ -> mid (case x of
                Foo1 x1 -> x1)

```

refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then x
becomes bound to `Foo ip1` so is inlined into the other case which
causes the KnownBranch optimisation to kick in.


2. combineIdenticalAlts does a better job

Simon Jakobi also points out that that combineIdenticalAlts will do a better job
if we refine the DEFAULT first.

```
data D = C0 | C1 | C2

case e of
   DEFAULT -> e0
   C0 -> e1
   C1 -> e1
```

When we apply combineIdenticalAlts to this expression, it can't
combine the alts for C0 and C1, as we already have a default case.

If we apply refineDefaultAlt first, we get

```
case e of
  C0 -> e1
  C1 -> e1
  C2 -> e0
```

and combineIdenticalAlts can turn that into

```
case e of
  DEFAULT -> e1
  C2 -> e0
```

It isn't obvious that refineDefaultAlt does this but if you look at its one
call site in SimplUtils then the `imposs_deflt_cons` argument is populated with
constructors which are matched elsewhere.

-}




{- Note [Combine identical alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If several alternatives are identical, merge them into a single
DEFAULT alternative.  I've occasionally seen this making a big
difference:

     case e of               =====>     case e of
       C _ -> f x                         D v -> ....v....
       D v -> ....v....                   DEFAULT -> f x
       DEFAULT -> f x

The point is that we merge common RHSs, at least for the DEFAULT case.
[One could do something more elaborate but I've never seen it needed.]
To avoid an expensive test, we just merge branches equal to the *first*
alternative; this picks up the common cases
     a) all branches equal
     b) some branches equal to the DEFAULT (which occurs first)

The case where Combine Identical Alternatives transformation showed up
was like this (base/Foreign/C/Err/Error.hs):

        x | p `is` 1 -> e1
          | p `is` 2 -> e2
        ...etc...

where @is@ was something like

        p `is` n = p /= (-1) && p == n

This gave rise to a horrible sequence of cases

        case p of
          (-1) -> $j p
          1    -> e1
          DEFAULT -> $j p

and similarly in cascade for all the join points!

NB: it's important that all this is done in [InAlt], *before* we work
on the alternatives themselves, because Simplify.simplAlt may zap the
occurrence info on the binders in the alternatives, which in turn
defeats combineIdenticalAlts (see Trac #7360).

Note [Care with impossible-constructors when combining alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have (Trac #10538)
   data T = A | B | C | D

      case x::T of   (Imposs-default-cons {A,B})
         DEFAULT -> e1
         A -> e2
         B -> e1

When calling combineIdentialAlts, we'll have computed that the
"impossible constructors" for the DEFAULT alt is {A,B}, since if x is
A or B we'll take the other alternatives.  But suppose we combine B
into the DEFAULT, to get

      case x::T of   (Imposs-default-cons {A})
         DEFAULT -> e1
         A -> e2

Then we must be careful to trim the impossible constructors to just {A},
else we risk compiling 'e1' wrong!

Not only that, but we take care when there is no DEFAULT beforehand,
because we are introducing one.  Consider

   case x of   (Imposs-default-cons {A,B,C})
     A -> e1
     B -> e2
     C -> e1

Then when combining the A and C alternatives we get

   case x of   (Imposs-default-cons {B})
     DEFAULT -> e1
     B -> e2

Note that we have a new DEFAULT branch that we didn't have before.  So
we need delete from the "impossible-default-constructors" all the
known-con alternatives that we have eliminated. (In Trac #11172 we
missed the first one.)

-}

combineIdenticalAlts :: [AltCon]    -- Constructors that cannot match DEFAULT
                     -> [CoreAlt]
                     -> (Bool,      -- True <=> something happened
                         [AltCon],  -- New constructors that cannot match DEFAULT
                         [CoreAlt]) -- New alternatives
-- See Note [Combine identical alternatives]
-- True <=> we did some combining, result is a single DEFAULT alternative
combineIdenticalAlts :: [AltCon] -> [CoreAlt] -> (Bool, [AltCon], [CoreAlt])
combineIdenticalAlts imposs_deflt_cons :: [AltCon]
imposs_deflt_cons ((con1 :: AltCon
con1,bndrs1 :: [Id]
bndrs1,rhs1 :: CoreExpr
rhs1) : rest_alts :: [CoreAlt]
rest_alts)
  | (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isDeadBinder [Id]
bndrs1    -- Remember the default
  , Bool -> Bool
not ([CoreAlt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreAlt]
elim_rest) -- alternative comes first
  = (Bool
True, [AltCon]
imposs_deflt_cons', CoreAlt
forall a. (AltCon, [a], CoreExpr)
deflt_alt CoreAlt -> [CoreAlt] -> [CoreAlt]
forall a. a -> [a] -> [a]
: [CoreAlt]
filtered_rest)
  where
    (elim_rest :: [CoreAlt]
elim_rest, filtered_rest :: [CoreAlt]
filtered_rest) = (CoreAlt -> Bool) -> [CoreAlt] -> ([CoreAlt], [CoreAlt])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition CoreAlt -> Bool
forall (t :: * -> *) a. Foldable t => (a, t Id, CoreExpr) -> Bool
identical_to_alt1 [CoreAlt]
rest_alts
    deflt_alt :: (AltCon, [a], CoreExpr)
deflt_alt = (AltCon
DEFAULT, [], [Tickish Id] -> CoreExpr -> CoreExpr
mkTicks ([[Tickish Id]] -> [Tickish Id]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Tickish Id]]
tickss) CoreExpr
rhs1)

     -- See Note [Care with impossible-constructors when combining alternatives]
    imposs_deflt_cons' :: [AltCon]
imposs_deflt_cons' = [AltCon]
imposs_deflt_cons [AltCon] -> [AltCon] -> [AltCon]
forall a. Ord a => [a] -> [a] -> [a]
`minusList` [AltCon]
elim_cons
    elim_cons :: [AltCon]
elim_cons = [AltCon]
elim_con1 [AltCon] -> [AltCon] -> [AltCon]
forall a. [a] -> [a] -> [a]
++ (CoreAlt -> AltCon) -> [CoreAlt] -> [AltCon]
forall a b. (a -> b) -> [a] -> [b]
map CoreAlt -> AltCon
forall a b c. (a, b, c) -> a
fstOf3 [CoreAlt]
elim_rest
    elim_con1 :: [AltCon]
elim_con1 = case AltCon
con1 of     -- Don't forget con1!
                  DEFAULT -> []  -- See Note [
                  _       -> [AltCon
con1]

    cheapEqTicked :: Expr b -> Expr b -> Bool
cheapEqTicked e1 :: Expr b
e1 e2 :: Expr b
e2 = (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
forall b. (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable Expr b
e1 Expr b
e2
    identical_to_alt1 :: (a, t Id, CoreExpr) -> Bool
identical_to_alt1 (_con :: a
_con,bndrs :: t Id
bndrs,rhs :: CoreExpr
rhs)
      = (Id -> Bool) -> t Id -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isDeadBinder t Id
bndrs Bool -> Bool -> Bool
&& CoreExpr
rhs CoreExpr -> CoreExpr -> Bool
forall b. Expr b -> Expr b -> Bool
`cheapEqTicked` CoreExpr
rhs1
    tickss :: [[Tickish Id]]
tickss = (CoreAlt -> [Tickish Id]) -> [CoreAlt] -> [[Tickish Id]]
forall a b. (a -> b) -> [a] -> [b]
map ((Tickish Id -> Bool) -> CoreExpr -> [Tickish Id]
forall b. (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
stripTicksT Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable (CoreExpr -> [Tickish Id])
-> (CoreAlt -> CoreExpr) -> CoreAlt -> [Tickish Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreAlt -> CoreExpr
forall a b c. (a, b, c) -> c
thdOf3) [CoreAlt]
elim_rest

combineIdenticalAlts imposs_cons :: [AltCon]
imposs_cons alts :: [CoreAlt]
alts
  = (Bool
False, [AltCon]
imposs_cons, [CoreAlt]
alts)

{- *********************************************************************
*                                                                      *
             exprIsTrivial
*                                                                      *
************************************************************************

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

Note [Variables are trivial]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There used to be a gruesome test for (hasNoBinding v) in the
Var case:
        exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
The idea here is that a constructor worker, like \$wJust, is
really short for (\x -> \$wJust x), because \$wJust has no binding.
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.

Note [Tick trivial]
~~~~~~~~~~~~~~~~~~~
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.

Note [Empty case is trivial]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The expression (case (x::Int) Bool of {}) is just a type-changing
case used when we are sure that 'x' will not return.  See
Note [Empty case alternatives] in CoreSyn.

If the scrutinee is trivial, then so is the whole expression; and the
CoreToSTG pass in fact drops the case expression leaving only the
scrutinee.

Having more trivial expressions is good.  Moreover, if we don't treat
it as trivial we may land up with let-bindings like
   let v = case x of {} in ...
and after CoreToSTG that gives
   let v = x in ...
and that confuses the code generator (Trac #11155). So best to kill
it off at source.
-}

exprIsTrivial :: CoreExpr -> Bool
-- If you modify this function, you may also
-- need to modify getIdFromTrivialExpr
exprIsTrivial :: CoreExpr -> Bool
exprIsTrivial (Var _)          = Bool
True        -- See Note [Variables are trivial]
exprIsTrivial (Type _)         = Bool
True
exprIsTrivial (Coercion _)     = Bool
True
exprIsTrivial (Lit lit :: Literal
lit)        = Literal -> Bool
litIsTrivial Literal
lit
exprIsTrivial (App e :: CoreExpr
e arg :: CoreExpr
arg)      = Bool -> Bool
not (CoreExpr -> Bool
isRuntimeArg CoreExpr
arg) Bool -> Bool -> Bool
&& CoreExpr -> Bool
exprIsTrivial CoreExpr
e
exprIsTrivial (Lam b :: Id
b e :: CoreExpr
e)        = Bool -> Bool
not (Id -> Bool
isRuntimeVar Id
b) Bool -> Bool -> Bool
&& CoreExpr -> Bool
exprIsTrivial CoreExpr
e
exprIsTrivial (Tick t :: Tickish Id
t e :: CoreExpr
e)       = Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
t) Bool -> Bool -> Bool
&& CoreExpr -> Bool
exprIsTrivial CoreExpr
e
                                 -- See Note [Tick trivial]
exprIsTrivial (Cast e :: CoreExpr
e _)       = CoreExpr -> Bool
exprIsTrivial CoreExpr
e
exprIsTrivial (Case e :: CoreExpr
e _ _ [])  = CoreExpr -> Bool
exprIsTrivial CoreExpr
e  -- See Note [Empty case is trivial]
exprIsTrivial _                = Bool
False

{-
Note [getIdFromTrivialExpr]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
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, AND the expression is not a literal.
See Note [substTickish] for how breakpoint substitution preserves
this extra invariant.

We also need this functionality in CorePrep to extract out Id of a
function which we are saturating.  However, in this case we don't know
if the variable actually refers to a literal; thus we use
'getIdFromTrivialExpr_maybe' to handle this case.  See test
T12076lit for an example where this matters.
-}

getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id
getIdFromTrivialExpr :: CoreExpr -> Id
getIdFromTrivialExpr e :: CoreExpr
e
    = Id -> Maybe Id -> Id
forall a. a -> Maybe a -> a
fromMaybe (String -> SDoc -> Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic "getIdFromTrivialExpr" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e))
                (CoreExpr -> Maybe Id
getIdFromTrivialExpr_maybe CoreExpr
e)

getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id
-- See Note [getIdFromTrivialExpr]
-- Th equations for this should line up with those for exprIsTrivial
getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id
getIdFromTrivialExpr_maybe e :: CoreExpr
e
  = CoreExpr -> Maybe Id
go CoreExpr
e
  where
    go :: CoreExpr -> Maybe Id
go (App f :: CoreExpr
f t :: CoreExpr
t) | Bool -> Bool
not (CoreExpr -> Bool
isRuntimeArg CoreExpr
t)   = CoreExpr -> Maybe Id
go CoreExpr
f
    go (Tick t :: Tickish Id
t e :: CoreExpr
e) | Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
t) = CoreExpr -> Maybe Id
go CoreExpr
e
    go (Cast e :: CoreExpr
e _)                         = CoreExpr -> Maybe Id
go CoreExpr
e
    go (Lam b :: Id
b e :: CoreExpr
e) | Bool -> Bool
not (Id -> Bool
isRuntimeVar Id
b)   = CoreExpr -> Maybe Id
go CoreExpr
e
    go (Case e :: CoreExpr
e _ _ [])                    = CoreExpr -> Maybe Id
go CoreExpr
e
    go (Var v :: Id
v) = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
v
    go _       = Maybe Id
forall a. Maybe a
Nothing

{-
exprIsBottom is a very cheap and cheerful function; it may return
False for bottoming expressions, but it never costs much to ask.  See
also CoreArity.exprBotStrictness_maybe, but that's a bit more
expensive.
-}

exprIsBottom :: CoreExpr -> Bool
-- See Note [Bottoming expressions]
exprIsBottom :: CoreExpr -> Bool
exprIsBottom e :: CoreExpr
e
  | Type -> Bool
isEmptyTy (CoreExpr -> Type
exprType CoreExpr
e)
  = Bool
True
  | Bool
otherwise
  = Int -> CoreExpr -> Bool
go 0 CoreExpr
e
  where
    go :: Int -> CoreExpr -> Bool
go n :: Int
n (Var v :: Id
v) = Id -> Bool
isBottomingId Id
v Bool -> Bool -> Bool
&&  Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Id -> Int
idArity Id
v
    go n :: Int
n (App e :: CoreExpr
e a :: CoreExpr
a) | CoreExpr -> Bool
forall b. Expr b -> Bool
isTypeArg CoreExpr
a = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
                   | Bool
otherwise   = Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) CoreExpr
e
    go n :: Int
n (Tick _ e :: CoreExpr
e)              = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
    go n :: Int
n (Cast e :: CoreExpr
e _)              = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
    go n :: Int
n (Let _ e :: CoreExpr
e)               = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
    go n :: Int
n (Lam v :: Id
v e :: CoreExpr
e) | Id -> Bool
isTyVar Id
v   = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
    go _ (Case _ _ _ alts :: [CoreAlt]
alts)       = [CoreAlt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreAlt]
alts
       -- See Note [Empty case alternatives] in CoreSyn
    go _ _                       = Bool
False

{- Note [Bottoming expressions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A bottoming expression is guaranteed to diverge, or raise an
exception.  We can test for it in two different ways, and exprIsBottom
checks for both of these situations:

* Visibly-bottom computations.  For example
      (error Int "Hello")
  is visibly bottom.  The strictness analyser also finds out if
  a function diverges or raises an exception, and puts that info
  in its strictness signature.

* Empty types.  If a type is empty, its only inhabitant is bottom.
  For example:
      data T
      f :: T -> Bool
      f = \(x:t). case x of Bool {}
  Since T has no data constructors, the case alternatives are of course
  empty.  However note that 'x' is not bound to a visibly-bottom value;
  it's the *type* that tells us it's going to diverge.

A GADT may also be empty even though it has constructors:
        data T a where
          T1 :: a -> T Bool
          T2 :: T Int
        ...(case (x::T Char) of {})...
Here (T Char) is uninhabited.  A more realistic case is (Int ~ Bool),
which is likewise uninhabited.


************************************************************************
*                                                                      *
             exprIsDupable
*                                                                      *
************************************************************************

Note [exprIsDupable]
~~~~~~~~~~~~~~~~~~~~
@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.

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

                Its only purpose is to avoid fruitless let-binding
                and then inlining of case join points
-}

exprIsDupable :: DynFlags -> CoreExpr -> Bool
exprIsDupable :: DynFlags -> CoreExpr -> Bool
exprIsDupable dflags :: DynFlags
dflags e :: CoreExpr
e
  = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Int -> CoreExpr -> Maybe Int
go Int
dupAppSize CoreExpr
e)
  where
    go :: Int -> CoreExpr -> Maybe Int
    go :: Int -> CoreExpr -> Maybe Int
go n :: Int
n (Type {})     = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
    go n :: Int
n (Coercion {}) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
    go n :: Int
n (Var {})      = Int -> Maybe Int
decrement Int
n
    go n :: Int
n (Tick _ e :: CoreExpr
e)    = Int -> CoreExpr -> Maybe Int
go Int
n CoreExpr
e
    go n :: Int
n (Cast e :: CoreExpr
e _)    = Int -> CoreExpr -> Maybe Int
go Int
n CoreExpr
e
    go n :: Int
n (App f :: CoreExpr
f a :: CoreExpr
a) | Just n' :: Int
n' <- Int -> CoreExpr -> Maybe Int
go Int
n CoreExpr
a = Int -> CoreExpr -> Maybe Int
go Int
n' CoreExpr
f
    go n :: Int
n (Lit lit :: Literal
lit) | DynFlags -> Literal -> Bool
litIsDupable DynFlags
dflags Literal
lit = Int -> Maybe Int
decrement Int
n
    go _ _ = Maybe Int
forall a. Maybe a
Nothing

    decrement :: Int -> Maybe Int
    decrement :: Int -> Maybe Int
decrement 0 = Maybe Int
forall a. Maybe a
Nothing
    decrement n :: Int
n = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)

dupAppSize :: Int
dupAppSize :: Int
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.

{-
************************************************************************
*                                                                      *
             exprIsCheap, exprIsExpandable
*                                                                      *
************************************************************************

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
going to put up with this, because the previous more aggressive inlining
(which treated 'noFactor' as work-free) was duplicating primops, which
in turn was making inner loops of array calculations runs slow (#5623)

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
(case x of ....) as work-free if the alternatives are.

Moreover it improves arities of overloaded functions where
there is only dictionary selection (no construction) involved

Note [exprIsCheap]   See also Note [Interaction of exprIsCheap and lone variables]
~~~~~~~~~~~~~~~~~~   in CoreUnfold.hs
@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.]

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

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

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

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

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

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

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

Note [Arguments and let-bindings exprIsCheapX]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
What predicate should we apply to the argument of an application, or the
RHS of a let-binding?

We used to say "exprIsTrivial arg" due to concerns about duplicating
nested constructor applications, but see #4978.  So now we just recursively
use exprIsCheapX.

We definitely want to treat let and app the same.  The principle here is
that
   let x = blah in f x
should behave equivalently to
   f blah

This in turn means that the 'letrec g' does not prevent eta expansion
in this (which it previously was):
    f = \x. let v = case x of
                      True -> letrec g = \w. blah
                              in g
                      False -> \x. x
            in \w. v True
-}

--------------------
exprIsWorkFree :: CoreExpr -> Bool   -- See Note [exprIsWorkFree]
exprIsWorkFree :: CoreExpr -> Bool
exprIsWorkFree = CheapAppFun -> CoreExpr -> Bool
exprIsCheapX CheapAppFun
isWorkFreeApp

exprIsCheap :: CoreExpr -> Bool
exprIsCheap :: CoreExpr -> Bool
exprIsCheap = CheapAppFun -> CoreExpr -> Bool
exprIsCheapX CheapAppFun
isCheapApp

exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool
exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool
exprIsCheapX ok_app :: CheapAppFun
ok_app e :: CoreExpr
e
  = CoreExpr -> Bool
ok CoreExpr
e
  where
    ok :: CoreExpr -> Bool
ok e :: CoreExpr
e = Int -> CoreExpr -> Bool
go 0 CoreExpr
e

    -- n is the number of value arguments
    go :: Int -> CoreExpr -> Bool
go n :: Int
n (Var v :: Id
v)                      = CheapAppFun
ok_app Id
v Int
n
    go _ (Lit {})                     = Bool
True
    go _ (Type {})                    = Bool
True
    go _ (Coercion {})                = Bool
True
    go n :: Int
n (Cast e :: CoreExpr
e _)                   = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
    go n :: Int
n (Case scrut :: CoreExpr
scrut _ _ alts :: [CoreAlt]
alts)        = CoreExpr -> Bool
ok CoreExpr
scrut Bool -> Bool -> Bool
&&
                                        [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Int -> CoreExpr -> Bool
go Int
n CoreExpr
rhs | (_,_,rhs :: CoreExpr
rhs) <- [CoreAlt]
alts ]
    go n :: Int
n (Tick t :: Tickish Id
t e :: CoreExpr
e) | Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishCounts Tickish Id
t = Bool
False
                    | Bool
otherwise       = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
    go n :: Int
n (Lam x :: Id
x e :: CoreExpr
e)  | Id -> Bool
isRuntimeVar Id
x  = Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==0 Bool -> Bool -> Bool
|| Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) CoreExpr
e
                    | Bool
otherwise       = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
    go n :: Int
n (App f :: CoreExpr
f e :: CoreExpr
e)  | CoreExpr -> Bool
isRuntimeArg CoreExpr
e  = Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) CoreExpr
f Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
e
                    | Bool
otherwise       = Int -> CoreExpr -> Bool
go Int
n CoreExpr
f
    go n :: Int
n (Let (NonRec _ r :: CoreExpr
r) e :: CoreExpr
e)         = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
r
    go n :: Int
n (Let (Rec prs :: [(Id, CoreExpr)]
prs) e :: CoreExpr
e)            = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e Bool -> Bool -> Bool
&& ((Id, CoreExpr) -> Bool) -> [(Id, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (CoreExpr -> Bool
ok (CoreExpr -> Bool)
-> ((Id, CoreExpr) -> CoreExpr) -> (Id, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, CoreExpr) -> CoreExpr
forall a b. (a, b) -> b
snd) [(Id, CoreExpr)]
prs

      -- Case: see Note [Case expressions are work-free]
      -- App, Let: see Note [Arguments and let-bindings exprIsCheapX]


{- Note [exprIsExpandable]
~~~~~~~~~~~~~~~~~~~~~~~~~~
An expression is "expandable" if we are willing to duplicate it, if doing
so might make a RULE or case-of-constructor fire.  Consider
   let x = (a,b)
       y = build g
   in ....(case x of (p,q) -> rhs)....(foldr k z y)....

We don't inline 'x' or 'y' (see Note [Lone variables] in CoreUnfold),
but we do want

 * the case-expression to simplify
   (via exprIsConApp_maybe, exprIsLiteral_maybe)

 * the foldr/build RULE to fire
   (by expanding the unfolding during rule matching)

So we classify the unfolding of a let-binding as "expandable" (via the
uf_expandable field) if we want to do this kind of on-the-fly
expansion.  Specifically:

* True of constructor applications (K a b)

* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in BasicTypes.
  (NB: exprIsCheap might not be true of this)

* False of case-expressions.  If we have
    let x = case ... in ...(case x of ...)...
  we won't simplify.  We have to inline x.  See Trac #14688.

* False of let-expressions (same reason); and in any case we
  float lets out of an RHS if doing so will reveal an expandable
  application (see SimplEnv.doFloatFromRhs).

* Take care: exprIsExpandable should /not/ be true of primops.  I
  found this in test T5623a:
    let q = /\a. Ptr a (a +# b)
    in case q @ Float of Ptr v -> ...q...

  q's inlining should not be expandable, else exprIsConApp_maybe will
  say that (q @ Float) expands to (Ptr a (a +# b)), and that will
  duplicate the (a +# b) primop, which we should not do lightly.
  (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)
-}

-------------------------------------
exprIsExpandable :: CoreExpr -> Bool
-- See Note [exprIsExpandable]
exprIsExpandable :: CoreExpr -> Bool
exprIsExpandable e :: CoreExpr
e
  = CoreExpr -> Bool
ok CoreExpr
e
  where
    ok :: CoreExpr -> Bool
ok e :: CoreExpr
e = Int -> CoreExpr -> Bool
go 0 CoreExpr
e

    -- n is the number of value arguments
    go :: Int -> CoreExpr -> Bool
go n :: Int
n (Var v :: Id
v)                      = CheapAppFun
isExpandableApp Id
v Int
n
    go _ (Lit {})                     = Bool
True
    go _ (Type {})                    = Bool
True
    go _ (Coercion {})                = Bool
True
    go n :: Int
n (Cast e :: CoreExpr
e _)                   = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
    go n :: Int
n (Tick t :: Tickish Id
t e :: CoreExpr
e) | Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishCounts Tickish Id
t = Bool
False
                    | Bool
otherwise       = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
    go n :: Int
n (Lam x :: Id
x e :: CoreExpr
e)  | Id -> Bool
isRuntimeVar Id
x  = Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==0 Bool -> Bool -> Bool
|| Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) CoreExpr
e
                    | Bool
otherwise       = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
    go n :: Int
n (App f :: CoreExpr
f e :: CoreExpr
e)  | CoreExpr -> Bool
isRuntimeArg CoreExpr
e  = Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) CoreExpr
f Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
e
                    | Bool
otherwise       = Int -> CoreExpr -> Bool
go Int
n CoreExpr
f
    go _ (Case {})                    = Bool
False
    go _ (Let {})                     = Bool
False


-------------------------------------
type CheapAppFun = Id -> Arity -> Bool
  -- Is an application of this function to n *value* args
  -- always cheap, assuming the arguments are cheap?
  -- True mainly of data constructors, partial applications;
  -- but with minor variations:
  --    isWorkFreeApp
  --    isCheapApp
  --    isExpandableApp

isWorkFreeApp :: CheapAppFun
isWorkFreeApp :: CheapAppFun
isWorkFreeApp fn :: Id
fn n_val_args :: Int
n_val_args
  | Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0           -- No value args
  = Bool
True
  | Int
n_val_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Id -> Int
idArity Id
fn   -- Partial application
  = Bool
True
  | Bool
otherwise
  = case Id -> IdDetails
idDetails Id
fn of
      DataConWorkId {} -> Bool
True
      _                -> Bool
False

isCheapApp :: CheapAppFun
isCheapApp :: CheapAppFun
isCheapApp fn :: Id
fn n_val_args :: Int
n_val_args
  | CheapAppFun
isWorkFreeApp Id
fn Int
n_val_args = Bool
True
  | Id -> Bool
isBottomingId Id
fn            = Bool
True  -- See Note [isCheapApp: bottoming functions]
  | Bool
otherwise
  = case Id -> IdDetails
idDetails Id
fn of
      DataConWorkId {} -> Bool
True  -- Actually handled by isWorkFreeApp
      RecSelId {}      -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1  -- See Note [Record selection]
      ClassOpId {}     -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
      PrimOpId op :: PrimOp
op      -> PrimOp -> Bool
primOpIsCheap PrimOp
op
      _                -> Bool
False
        -- 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

isExpandableApp :: CheapAppFun
isExpandableApp :: CheapAppFun
isExpandableApp fn :: Id
fn n_val_args :: Int
n_val_args
  | CheapAppFun
isWorkFreeApp Id
fn Int
n_val_args = Bool
True
  | Bool
otherwise
  = case Id -> IdDetails
idDetails Id
fn of
      DataConWorkId {} -> Bool
True  -- Actually handled by isWorkFreeApp
      RecSelId {}      -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1  -- See Note [Record selection]
      ClassOpId {}     -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
      PrimOpId {}      -> Bool
False
      _ | Id -> Bool
isBottomingId Id
fn               -> Bool
False
          -- See Note [isExpandableApp: bottoming functions]
        | RuleMatchInfo -> Bool
isConLike (Id -> RuleMatchInfo
idRuleMatchInfo Id
fn) -> Bool
True
        | Bool
all_args_are_preds             -> Bool
True
        | Bool
otherwise                      -> Bool
False

  where
     -- See if all the arguments are PredTys (implicit params or classes)
     -- If so we'll regard it as expandable; see Note [Expandable overloadings]
     all_args_are_preds :: Bool
all_args_are_preds = Int -> Type -> Bool
forall a. (Eq a, Num a) => a -> Type -> Bool
all_pred_args Int
n_val_args (Id -> Type
idType Id
fn)

     all_pred_args :: a -> Type -> Bool
all_pred_args n_val_args :: a
n_val_args ty :: Type
ty
       | a
n_val_args a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 0
       = Bool
True

       | Just (bndr :: TyCoBinder
bndr, ty :: Type
ty) <- Type -> Maybe (TyCoBinder, Type)
splitPiTy_maybe Type
ty
       = TyCoBinder -> (TyCoVarBinder -> Bool) -> (Type -> Bool) -> Bool
forall a. TyCoBinder -> (TyCoVarBinder -> a) -> (Type -> a) -> a
caseBinder TyCoBinder
bndr
           (\_tv :: TyCoVarBinder
_tv -> a -> Type -> Bool
all_pred_args a
n_val_args Type
ty)
           (\bndr_ty :: Type
bndr_ty -> Type -> Bool
isPredTy Type
bndr_ty Bool -> Bool -> Bool
&& a -> Type -> Bool
all_pred_args (a
n_val_argsa -> a -> a
forall a. Num a => a -> a -> a
-1) Type
ty)

       | Bool
otherwise
       = Bool
False

{- Note [isCheapApp: bottoming functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
I'm not sure why we have a special case for bottoming
functions in isCheapApp.  Maybe we don't need it.

Note [isExpandableApp: bottoming functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's important that isExpandableApp does not respond True to bottoming
functions.  Recall  undefined :: HasCallStack => a
Suppose isExpandableApp responded True to (undefined d), and we had:

  x = undefined <dict-expr>

Then Simplify.prepareRhs would ANF the RHS:

  d = <dict-expr>
  x = undefined d

This is already bad: we gain nothing from having x bound to (undefined
var), unlike the case for data constructors.  Worse, we get the
simplifier loop described in OccurAnal Note [Cascading inlines].
Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will
certainly_inline; so we end up inlining d right back into x; but in
the end x doesn't inline because it is bottom (preInlineUnconditionally);
so the process repeats.. We could elaborate the certainly_inline logic
some more, but it's better just to treat bottoming bindings as
non-expandable, because ANFing them is a bad idea in the first place.

Note [Record selection]
~~~~~~~~~~~~~~~~~~~~~~~~~~
I'm experimenting with making record selection
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)

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.


************************************************************************
*                                                                      *
             exprOkForSpeculation
*                                                                      *
************************************************************************
-}

-----------------------------
-- | 'exprOkForSpeculation' returns True of an expression that is:
--
--  * Safe to evaluate even if normal order eval might not
--    evaluate the expression at all, or
--
--  * Safe /not/ to evaluate even if normal order would do so
--
-- It is usually called on arguments of unlifted type, but not always
-- In particular, Simplify.rebuildCase calls it on lifted types
-- when a 'case' is a plain 'seq'. See the example in
-- Note [exprOkForSpeculation: case expressions] below
--
-- Precisely, it returns @True@ iff:
--  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,
--     divide by zero)
--
-- 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
-- and Note [Transformations affected by can_fail and has_side_effects]
--
-- As an example of the considerations in this test, consider:
--
-- > let x = case y# +# 1# of { r# -> I# r# }
-- > in E
--
-- being translated to:
--
-- > case y# +# 1# of { r# ->
-- >    let x = I# r#
-- >    in E
-- > }
--
-- 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.

exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primOpOkForSpeculation
exprOkForSideEffects :: CoreExpr -> Bool
exprOkForSideEffects = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primOpOkForSideEffects

expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok _ (Lit _)      = Bool
True
expr_ok _ (Type _)     = Bool
True
expr_ok _ (Coercion _) = Bool
True

expr_ok primop_ok :: PrimOp -> Bool
primop_ok (Var v :: Id
v)    = (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok PrimOp -> Bool
primop_ok Id
v []
expr_ok primop_ok :: PrimOp -> Bool
primop_ok (Cast e :: CoreExpr
e _) = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
e
expr_ok primop_ok :: PrimOp -> Bool
primop_ok (Lam b :: Id
b e :: CoreExpr
e)
                 | Id -> Bool
isTyVar Id
b = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok  CoreExpr
e
                 | Bool
otherwise = Bool
True

-- 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.
expr_ok primop_ok :: PrimOp -> Bool
primop_ok (Tick tickish :: Tickish Id
tickish e :: CoreExpr
e)
   | Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishCounts Tickish Id
tickish = Bool
False
   | Bool
otherwise             = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
e

expr_ok _ (Let {}) = Bool
False
  -- Lets can be stacked deeply, so just give up.
  -- In any case, the argument of exprOkForSpeculation is
  -- usually in a strict context, so any lets will have been
  -- floated away.

expr_ok primop_ok :: PrimOp -> Bool
primop_ok (Case scrut :: CoreExpr
scrut bndr :: Id
bndr _ alts :: [CoreAlt]
alts)
  =  -- See Note [exprOkForSpeculation: case expressions]
     (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
scrut
  Bool -> Bool -> Bool
&& HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
bndr)
  Bool -> Bool -> Bool
&& (CoreAlt -> Bool) -> [CoreAlt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(_,_,rhs :: CoreExpr
rhs) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
rhs) [CoreAlt]
alts
  Bool -> Bool -> Bool
&& [CoreAlt] -> Bool
forall b. [Alt b] -> Bool
altsAreExhaustive [CoreAlt]
alts

expr_ok primop_ok :: PrimOp -> Bool
primop_ok other_expr :: CoreExpr
other_expr
  | (expr :: CoreExpr
expr, args :: [CoreExpr]
args) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
other_expr
  = case (Tickish Id -> Bool) -> CoreExpr -> CoreExpr
forall b. (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksTopE (Bool -> Bool
not (Bool -> Bool) -> (Tickish Id -> Bool) -> Tickish Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishCounts) CoreExpr
expr of
        Var f :: Id
f   -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok PrimOp -> Bool
primop_ok Id
f [CoreExpr]
args
        -- 'LitRubbish' is the only literal that can occur in the head of an
        -- application and will not be matched by the above case (Var /= Lit).
        Lit lit :: Literal
lit -> ASSERT( lit == rubbishLit ) True
        _       -> Bool
False

-----------------------------
app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok primop_ok :: PrimOp -> Bool
primop_ok fun :: Id
fun args :: [CoreExpr]
args
  = case Id -> IdDetails
idDetails Id
fun of
      DFunId new_type :: Bool
new_type ->  Bool -> Bool
not Bool
new_type
         -- DFuns terminate, unless the dict is implemented
         -- with a newtype in which case they may not

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

      PrimOpId op :: PrimOp
op
        | PrimOp -> Bool
isDivOp PrimOp
op
        , [arg1 :: CoreExpr
arg1, Lit lit :: Literal
lit] <- [CoreExpr]
args
        -> Bool -> Bool
not (Literal -> Bool
isZeroLit Literal
lit) Bool -> Bool -> Bool
&& (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
arg1
              -- Special case for dividing operations that fail
              -- In general they are NOT ok-for-speculation
              -- (which primop_ok will catch), but they ARE OK
              -- if the divisor is definitely non-zero.
              -- Often there is a literal divisor, and this
              -- can get rid of a thunk in an inner loop

        | PrimOp
SeqOp <- PrimOp
op  -- See Note [exprOkForSpeculation and SeqOp/DataToTagOp]
        -> Bool
False       --     for the special cases for SeqOp and DataToTagOp
        | PrimOp
DataToTagOp <- PrimOp
op
        -> Bool
False

        | Bool
otherwise
        -> PrimOp -> Bool
primop_ok PrimOp
op  -- Check the primop itself
        Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((TyCoBinder -> CoreExpr -> Bool)
-> [TyCoBinder] -> [CoreExpr] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TyCoBinder -> CoreExpr -> Bool
primop_arg_ok [TyCoBinder]
arg_tys [CoreExpr]
args)  -- Check the arguments

      _other :: IdDetails
_other -> HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
fun)          -- c.f. the Var case of exprIsHNF
             Bool -> Bool -> Bool
|| Id -> Int
idArity Id
fun Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n_val_args             -- Partial apps
             -- NB: even in the nullary case, do /not/ check
             --     for evaluated-ness of the fun;
             --     see Note [exprOkForSpeculation and evaluated variables]
             where
               n_val_args :: Int
n_val_args = [CoreExpr] -> Int
forall b. [Arg b] -> Int
valArgCount [CoreExpr]
args
  where
    (arg_tys :: [TyCoBinder]
arg_tys, _) = Type -> ([TyCoBinder], Type)
splitPiTys (Id -> Type
idType Id
fun)

    primop_arg_ok :: TyBinder -> CoreExpr -> Bool
    primop_arg_ok :: TyCoBinder -> CoreExpr -> Bool
primop_arg_ok (Named _) _ = Bool
True   -- A type argument
    primop_arg_ok (Anon ty :: Type
ty) arg :: CoreExpr
arg        -- A term argument
       | HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
ty = (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok PrimOp -> Bool
primop_ok CoreExpr
arg
       | Bool
otherwise         = Bool
True  -- See Note [Primops with lifted arguments]

-----------------------------
altsAreExhaustive :: [Alt b] -> Bool
-- True  <=> the case alternatives are definiely exhaustive
-- False <=> they may or may not be
altsAreExhaustive :: [Alt b] -> Bool
altsAreExhaustive []
  = Bool
False    -- Should not happen
altsAreExhaustive ((con1 :: AltCon
con1,_,_) : alts :: [Alt b]
alts)
  = case AltCon
con1 of
      DEFAULT   -> Bool
True
      LitAlt {} -> Bool
False
      DataAlt c :: DataCon
c -> [Alt b]
alts [Alt b] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` (TyCon -> Int
tyConFamilySize (DataCon -> TyCon
dataConTyCon DataCon
c) Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
      -- 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

-- | True of dyadic operators that can fail only if the second arg is zero!
isDivOp :: PrimOp -> Bool
-- This function probably belongs in PrimOp, or even in
-- an automagically generated file.. but it's such a
-- special case I thought I'd leave it here for now.
isDivOp :: PrimOp -> Bool
isDivOp IntQuotOp        = Bool
True
isDivOp IntRemOp         = Bool
True
isDivOp WordQuotOp       = Bool
True
isDivOp WordRemOp        = Bool
True
isDivOp FloatDivOp       = Bool
True
isDivOp DoubleDivOp      = Bool
True
isDivOp _                = Bool
False

{- Note [exprOkForSpeculation: case expressions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
exprOkForSpeculation accepts very special case expressions.
Reason: (a ==# b) is ok-for-speculation, but the litEq rules
in PrelRules convert it (a ==# 3#) to
   case a of { DEFAULT -> 0#; 3# -> 1# }
for excellent reasons described in
  PrelRules Note [The litEq rule: converting equality to case].
So, annoyingly, we want that case expression to be
ok-for-speculation too. Bother.

But we restrict it sharply:

* We restrict it to unlifted scrutinees. Consider this:
     case x of y {
       DEFAULT -> ... (let v::Int# = case y of { True  -> e1
                                               ; False -> e2 }
                       in ...) ...

  Does the RHS of v satisfy the let/app invariant?  Previously we said
  yes, on the grounds that y is evaluated.  But the binder-swap done
  by SetLevels would transform the inner alternative to
     DEFAULT -> ... (let v::Int# = case x of { ... }
                     in ...) ....
  which does /not/ satisfy the let/app invariant, because x is
  not evaluated. See Note [Binder-swap during float-out]
  in SetLevels.  To avoid this awkwardness it seems simpler
  to stick to unlifted scrutinees where the issue does not
  arise.

* We restrict it to exhaustive alternatives. A non-exhaustive
  case manifestly isn't ok-for-speculation. for example,
  this is a valid program (albeit a slightly dodgy one)
    let v = case x of { B -> ...; C -> ... }
    in case x of
         A -> ...
         _ ->  ...v...v....
  Should v be considered ok-for-speculation?  Its scrutinee may be
  evaluated, but the alternatives are incomplete so we should not
  evaluate it strictly.

  Now, all this is for lifted types, but it'd be the same for any
  finite unlifted type. We don't have many of them, but we might
  add unlifted algebraic types in due course.


----- Historical note: Trac #15696: --------
  Previously SetLevels used exprOkForSpeculation to guide
  floating of single-alternative cases; it now uses exprIsHNF
  Note [Floating single-alternative cases].

  But in those days, consider
    case e of x { DEAFULT ->
      ...(case x of y
            A -> ...
            _ -> ...(case (case x of { B -> p; C -> p }) of
                       I# r -> blah)...
  If SetLevels considers the inner nested case as
  ok-for-speculation it can do case-floating (in SetLevels).
  So we'd float to:
    case e of x { DEAFULT ->
    case (case x of { B -> p; C -> p }) of I# r ->
    ...(case x of y
            A -> ...
            _ -> ...blah...)...
  which is utterly bogus (seg fault); see Trac #5453.

----- Historical note: Trac #3717: --------
    foo :: Int -> Int
    foo 0 = 0
    foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)

In earlier GHCs, we got this:
    T.$wfoo =
      \ (ww :: GHC.Prim.Int#) ->
        case ww of ds {
          __DEFAULT -> case (case <# ds 5 of _ {
                          GHC.Types.False -> lvl1;
                          GHC.Types.True -> lvl})
                       of _ { __DEFAULT ->
                       T.$wfoo (GHC.Prim.-# ds_XkE 1) };
          0 -> 0 }

Before join-points etc we could only get rid of two cases (which are
redundant) by recognising that the (case <# ds 5 of { ... }) is
ok-for-speculation, even though it has /lifted/ type.  But now join
points do the job nicely.
------- End of historical note ------------


Note [Primops with lifted arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Is this ok-for-speculation (see Trac #13027)?
   reallyUnsafePtrEq# a b
Well, yes.  The primop accepts lifted arguments and does not
evaluate them.  Indeed, in general primops are, well, primitive
and do not perform evaluation.

Bottom line:
  * In exprOkForSpeculation we simply ignore all lifted arguments.
  * In the rare case of primops that /do/ evaluate their arguments,
    (namely DataToTagOp and SeqOp) return False; see
    Note [exprOkForSpeculation and evaluated variables]

Note [exprOkForSpeculation and SeqOp/DataToTagOp]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Most primops with lifted arguments don't evaluate them
(see Note [Primops with lifted arguments]), so we can ignore
that argument entirely when doing exprOkForSpeculation.

But DataToTagOp and SeqOp are exceptions to that rule.
For reasons described in Note [exprOkForSpeculation and
evaluated variables], we simply return False for them.

Not doing this made #5129 go bad.
Lots of discussion in #15696.

Note [exprOkForSpeculation and evaluated variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Recall that
  seq#       :: forall a s. a -> State# s -> (# State# s, a #)
  dataToTag# :: forall a.   a -> Int#
must always evaluate their first argument.

Now consider these examples:
 * case x of y { DEFAULT -> ....y.... }
   Should 'y' (alone) be considered ok-for-speculation?

 * case x of y { DEFAULT -> ....f (dataToTag# y)... }
   Should (dataToTag# y) be considered ok-for-spec?

You could argue 'yes', because in the case alternative we know that
'y' is evaluated.  But the binder-swap transformation, which is
extremely useful for float-out, changes these expressions to
   case x of y { DEFAULT -> ....x.... }
   case x of y { DEFAULT -> ....f (dataToTag# x)... }

And now the expression does not obey the let/app invariant!  Yikes!
Moreover we really might float (f (dataToTag# x)) outside the case,
and then it really, really doesn't obey the let/app invariant.

The solution is simple: exprOkForSpeculation does not try to take
advantage of the evaluated-ness of (lifted) variables.  And it returns
False (always) for DataToTagOp and SeqOp.

Note that exprIsHNF /can/ and does take advantage of evaluated-ness;
it doesn't have the trickiness of the let/app invariant to worry about.

************************************************************************
*                                                                      *
             exprIsHNF, exprIsConLike
*                                                                      *
************************************************************************
-}

-- Note [exprIsHNF]             See also Note [exprIsCheap and exprIsHNF]
-- ~~~~~~~~~~~~~~~~
-- | exprIsHNF returns true for expressions that are certainly /already/
-- evaluated to /head/ normal form.  This is used to decide whether it's ok
-- to change:
--
-- > case x of _ -> e
--
--    into:
--
-- > e
--
-- and to decide whether it's safe to discard a 'seq'.
--
-- 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#)
--
-- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't
-- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
-- unboxed type must be ok-for-speculation (or trivial).
exprIsHNF :: CoreExpr -> Bool           -- True => Value-lambda, constructor, PAP
exprIsHNF :: CoreExpr -> Bool
exprIsHNF = (Id -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike Id -> Bool
isDataConWorkId Unfolding -> Bool
isEvaldUnfolding

-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as
-- data constructors. Conlike arguments are considered interesting by the
-- inliner.
exprIsConLike :: CoreExpr -> Bool       -- True => lambda, conlike, PAP
exprIsConLike :: CoreExpr -> Bool
exprIsConLike = (Id -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike Id -> Bool
isConLikeId Unfolding -> Bool
isConLikeUnfolding

-- | 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 :: (Id -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike is_con :: Id -> Bool
is_con is_con_unf :: Unfolding -> Bool
is_con_unf = CoreExpr -> Bool
is_hnf_like
  where
    is_hnf_like :: CoreExpr -> Bool
is_hnf_like (Var v :: Id
v) -- NB: There are no value args at this point
      =  CheapAppFun
id_app_is_value Id
v 0 -- Catches nullary constructors,
                             --      so that [] and () are values, for example
                             -- and (e.g.) primops that don't have unfoldings
      Bool -> Bool -> Bool
|| Unfolding -> Bool
is_con_unf (Id -> Unfolding
idUnfolding Id
v)
        -- Check the thing's unfolding; it might be bound to a value
        --   or to a guaranteed-evaluated variable (isEvaldUnfolding)
        --   Contrast with Note [exprOkForSpeculation and evaluated variables]
        -- 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

    is_hnf_like (Lit _)          = Bool
True
    is_hnf_like (Type _)         = Bool
True       -- Types are honorary Values;
                                              -- we don't mind copying them
    is_hnf_like (Coercion _)     = Bool
True       -- Same for coercions
    is_hnf_like (Lam b :: Id
b e :: CoreExpr
e)        = Id -> Bool
isRuntimeVar Id
b Bool -> Bool -> Bool
|| CoreExpr -> Bool
is_hnf_like CoreExpr
e
    is_hnf_like (Tick tickish :: Tickish Id
tickish e :: CoreExpr
e) = Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishCounts Tickish Id
tickish)
                                   Bool -> Bool -> Bool
&& CoreExpr -> Bool
is_hnf_like CoreExpr
e
                                      -- See Note [exprIsHNF Tick]
    is_hnf_like (Cast e :: CoreExpr
e _)       = CoreExpr -> Bool
is_hnf_like CoreExpr
e
    is_hnf_like (App e :: CoreExpr
e a :: CoreExpr
a)
      | CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg CoreExpr
a               = CoreExpr -> Int -> Bool
app_is_value CoreExpr
e 1
      | Bool
otherwise                = CoreExpr -> Bool
is_hnf_like CoreExpr
e
    is_hnf_like (Let _ e :: CoreExpr
e)        = CoreExpr -> Bool
is_hnf_like CoreExpr
e  -- Lazy let(rec)s don't affect us
    is_hnf_like _                = Bool
False

    -- 'n' is the number of value args to which the expression is applied
    -- And n>0: there is at least one value argument
    app_is_value :: CoreExpr -> Int -> Bool
    app_is_value :: CoreExpr -> Int -> Bool
app_is_value (Var f :: Id
f)    nva :: Int
nva = CheapAppFun
id_app_is_value Id
f Int
nva
    app_is_value (Tick _ f :: CoreExpr
f) nva :: Int
nva = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f Int
nva
    app_is_value (Cast f :: CoreExpr
f _) nva :: Int
nva = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f Int
nva
    app_is_value (App f :: CoreExpr
f a :: CoreExpr
a)  nva :: Int
nva
      | CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg CoreExpr
a              = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f (Int
nva Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
      | Bool
otherwise               = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f Int
nva
    app_is_value _          _   = Bool
False

    id_app_is_value :: CheapAppFun
id_app_is_value id :: Id
id n_val_args :: Int
n_val_args
       = Id -> Bool
is_con Id
id
       Bool -> Bool -> Bool
|| Id -> Int
idArity Id
id Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n_val_args
       Bool -> Bool -> Bool
|| Id
id Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
absentErrorIdKey  -- See Note [aBSENT_ERROR_ID] in MkCore
                      -- absentError behaves like an honorary data constructor


{-
Note [exprIsHNF Tick]

We can discard source annotations on HNFs as long as they aren't
tick-like:

  scc c (\x . e)    =>  \x . e
  scc c (C x1..xn)  =>  C x1..xn

So we regard these as HNFs.  Tick annotations that tick are not
regarded as HNF if the expression they surround is HNF, because the
tick is there to tell us that the expression was evaluated, so we
don't want to discard a seq on it.
-}

-- | Can we bind this 'CoreExpr' at the top level?
exprIsTopLevelBindable :: CoreExpr -> Type -> Bool
-- See Note [CoreSyn top-level string literals]
-- Precondition: exprType expr = ty
-- Top-level literal strings can't even be wrapped in ticks
--   see Note [CoreSyn top-level string literals] in CoreSyn
exprIsTopLevelBindable :: CoreExpr -> Type -> Bool
exprIsTopLevelBindable expr :: CoreExpr
expr ty :: Type
ty
  = Bool -> Bool
not (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
ty)
  Bool -> Bool -> Bool
|| CoreExpr -> Bool
exprIsTickedString CoreExpr
expr

-- | Check if the expression is zero or more Ticks wrapped around a literal
-- string.
exprIsTickedString :: CoreExpr -> Bool
exprIsTickedString :: CoreExpr -> Bool
exprIsTickedString = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool)
-> (CoreExpr -> Maybe ByteString) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Maybe ByteString
exprIsTickedString_maybe

-- | Extract a literal string from an expression that is zero or more Ticks
-- wrapped around a literal string. Returns Nothing if the expression has a
-- different shape.
-- Used to "look through" Ticks in places that need to handle literal strings.
exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString
exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString
exprIsTickedString_maybe (Lit (LitString bs :: ByteString
bs)) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs
exprIsTickedString_maybe (Tick t :: Tickish Id
t e :: CoreExpr
e)
  -- we don't tick literals with CostCentre ticks, compare to mkTick
  | Tickish Id -> TickishPlacement
forall id. Tickish id -> TickishPlacement
tickishPlace Tickish Id
t TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceCostCentre = Maybe ByteString
forall a. Maybe a
Nothing
  | Bool
otherwise = CoreExpr -> Maybe ByteString
exprIsTickedString_maybe CoreExpr
e
exprIsTickedString_maybe _ = Maybe ByteString
forall a. Maybe a
Nothing

{-
************************************************************************
*                                                                      *
             Instantiating data constructors
*                                                                      *
************************************************************************

These InstPat functions go here to avoid circularity between DataCon and Id
-}

dataConRepInstPat   ::                 [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id])
dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id])

dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([Id], [Id])
dataConRepInstPat   = [FastString] -> [Unique] -> DataCon -> [Type] -> ([Id], [Id])
dataConInstPat (FastString -> [FastString]
forall a. a -> [a]
repeat ((String -> FastString
fsLit "ipv")))
dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([Id], [Id])
dataConRepFSInstPat = [FastString] -> [Unique] -> DataCon -> [Type] -> ([Id], [Id])
dataConInstPat

dataConInstPat :: [FastString]          -- A long enough list of FSs to use for names
               -> [Unique]              -- An equally long list of uniques, at least one for each binder
               -> DataCon
               -> [Type]                -- Types to instantiate the universally quantified tyvars
               -> ([TyCoVar], [Id])     -- Return instantiated variables
-- dataConInstPat arg_fun fss us con inst_tys returns a tuple
-- (ex_tvs, arg_ids),
--
--   ex_tvs are intended to be used as binders for existential type args
--
--   arg_ids are indended to be used as binders for value arguments,
--     and their types have been instantiated with inst_tys and ex_tys
--     The arg_ids include both evidence and
--     programmer-specified arguments (both after rep-ing)
--
-- Example.
--  The following constructor T1
--
--  data T a where
--    T1 :: forall b. Int -> b -> T(a,b)
--    ...
--
--  has representation type
--   forall a. forall a1. forall b. (a ~ (a1,b)) =>
--     Int -> b -> T a
--
--  dataConInstPat fss us T1 (a1',b') will return
--
--  ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b''])
--
--  where the double-primed variables are created with the FastStrings and
--  Uniques given as fss and us
dataConInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([Id], [Id])
dataConInstPat fss :: [FastString]
fss uniqs :: [Unique]
uniqs con :: DataCon
con inst_tys :: [Type]
inst_tys
  = ASSERT( univ_tvs `equalLength` inst_tys )
    ([Id]
ex_bndrs, [Id]
arg_ids)
  where
    univ_tvs :: [Id]
univ_tvs = DataCon -> [Id]
dataConUnivTyVars DataCon
con
    ex_tvs :: [Id]
ex_tvs   = DataCon -> [Id]
dataConExTyCoVars DataCon
con
    arg_tys :: [Type]
arg_tys  = DataCon -> [Type]
dataConRepArgTys DataCon
con
    arg_strs :: [StrictnessMark]
arg_strs = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con  -- 1-1 with arg_tys
    n_ex :: Int
n_ex = [Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
ex_tvs

      -- split the Uniques and FastStrings
    (ex_uniqs :: [Unique]
ex_uniqs, id_uniqs :: [Unique]
id_uniqs) = Int -> [Unique] -> ([Unique], [Unique])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_ex [Unique]
uniqs
    (ex_fss :: [FastString]
ex_fss,   id_fss :: [FastString]
id_fss)   = Int -> [FastString] -> ([FastString], [FastString])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_ex [FastString]
fss

      -- Make the instantiating substitution for universals
    univ_subst :: TCvSubst
univ_subst = [Id] -> [Type] -> TCvSubst
HasDebugCallStack => [Id] -> [Type] -> TCvSubst
zipTvSubst [Id]
univ_tvs [Type]
inst_tys

      -- Make existential type variables, applying and extending the substitution
    (full_subst :: TCvSubst
full_subst, ex_bndrs :: [Id]
ex_bndrs) = (TCvSubst -> (Id, FastString, Unique) -> (TCvSubst, Id))
-> TCvSubst -> [(Id, FastString, Unique)] -> (TCvSubst, [Id])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL TCvSubst -> (Id, FastString, Unique) -> (TCvSubst, Id)
mk_ex_var TCvSubst
univ_subst
                                       ([Id] -> [FastString] -> [Unique] -> [(Id, FastString, Unique)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Id]
ex_tvs [FastString]
ex_fss [Unique]
ex_uniqs)

    mk_ex_var :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar)
    mk_ex_var :: TCvSubst -> (Id, FastString, Unique) -> (TCvSubst, Id)
mk_ex_var subst :: TCvSubst
subst (tv :: Id
tv, fs :: FastString
fs, uniq :: Unique
uniq) = (TCvSubst -> Id -> Id -> TCvSubst
Type.extendTCvSubstWithClone TCvSubst
subst Id
tv
                                       Id
new_tv
                                     , Id
new_tv)
      where
        new_tv :: Id
new_tv | Id -> Bool
isTyVar Id
tv
               = Name -> Type -> Id
mkTyVar (Unique -> FastString -> Name
mkSysTvName Unique
uniq FastString
fs) Type
kind
               | Bool
otherwise
               = Name -> Type -> Id
mkCoVar (Unique -> FastString -> Name
mkSystemVarName Unique
uniq FastString
fs) Type
kind
        kind :: Type
kind   = TCvSubst -> Type -> Type
Type.substTyUnchecked TCvSubst
subst (Id -> Type
varType Id
tv)

      -- Make value vars, instantiating types
    arg_ids :: [Id]
arg_ids = (Unique -> FastString -> Type -> StrictnessMark -> Id)
-> [Unique] -> [FastString] -> [Type] -> [StrictnessMark] -> [Id]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 Unique -> FastString -> Type -> StrictnessMark -> Id
mk_id_var [Unique]
id_uniqs [FastString]
id_fss [Type]
arg_tys [StrictnessMark]
arg_strs
    mk_id_var :: Unique -> FastString -> Type -> StrictnessMark -> Id
mk_id_var uniq :: Unique
uniq fs :: FastString
fs ty :: Type
ty str :: StrictnessMark
str
      = StrictnessMark -> Id -> Id
setCaseBndrEvald StrictnessMark
str (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$  -- See Note [Mark evaluated arguments]
        Name -> Type -> Id
mkLocalIdOrCoVar Name
name (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
Type.substTy TCvSubst
full_subst Type
ty)
      where
        name :: Name
name = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq (FastString -> OccName
mkVarOccFS FastString
fs) SrcSpan
noSrcSpan

{-
Note [Mark evaluated arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When pattern matching on a constructor with strict fields, the binder
can have an 'evaldUnfolding'.  Moreover, it *should* have one, so that
when loading an interface file unfolding like:
  data T = MkT !Int
  f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1
                             in ... }
we don't want Lint to complain.  The 'y' is evaluated, so the
case in the RHS of the binding for 'v' is fine.  But only if we
*know* that 'y' is evaluated.

c.f. add_evals in Simplify.simplAlt

************************************************************************
*                                                                      *
         Equality
*                                                                      *
************************************************************************
-}

-- | A cheap equality test which bales out fast!
--      If it returns @True@ the arguments are definitely equal,
--      otherwise, they may or may not be equal.
--
-- See also 'exprIsBig'
cheapEqExpr :: Expr b -> Expr b -> Bool
cheapEqExpr :: Expr b -> Expr b -> Bool
cheapEqExpr = (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
forall b. (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' (Bool -> Tickish Id -> Bool
forall a b. a -> b -> a
const Bool
False)

-- | Cheap expression equality test, can ignore ticks by type.
cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' ignoreTick :: Tickish Id -> Bool
ignoreTick = Expr b -> Expr b -> Bool
forall b. Expr b -> Expr b -> Bool
go_s
  where go_s :: Expr b -> Expr b -> Bool
go_s = Expr b -> Expr b -> Bool
go (Expr b -> Expr b -> Bool)
-> (Expr b -> Expr b) -> Expr b -> Expr b -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Tickish Id -> Bool) -> Expr b -> Expr b
forall b. (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksTopE Tickish Id -> Bool
ignoreTick
        go :: Expr b -> Expr b -> Bool
go (Var v1 :: Id
v1)   (Var v2 :: Id
v2)   = Id
v1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v2
        go (Lit lit1 :: Literal
lit1) (Lit lit2 :: Literal
lit2) = Literal
lit1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit2
        go (Type t1 :: Type
t1)  (Type t2 :: Type
t2)  = Type
t1 Type -> Type -> Bool
`eqType` Type
t2
        go (Coercion c1 :: Coercion
c1) (Coercion c2 :: Coercion
c2) = Coercion
c1 Coercion -> Coercion -> Bool
`eqCoercion` Coercion
c2

        go (App f1 :: Expr b
f1 a1 :: Expr b
a1) (App f2 :: Expr b
f2 a2 :: Expr b
a2)
          = Expr b
f1 Expr b -> Expr b -> Bool
`go_s` Expr b
f2 Bool -> Bool -> Bool
&& Expr b
a1 Expr b -> Expr b -> Bool
`go_s` Expr b
a2

        go (Cast e1 :: Expr b
e1 t1 :: Coercion
t1) (Cast e2 :: Expr b
e2 t2 :: Coercion
t2)
          = Expr b
e1 Expr b -> Expr b -> Bool
`go_s` Expr b
e2 Bool -> Bool -> Bool
&& Coercion
t1 Coercion -> Coercion -> Bool
`eqCoercion` Coercion
t2

        go (Tick t1 :: Tickish Id
t1 e1 :: Expr b
e1) (Tick t2 :: Tickish Id
t2 e2 :: Expr b
e2)
          = Tickish Id
t1 Tickish Id -> Tickish Id -> Bool
forall a. Eq a => a -> a -> Bool
== Tickish Id
t2 Bool -> Bool -> Bool
&& Expr b
e1 Expr b -> Expr b -> Bool
`go_s` Expr b
e2

        go _ _ = Bool
False
        {-# INLINE go #-}
{-# INLINE cheapEqExpr' #-}

exprIsBig :: Expr b -> Bool
-- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'
exprIsBig :: Expr b -> Bool
exprIsBig (Lit _)      = Bool
False
exprIsBig (Var _)      = Bool
False
exprIsBig (Type _)     = Bool
False
exprIsBig (Coercion _) = Bool
False
exprIsBig (Lam _ e :: Expr b
e)    = Expr b -> Bool
forall b. Expr b -> Bool
exprIsBig Expr b
e
exprIsBig (App f :: Expr b
f a :: Expr b
a)    = Expr b -> Bool
forall b. Expr b -> Bool
exprIsBig Expr b
f Bool -> Bool -> Bool
|| Expr b -> Bool
forall b. Expr b -> Bool
exprIsBig Expr b
a
exprIsBig (Cast e :: Expr b
e _)   = Expr b -> Bool
forall b. Expr b -> Bool
exprIsBig Expr b
e    -- Hopefully coercions are not too big!
exprIsBig (Tick _ e :: Expr b
e)   = Expr b -> Bool
forall b. Expr b -> Bool
exprIsBig Expr b
e
exprIsBig _            = Bool
True

eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
-- Compares for equality, modulo alpha
eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
eqExpr in_scope :: InScopeSet
in_scope e1 :: CoreExpr
e1 e2 :: CoreExpr
e2
  = RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go (InScopeSet -> RnEnv2
mkRnEnv2 InScopeSet
in_scope) CoreExpr
e1 CoreExpr
e2
  where
    go :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go env :: RnEnv2
env (Var v1 :: Id
v1) (Var v2 :: Id
v2)
      | RnEnv2 -> Id -> Id
rnOccL RnEnv2
env Id
v1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== RnEnv2 -> Id -> Id
rnOccR RnEnv2
env Id
v2
      = Bool
True

    go _   (Lit lit1 :: Literal
lit1)    (Lit lit2 :: Literal
lit2)      = Literal
lit1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit2
    go env :: RnEnv2
env (Type t1 :: Type
t1)    (Type t2 :: Type
t2)        = RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
    go env :: RnEnv2
env (Coercion co1 :: Coercion
co1) (Coercion co2 :: Coercion
co2) = RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env Coercion
co1 Coercion
co2
    go env :: RnEnv2
env (Cast e1 :: CoreExpr
e1 co1 :: Coercion
co1) (Cast e2 :: CoreExpr
e2 co2 :: Coercion
co2) = RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env Coercion
co1 Coercion
co2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
e1 CoreExpr
e2
    go env :: RnEnv2
env (App f1 :: CoreExpr
f1 a1 :: CoreExpr
a1)   (App f2 :: CoreExpr
f2 a2 :: CoreExpr
a2)   = RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
f1 CoreExpr
f2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
a1 CoreExpr
a2
    go env :: RnEnv2
env (Tick n1 :: Tickish Id
n1 e1 :: CoreExpr
e1)  (Tick n2 :: Tickish Id
n2 e2 :: CoreExpr
e2)  = RnEnv2 -> Tickish Id -> Tickish Id -> Bool
eqTickish RnEnv2
env Tickish Id
n1 Tickish Id
n2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
e1 CoreExpr
e2

    go env :: RnEnv2
env (Lam b1 :: Id
b1 e1 :: CoreExpr
e1)  (Lam b2 :: Id
b2 e2 :: CoreExpr
e2)
      =  RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env (Id -> Type
varType Id
b1) (Id -> Type
varType Id
b2)   -- False for Id/TyVar combination
      Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go (RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
b1 Id
b2) CoreExpr
e1 CoreExpr
e2

    go env :: RnEnv2
env (Let (NonRec v1 :: Id
v1 r1 :: CoreExpr
r1) e1 :: CoreExpr
e1) (Let (NonRec v2 :: Id
v2 r2 :: CoreExpr
r2) e2 :: CoreExpr
e2)
      =  RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
r1 CoreExpr
r2  -- No need to check binder types, since RHSs match
      Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go (RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
v1 Id
v2) CoreExpr
e1 CoreExpr
e2

    go env :: RnEnv2
env (Let (Rec ps1 :: [(Id, CoreExpr)]
ps1) e1 :: CoreExpr
e1) (Let (Rec ps2 :: [(Id, CoreExpr)]
ps2) e2 :: CoreExpr
e2)
      = [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [(Id, CoreExpr)]
ps1 [(Id, CoreExpr)]
ps2
      Bool -> Bool -> Bool
&& (CoreExpr -> CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
all2 (RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env') [CoreExpr]
rs1 [CoreExpr]
rs2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env' CoreExpr
e1 CoreExpr
e2
      where
        (bs1 :: [Id]
bs1,rs1 :: [CoreExpr]
rs1) = [(Id, CoreExpr)] -> ([Id], [CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CoreExpr)]
ps1
        (bs2 :: [Id]
bs2,rs2 :: [CoreExpr]
rs2) = [(Id, CoreExpr)] -> ([Id], [CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CoreExpr)]
ps2
        env' :: RnEnv2
env' = RnEnv2 -> [Id] -> [Id] -> RnEnv2
rnBndrs2 RnEnv2
env [Id]
bs1 [Id]
bs2

    go env :: RnEnv2
env (Case e1 :: CoreExpr
e1 b1 :: Id
b1 t1 :: Type
t1 a1 :: [CoreAlt]
a1) (Case e2 :: CoreExpr
e2 b2 :: Id
b2 t2 :: Type
t2 a2 :: [CoreAlt]
a2)
      | [CoreAlt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreAlt]
a1   -- See Note [Empty case alternatives] in TrieMap
      = [CoreAlt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreAlt]
a2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
e1 CoreExpr
e2 Bool -> Bool -> Bool
&& RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
      | Bool
otherwise
      =  RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go RnEnv2
env CoreExpr
e1 CoreExpr
e2 Bool -> Bool -> Bool
&& (CoreAlt -> CoreAlt -> Bool) -> [CoreAlt] -> [CoreAlt] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
all2 (RnEnv2 -> CoreAlt -> CoreAlt -> Bool
go_alt (RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
b1 Id
b2)) [CoreAlt]
a1 [CoreAlt]
a2

    go _ _ _ = Bool
False

    -----------
    go_alt :: RnEnv2 -> CoreAlt -> CoreAlt -> Bool
go_alt env :: RnEnv2
env (c1 :: AltCon
c1, bs1 :: [Id]
bs1, e1 :: CoreExpr
e1) (c2 :: AltCon
c2, bs2 :: [Id]
bs2, e2 :: CoreExpr
e2)
      = AltCon
c1 AltCon -> AltCon -> Bool
forall a. Eq a => a -> a -> Bool
== AltCon
c2 Bool -> Bool -> Bool
&& RnEnv2 -> CoreExpr -> CoreExpr -> Bool
go (RnEnv2 -> [Id] -> [Id] -> RnEnv2
rnBndrs2 RnEnv2
env [Id]
bs1 [Id]
bs2) CoreExpr
e1 CoreExpr
e2

eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool
eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool
eqTickish env :: RnEnv2
env (Breakpoint lid :: Int
lid lids :: [Id]
lids) (Breakpoint rid :: Int
rid rids :: [Id]
rids)
      = Int
lid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rid  Bool -> Bool -> Bool
&&  (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (RnEnv2 -> Id -> Id
rnOccL RnEnv2
env) [Id]
lids [Id] -> [Id] -> Bool
forall a. Eq a => a -> a -> Bool
== (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (RnEnv2 -> Id -> Id
rnOccR RnEnv2
env) [Id]
rids
eqTickish _ l :: Tickish Id
l r :: Tickish Id
r = Tickish Id
l Tickish Id -> Tickish Id -> Bool
forall a. Eq a => a -> a -> Bool
== Tickish Id
r

-- | Finds differences between core expressions, modulo alpha and
-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be
-- checked for differences as well.
diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr _   env :: RnEnv2
env (Var v1 :: Id
v1)   (Var v2 :: Id
v2)   | RnEnv2 -> Id -> Id
rnOccL RnEnv2
env Id
v1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== RnEnv2 -> Id -> Id
rnOccR RnEnv2
env Id
v2 = []
diffExpr _   _   (Lit lit1 :: Literal
lit1) (Lit lit2 :: Literal
lit2) | Literal
lit1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit2                   = []
diffExpr _   env :: RnEnv2
env (Type t1 :: Type
t1)  (Type t2 :: Type
t2)  | RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2              = []
diffExpr _   env :: RnEnv2
env (Coercion co1 :: Coercion
co1) (Coercion co2 :: Coercion
co2)
                                       | RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env Coercion
co1 Coercion
co2        = []
diffExpr top :: Bool
top env :: RnEnv2
env (Cast e1 :: CoreExpr
e1 co1 :: Coercion
co1)  (Cast e2 :: CoreExpr
e2 co2 :: Coercion
co2)
  | RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env Coercion
co1 Coercion
co2                = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2
diffExpr top :: Bool
top env :: RnEnv2
env (Tick n1 :: Tickish Id
n1 e1 :: CoreExpr
e1)   e2 :: CoreExpr
e2
  | Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
n1)                 = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2
diffExpr top :: Bool
top env :: RnEnv2
env e1 :: CoreExpr
e1             (Tick n2 :: Tickish Id
n2 e2 :: CoreExpr
e2)
  | Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
n2)                 = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2
diffExpr top :: Bool
top env :: RnEnv2
env (Tick n1 :: Tickish Id
n1 e1 :: CoreExpr
e1)   (Tick n2 :: Tickish Id
n2 e2 :: CoreExpr
e2)
  | RnEnv2 -> Tickish Id -> Tickish Id -> Bool
eqTickish RnEnv2
env Tickish Id
n1 Tickish Id
n2                    = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2
 -- The error message of failed pattern matches will contain
 -- generated names, which are allowed to differ.
diffExpr _   _   (App (App (Var absent :: Id
absent) _) _)
                 (App (App (Var absent2 :: Id
absent2) _) _)
  | Id -> Bool
isBottomingId Id
absent Bool -> Bool -> Bool
&& Id -> Bool
isBottomingId Id
absent2 = []
diffExpr top :: Bool
top env :: RnEnv2
env (App f1 :: CoreExpr
f1 a1 :: CoreExpr
a1)    (App f2 :: CoreExpr
f2 a2 :: CoreExpr
a2)
  = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
f1 CoreExpr
f2 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
a1 CoreExpr
a2
diffExpr top :: Bool
top env :: RnEnv2
env (Lam b1 :: Id
b1 e1 :: CoreExpr
e1)  (Lam b2 :: Id
b2 e2 :: CoreExpr
e2)
  | RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env (Id -> Type
varType Id
b1) (Id -> Type
varType Id
b2)   -- False for Id/TyVar combination
  = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top (RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
b1 Id
b2) CoreExpr
e1 CoreExpr
e2
diffExpr top :: Bool
top env :: RnEnv2
env (Let bs1 :: Bind Id
bs1 e1 :: CoreExpr
e1) (Let bs2 :: Bind Id
bs2 e2 :: CoreExpr
e2)
  = let (ds :: [SDoc]
ds, env' :: RnEnv2
env') = Bool
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
diffBinds Bool
top RnEnv2
env ([Bind Id] -> [(Id, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds [Bind Id
bs1]) ([Bind Id] -> [(Id, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds [Bind Id
bs2])
    in [SDoc]
ds [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env' CoreExpr
e1 CoreExpr
e2
diffExpr top :: Bool
top env :: RnEnv2
env (Case e1 :: CoreExpr
e1 b1 :: Id
b1 t1 :: Type
t1 a1 :: [CoreAlt]
a1) (Case e2 :: CoreExpr
e2 b2 :: Id
b2 t2 :: Type
t2 a2 :: [CoreAlt]
a2)
  | [CoreAlt] -> [CoreAlt] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [CoreAlt]
a1 [CoreAlt]
a2 Bool -> Bool -> Bool
&& Bool -> Bool
not ([CoreAlt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreAlt]
a1) Bool -> Bool -> Bool
|| RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
    -- See Note [Empty case alternatives] in TrieMap
  = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [[SDoc]] -> [SDoc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((CoreAlt -> CoreAlt -> [SDoc])
-> [CoreAlt] -> [CoreAlt] -> [[SDoc]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith CoreAlt -> CoreAlt -> [SDoc]
forall a.
(Eq a, Outputable a) =>
(a, [Id], CoreExpr) -> (a, [Id], CoreExpr) -> [SDoc]
diffAlt [CoreAlt]
a1 [CoreAlt]
a2)
  where env' :: RnEnv2
env' = RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
b1 Id
b2
        diffAlt :: (a, [Id], CoreExpr) -> (a, [Id], CoreExpr) -> [SDoc]
diffAlt (c1 :: a
c1, bs1 :: [Id]
bs1, e1 :: CoreExpr
e1) (c2 :: a
c2, bs2 :: [Id]
bs2, e2 :: CoreExpr
e2)
          | a
c1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
c2  = [String -> SDoc
text "alt-cons " SDoc -> SDoc -> SDoc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
c1 SDoc -> SDoc -> SDoc
<> String -> SDoc
text " /= " SDoc -> SDoc -> SDoc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
c2]
          | Bool
otherwise = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top (RnEnv2 -> [Id] -> [Id] -> RnEnv2
rnBndrs2 RnEnv2
env' [Id]
bs1 [Id]
bs2) CoreExpr
e1 CoreExpr
e2
diffExpr _  _ e1 :: CoreExpr
e1 e2 :: CoreExpr
e2
  = [[SDoc] -> SDoc
fsep [CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e1, String -> SDoc
text "/=", CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e2]]

-- | Finds differences between core bindings, see @diffExpr@.
--
-- The main problem here is that while we expect the binds to have the
-- same order in both lists, this is not guaranteed. To do this
-- properly we'd either have to do some sort of unification or check
-- all possible mappings, which would be seriously expensive. So
-- instead we simply match single bindings as far as we can. This
-- leaves us just with mutually recursive and/or mismatching bindings,
-- which we then speculatively match by ordering them. It's by no means
-- perfect, but gets the job done well enough.
diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
          -> ([SDoc], RnEnv2)
diffBinds :: Bool
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
diffBinds top :: Bool
top env :: RnEnv2
env binds1 :: [(Id, CoreExpr)]
binds1 = Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go ([(Id, CoreExpr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds1) RnEnv2
env [(Id, CoreExpr)]
binds1
 where go :: Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go _    env :: RnEnv2
env []     []
          = ([], RnEnv2
env)
       go fuel :: Int
fuel env :: RnEnv2
env binds1 :: [(Id, CoreExpr)]
binds1 binds2 :: [(Id, CoreExpr)]
binds2
          -- No binds left to compare? Bail out early.
          | [(Id, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Id, CoreExpr)]
binds1 Bool -> Bool -> Bool
|| [(Id, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Id, CoreExpr)]
binds2
          = (RnEnv2 -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [SDoc]
warn RnEnv2
env [(Id, CoreExpr)]
binds1 [(Id, CoreExpr)]
binds2, RnEnv2
env)
          -- Iterated over all binds without finding a match? Then
          -- try speculatively matching binders by order.
          | Int
fuel Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
          = if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RnEnv2
env RnEnv2 -> Id -> Bool
`inRnEnvL` (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst ([(Id, CoreExpr)] -> (Id, CoreExpr)
forall a. [a] -> a
head [(Id, CoreExpr)]
binds1)
            then let env' :: RnEnv2
env' = ([Id] -> [Id] -> RnEnv2) -> ([Id], [Id]) -> RnEnv2
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (RnEnv2 -> [Id] -> [Id] -> RnEnv2
rnBndrs2 RnEnv2
env) (([Id], [Id]) -> RnEnv2) -> ([Id], [Id]) -> RnEnv2
forall a b. (a -> b) -> a -> b
$ [(Id, Id)] -> ([Id], [Id])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Id, Id)] -> ([Id], [Id])) -> [(Id, Id)] -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$
                            [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Id] -> [Id]
forall a. Ord a => [a] -> [a]
sort ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ ((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
binds1) ([Id] -> [Id]
forall a. Ord a => [a] -> [a]
sort ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ ((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
binds2)
                 in Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go ([(Id, CoreExpr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds1) RnEnv2
env' [(Id, CoreExpr)]
binds1 [(Id, CoreExpr)]
binds2
            -- If we have already tried that, give up
            else (RnEnv2 -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [SDoc]
warn RnEnv2
env [(Id, CoreExpr)]
binds1 [(Id, CoreExpr)]
binds2, RnEnv2
env)
       go fuel :: Int
fuel env :: RnEnv2
env ((bndr1 :: Id
bndr1,expr1 :: CoreExpr
expr1):binds1 :: [(Id, CoreExpr)]
binds1) binds2 :: [(Id, CoreExpr)]
binds2
          | let matchExpr :: (Id, CoreExpr) -> Bool
matchExpr (bndr :: Id
bndr,expr :: CoreExpr
expr) =
                  (Bool -> Bool
not Bool
top Bool -> Bool -> Bool
|| [SDoc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RnEnv2 -> Id -> Id -> [SDoc]
diffIdInfo RnEnv2
env Id
bndr Id
bndr1)) Bool -> Bool -> Bool
&&
                  [SDoc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top (RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
bndr1 Id
bndr) CoreExpr
expr1 CoreExpr
expr)
          , (binds2l :: [(Id, CoreExpr)]
binds2l, (bndr2 :: Id
bndr2,_):binds2r :: [(Id, CoreExpr)]
binds2r) <- ((Id, CoreExpr) -> Bool)
-> [(Id, CoreExpr)] -> ([(Id, CoreExpr)], [(Id, CoreExpr)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Id, CoreExpr) -> Bool
matchExpr [(Id, CoreExpr)]
binds2
          = Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go ([(Id, CoreExpr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds1) (RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
bndr1 Id
bndr2)
                [(Id, CoreExpr)]
binds1 ([(Id, CoreExpr)]
binds2l [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(Id, CoreExpr)]
binds2r)
          | Bool
otherwise -- No match, so push back (FIXME O(n^2))
          = Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go (Int
fuelInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) RnEnv2
env ([(Id, CoreExpr)]
binds1[(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++[(Id
bndr1,CoreExpr
expr1)]) [(Id, CoreExpr)]
binds2
       go _ _ _ _ = String -> ([SDoc], RnEnv2)
forall a. String -> a
panic "diffBinds: impossible" -- GHC isn't smart enough

       -- We have tried everything, but couldn't find a good match. So
       -- now we just return the comparison results when we pair up
       -- the binds in a pseudo-random order.
       warn :: RnEnv2 -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [SDoc]
warn env :: RnEnv2
env binds1 :: [(Id, CoreExpr)]
binds1 binds2 :: [(Id, CoreExpr)]
binds2 =
         (((Id, CoreExpr), (Id, CoreExpr)) -> [SDoc])
-> [((Id, CoreExpr), (Id, CoreExpr))] -> [SDoc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Id, CoreExpr) -> (Id, CoreExpr) -> [SDoc])
-> ((Id, CoreExpr), (Id, CoreExpr)) -> [SDoc]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (RnEnv2 -> (Id, CoreExpr) -> (Id, CoreExpr) -> [SDoc]
diffBind RnEnv2
env)) ([(Id, CoreExpr)]
-> [(Id, CoreExpr)] -> [((Id, CoreExpr), (Id, CoreExpr))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Id, CoreExpr)]
binds1' [(Id, CoreExpr)]
binds2') [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
         String -> [(Id, CoreExpr)] -> [SDoc]
forall b. OutputableBndr b => String -> [(b, Expr b)] -> [SDoc]
unmatched "unmatched left-hand:" (Int -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. Int -> [a] -> [a]
drop Int
l [(Id, CoreExpr)]
binds1') [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
         String -> [(Id, CoreExpr)] -> [SDoc]
forall b. OutputableBndr b => String -> [(b, Expr b)] -> [SDoc]
unmatched "unmatched right-hand:" (Int -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. Int -> [a] -> [a]
drop Int
l [(Id, CoreExpr)]
binds2')
        where binds1' :: [(Id, CoreExpr)]
binds1' = ((Id, CoreExpr) -> (Id, CoreExpr) -> Ordering)
-> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Id, CoreExpr) -> Id)
-> (Id, CoreExpr) -> (Id, CoreExpr) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) [(Id, CoreExpr)]
binds1
              binds2' :: [(Id, CoreExpr)]
binds2' = ((Id, CoreExpr) -> (Id, CoreExpr) -> Ordering)
-> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Id, CoreExpr) -> Id)
-> (Id, CoreExpr) -> (Id, CoreExpr) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) [(Id, CoreExpr)]
binds2
              l :: Int
l = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ([(Id, CoreExpr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds1') ([(Id, CoreExpr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds2')
       unmatched :: String -> [(b, Expr b)] -> [SDoc]
unmatched _   [] = []
       unmatched txt :: String
txt bs :: [(b, Expr b)]
bs = [String -> SDoc
text String
txt SDoc -> SDoc -> SDoc
$$ Bind b -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([(b, Expr b)] -> Bind b
forall b. [(b, Expr b)] -> Bind b
Rec [(b, Expr b)]
bs)]
       diffBind :: RnEnv2 -> (Id, CoreExpr) -> (Id, CoreExpr) -> [SDoc]
diffBind env :: RnEnv2
env (bndr1 :: Id
bndr1,expr1 :: CoreExpr
expr1) (bndr2 :: Id
bndr2,expr2 :: CoreExpr
expr2)
         | ds :: [SDoc]
ds@(_:_) <- Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
expr1 CoreExpr
expr2
         = String -> Id -> Id -> [SDoc] -> [SDoc]
locBind "in binding" Id
bndr1 Id
bndr2 [SDoc]
ds
         | Bool
otherwise
         = RnEnv2 -> Id -> Id -> [SDoc]
diffIdInfo RnEnv2
env Id
bndr1 Id
bndr2

-- | Find differences in @IdInfo@. We will especially check whether
-- the unfoldings match, if present (see @diffUnfold@).
diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]
diffIdInfo :: RnEnv2 -> Id -> Id -> [SDoc]
diffIdInfo env :: RnEnv2
env bndr1 :: Id
bndr1 bndr2 :: Id
bndr2
  | IdInfo -> Int
arityInfo IdInfo
info1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> Int
arityInfo IdInfo
info2
    Bool -> Bool -> Bool
&& IdInfo -> CafInfo
cafInfo IdInfo
info1 CafInfo -> CafInfo -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> CafInfo
cafInfo IdInfo
info2
    Bool -> Bool -> Bool
&& IdInfo -> OneShotInfo
oneShotInfo IdInfo
info1 OneShotInfo -> OneShotInfo -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> OneShotInfo
oneShotInfo IdInfo
info2
    Bool -> Bool -> Bool
&& IdInfo -> InlinePragma
inlinePragInfo IdInfo
info1 InlinePragma -> InlinePragma -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> InlinePragma
inlinePragInfo IdInfo
info2
    Bool -> Bool -> Bool
&& IdInfo -> OccInfo
occInfo IdInfo
info1 OccInfo -> OccInfo -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> OccInfo
occInfo IdInfo
info2
    Bool -> Bool -> Bool
&& IdInfo -> Demand
demandInfo IdInfo
info1 Demand -> Demand -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> Demand
demandInfo IdInfo
info2
    Bool -> Bool -> Bool
&& IdInfo -> Int
callArityInfo IdInfo
info1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> Int
callArityInfo IdInfo
info2
    Bool -> Bool -> Bool
&& IdInfo -> LevityInfo
levityInfo IdInfo
info1 LevityInfo -> LevityInfo -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> LevityInfo
levityInfo IdInfo
info2
  = String -> Id -> Id -> [SDoc] -> [SDoc]
locBind "in unfolding of" Id
bndr1 Id
bndr2 ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
    RnEnv2 -> Unfolding -> Unfolding -> [SDoc]
diffUnfold RnEnv2
env (IdInfo -> Unfolding
unfoldingInfo IdInfo
info1) (IdInfo -> Unfolding
unfoldingInfo IdInfo
info2)
  | Bool
otherwise
  = String -> Id -> Id -> [SDoc] -> [SDoc]
locBind "in Id info of" Id
bndr1 Id
bndr2
    [[SDoc] -> SDoc
fsep [BindingSite -> Id -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Id
bndr1, String -> SDoc
text "/=", BindingSite -> Id -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Id
bndr2]]
  where info1 :: IdInfo
info1 = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
bndr1; info2 :: IdInfo
info2 = HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
bndr2

-- | Find differences in unfoldings. Note that we will not check for
-- differences of @IdInfo@ in unfoldings, as this is generally
-- redundant, and can lead to an exponential blow-up in complexity.
diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]
diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]
diffUnfold _   NoUnfolding    NoUnfolding                 = []
diffUnfold _   BootUnfolding  BootUnfolding               = []
diffUnfold _   (OtherCon cs1 :: [AltCon]
cs1) (OtherCon cs2 :: [AltCon]
cs2) | [AltCon]
cs1 [AltCon] -> [AltCon] -> Bool
forall a. Eq a => a -> a -> Bool
== [AltCon]
cs2 = []
diffUnfold env :: RnEnv2
env (DFunUnfolding bs1 :: [Id]
bs1 c1 :: DataCon
c1 a1 :: [CoreExpr]
a1)
               (DFunUnfolding bs2 :: [Id]
bs2 c2 :: DataCon
c2 a2 :: [CoreExpr]
a2)
  | DataCon
c1 DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
c2 Bool -> Bool -> Bool
&& [Id] -> [Id] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Id]
bs1 [Id]
bs2
  = ((CoreExpr, CoreExpr) -> [SDoc])
-> [(CoreExpr, CoreExpr)] -> [SDoc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((CoreExpr -> CoreExpr -> [SDoc]) -> (CoreExpr, CoreExpr) -> [SDoc]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
False RnEnv2
env')) ([CoreExpr] -> [CoreExpr] -> [(CoreExpr, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CoreExpr]
a1 [CoreExpr]
a2)
  where env' :: RnEnv2
env' = RnEnv2 -> [Id] -> [Id] -> RnEnv2
rnBndrs2 RnEnv2
env [Id]
bs1 [Id]
bs2
diffUnfold env :: RnEnv2
env (CoreUnfolding t1 :: CoreExpr
t1 _ _ v1 :: Bool
v1 cl1 :: Bool
cl1 wf1 :: Bool
wf1 x1 :: Bool
x1 g1 :: UnfoldingGuidance
g1)
               (CoreUnfolding t2 :: CoreExpr
t2 _ _ v2 :: Bool
v2 cl2 :: Bool
cl2 wf2 :: Bool
wf2 x2 :: Bool
x2 g2 :: UnfoldingGuidance
g2)
  | Bool
v1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
v2 Bool -> Bool -> Bool
&& Bool
cl1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
cl2
    Bool -> Bool -> Bool
&& Bool
wf1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
wf2 Bool -> Bool -> Bool
&& Bool
x1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
x2 Bool -> Bool -> Bool
&& UnfoldingGuidance
g1 UnfoldingGuidance -> UnfoldingGuidance -> Bool
forall a. Eq a => a -> a -> Bool
== UnfoldingGuidance
g2
  = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
False RnEnv2
env CoreExpr
t1 CoreExpr
t2
diffUnfold _   uf1 :: Unfolding
uf1 uf2 :: Unfolding
uf2
  = [[SDoc] -> SDoc
fsep [Unfolding -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unfolding
uf1, String -> SDoc
text "/=", Unfolding -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unfolding
uf2]]

-- | Add location information to diff messages
locBind :: String -> Var -> Var -> [SDoc] -> [SDoc]
locBind :: String -> Id -> Id -> [SDoc] -> [SDoc]
locBind loc :: String
loc b1 :: Id
b1 b2 :: Id
b2 diffs :: [SDoc]
diffs = (SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map SDoc -> SDoc
addLoc [SDoc]
diffs
  where addLoc :: SDoc -> SDoc
addLoc d :: SDoc
d            = SDoc
d SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc
parens (String -> SDoc
text String
loc SDoc -> SDoc -> SDoc
<+> SDoc
bindLoc))
        bindLoc :: SDoc
bindLoc | Id
b1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
b2  = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b1
                | Bool
otherwise = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b1 SDoc -> SDoc -> SDoc
<> Char -> SDoc
char '/' SDoc -> SDoc -> SDoc
<> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b2

{-
************************************************************************
*                                                                      *
                Eta reduction
*                                                                      *
************************************************************************

Note [Eta reduction conditions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We try for eta reduction here, but *only* if we get all the way to an
trivial expression.  We don't want to remove extra lambdas unless we
are going to avoid allocating this thing altogether.

There are some particularly delicate points here:

* We want to eta-reduce if doing so leaves a trivial expression,
  *including* a cast.  For example
       \x. f |> co  -->  f |> co
  (provided co doesn't mention x)

* Eta reduction is not valid in general:
        \x. bot  /=  bot
  This matters, partly for old-fashioned correctness reasons but,
  worse, getting it wrong can yield a seg fault. Consider
        f = \x.f x
        h y = case (case y of { True -> f `seq` True; False -> False }) of
                True -> ...; False -> ...

  If we (unsoundly) eta-reduce f to get f=f, the strictness analyser
  says f=bottom, and replaces the (f `seq` True) with just
  (f `cast` unsafe-co).  BUT, as thing stand, 'f' got arity 1, and it
  *keeps* arity 1 (perhaps also wrongly).  So CorePrep eta-expands
  the definition again, so that it does not termninate after all.
  Result: seg-fault because the boolean case actually gets a function value.
  See Trac #1947.

  So it's important to do the right thing.

* Note [Arity care]: we need to be careful if we just look at f's
  arity. Currently (Dec07), f's arity is visible in its own RHS (see
  Note [Arity robustness] in SimplEnv) so we must *not* trust the
  arity when checking that 'f' is a value.  Otherwise we will
  eta-reduce
      f = \x. f x
  to
      f = f
  Which might change a terminating program (think (f `seq` e)) to a
  non-terminating one.  So we check for being a loop breaker first.

  However for GlobalIds we can look at the arity; and for primops we
  must, since they have no unfolding.

* Regardless of whether 'f' is a value, we always want to
  reduce (/\a -> f a) to f
  This came up in a RULE: foldr (build (/\a -> g a))
  did not match           foldr (build (/\b -> ...something complex...))
  The type checker can insert these eta-expanded versions,
  with both type and dictionary lambdas; hence the slightly
  ad-hoc isDictId

* Never *reduce* arity. For example
      f = \xy. g x y
  Then if h has arity 1 we don't want to eta-reduce because then
  f's arity would decrease, and that is bad

These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
Alas.

Note [Eta reduction with casted arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
    (\(x:t3). f (x |> g)) :: t3 -> t2
  where
    f :: t1 -> t2
    g :: t3 ~ t1
This should be eta-reduced to

    f |> (sym g -> t2)

So we need to accumulate a coercion, pushing it inward (past
variable arguments only) thus:
   f (x |> co_arg) |> co  -->  (f |> (sym co_arg -> co)) x
   f (x:t)         |> co  -->  (f |> (t -> co)) x
   f @ a           |> co  -->  (f |> (forall a.co)) @ a
   f @ (g:t1~t2)   |> co  -->  (f |> (t1~t2 => co)) @ (g:t1~t2)
These are the equations for ok_arg.

It's true that we could also hope to eta reduce these:
    (\xy. (f x |> g) y)
    (\xy. (f x y) |> g)
But the simplifier pushes those casts outwards, so we don't
need to address that here.
-}

tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
tryEtaReduce :: [Id] -> CoreExpr -> Maybe CoreExpr
tryEtaReduce bndrs :: [Id]
bndrs body :: CoreExpr
body
  = [Id] -> CoreExpr -> Coercion -> Maybe CoreExpr
go ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bndrs) CoreExpr
body (Type -> Coercion
mkRepReflCo (CoreExpr -> Type
exprType CoreExpr
body))
  where
    incoming_arity :: Int
incoming_arity = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
bndrs

    go :: [Var]            -- Binders, innermost first, types [a3,a2,a1]
       -> CoreExpr         -- Of type tr
       -> Coercion         -- Of type tr ~ ts
       -> Maybe CoreExpr   -- Of type a1 -> a2 -> a3 -> ts
    -- See Note [Eta reduction with casted arguments]
    -- for why we have an accumulating coercion
    go :: [Id] -> CoreExpr -> Coercion -> Maybe CoreExpr
go [] fun :: CoreExpr
fun co :: Coercion
co
      | CoreExpr -> Bool
forall b. Expr b -> Bool
ok_fun CoreExpr
fun
      , let used_vars :: VarSet
used_vars = CoreExpr -> VarSet
exprFreeVars CoreExpr
fun VarSet -> VarSet -> VarSet
`unionVarSet` Coercion -> VarSet
tyCoVarsOfCo Coercion
co
      , Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> VarSet -> Bool
`elemVarSet` VarSet
used_vars) [Id]
bndrs)
      = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
fun Coercion
co)   -- Check for any of the binders free in the result
                               -- including the accumulated coercion

    go bs :: [Id]
bs (Tick t :: Tickish Id
t e :: CoreExpr
e) co :: Coercion
co
      | Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable Tickish Id
t
      = (CoreExpr -> CoreExpr) -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t) (Maybe CoreExpr -> Maybe CoreExpr)
-> Maybe CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [Id] -> CoreExpr -> Coercion -> Maybe CoreExpr
go [Id]
bs CoreExpr
e Coercion
co
      -- Float app ticks: \x -> Tick t (e x) ==> Tick t e

    go (b :: Id
b : bs :: [Id]
bs) (App fun :: CoreExpr
fun arg :: CoreExpr
arg) co :: Coercion
co
      | Just (co' :: Coercion
co', ticks :: [Tickish Id]
ticks) <- Id -> CoreExpr -> Coercion -> Maybe (Coercion, [Tickish Id])
ok_arg Id
b CoreExpr
arg Coercion
co
      = (CoreExpr -> CoreExpr) -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> [Tickish Id] -> CoreExpr)
-> [Tickish Id] -> CoreExpr -> CoreExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Tickish Id -> CoreExpr -> CoreExpr)
-> CoreExpr -> [Tickish Id] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tickish Id -> CoreExpr -> CoreExpr
mkTick) [Tickish Id]
ticks) (Maybe CoreExpr -> Maybe CoreExpr)
-> Maybe CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ [Id] -> CoreExpr -> Coercion -> Maybe CoreExpr
go [Id]
bs CoreExpr
fun Coercion
co'
            -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e

    go _ _ _  = Maybe CoreExpr
forall a. Maybe a
Nothing         -- Failure!

    ---------------
    -- Note [Eta reduction conditions]
    ok_fun :: Expr b -> Bool
ok_fun (App fun :: Expr b
fun (Type {})) = Expr b -> Bool
ok_fun Expr b
fun
    ok_fun (Cast fun :: Expr b
fun _)        = Expr b -> Bool
ok_fun Expr b
fun
    ok_fun (Tick _ expr :: Expr b
expr)       = Expr b -> Bool
ok_fun Expr b
expr
    ok_fun (Var fun_id :: Id
fun_id)        = Id -> Bool
ok_fun_id Id
fun_id Bool -> Bool -> Bool
|| (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
ok_lam [Id]
bndrs
    ok_fun _fun :: Expr b
_fun                = Bool
False

    ---------------
    ok_fun_id :: Id -> Bool
ok_fun_id fun :: Id
fun = Id -> Int
fun_arity Id
fun Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
incoming_arity

    ---------------
    fun_arity :: Id -> Int
fun_arity fun :: Id
fun             -- See Note [Arity care]
       | Id -> Bool
isLocalId Id
fun
       , OccInfo -> Bool
isStrongLoopBreaker (Id -> OccInfo
idOccInfo Id
fun) = 0
       | Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0                           = Int
arity
       | Unfolding -> Bool
isEvaldUnfolding (Id -> Unfolding
idUnfolding Id
fun)  = 1
            -- See Note [Eta reduction of an eval'd function]
       | Bool
otherwise                           = 0
       where
         arity :: Int
arity = Id -> Int
idArity Id
fun

    ---------------
    ok_lam :: Id -> Bool
ok_lam v :: Id
v = Id -> Bool
isTyVar Id
v Bool -> Bool -> Bool
|| Id -> Bool
isEvVar Id
v

    ---------------
    ok_arg :: Var              -- Of type bndr_t
           -> CoreExpr         -- Of type arg_t
           -> Coercion         -- Of kind (t1~t2)
           -> Maybe (Coercion  -- Of type (arg_t -> t1 ~  bndr_t -> t2)
                               --   (and similarly for tyvars, coercion args)
                    , [Tickish Var])
    -- See Note [Eta reduction with casted arguments]
    ok_arg :: Id -> CoreExpr -> Coercion -> Maybe (Coercion, [Tickish Id])
ok_arg bndr :: Id
bndr (Type ty :: Type
ty) co :: Coercion
co
       | Just tv :: Id
tv <- Type -> Maybe Id
getTyVar_maybe Type
ty
       , Id
bndr Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
tv  = (Coercion, [Tickish Id]) -> Maybe (Coercion, [Tickish Id])
forall a. a -> Maybe a
Just ([Id] -> Coercion -> Coercion
mkHomoForAllCos [Id
tv] Coercion
co, [])
    ok_arg bndr :: Id
bndr (Var v :: Id
v) co :: Coercion
co
       | Id
bndr Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v   = let reflCo :: Coercion
reflCo = Type -> Coercion
mkRepReflCo (Id -> Type
idType Id
bndr)
                       in (Coercion, [Tickish Id]) -> Maybe (Coercion, [Tickish Id])
forall a. a -> Maybe a
Just (Role -> Coercion -> Coercion -> Coercion
mkFunCo Role
Representational Coercion
reflCo Coercion
co, [])
    ok_arg bndr :: Id
bndr (Cast e :: CoreExpr
e co_arg :: Coercion
co_arg) co :: Coercion
co
       | (ticks :: [Tickish Id]
ticks, Var v :: Id
v) <- (Tickish Id -> Bool) -> CoreExpr -> ([Tickish Id], CoreExpr)
forall b. (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
stripTicksTop Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable CoreExpr
e
       , Id
bndr Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v
       = (Coercion, [Tickish Id]) -> Maybe (Coercion, [Tickish Id])
forall a. a -> Maybe a
Just (Role -> Coercion -> Coercion -> Coercion
mkFunCo Role
Representational (Coercion -> Coercion
mkSymCo Coercion
co_arg) Coercion
co, [Tickish Id]
ticks)
       -- The simplifier combines multiple casts into one,
       -- so we can have a simple-minded pattern match here
    ok_arg bndr :: Id
bndr (Tick t :: Tickish Id
t arg :: CoreExpr
arg) co :: Coercion
co
       | Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable Tickish Id
t, Just (co' :: Coercion
co', ticks :: [Tickish Id]
ticks) <- Id -> CoreExpr -> Coercion -> Maybe (Coercion, [Tickish Id])
ok_arg Id
bndr CoreExpr
arg Coercion
co
       = (Coercion, [Tickish Id]) -> Maybe (Coercion, [Tickish Id])
forall a. a -> Maybe a
Just (Coercion
co', Tickish Id
tTickish Id -> [Tickish Id] -> [Tickish Id]
forall a. a -> [a] -> [a]
:[Tickish Id]
ticks)

    ok_arg _ _ _ = Maybe (Coercion, [Tickish Id])
forall a. Maybe a
Nothing

{-
Note [Eta reduction of an eval'd function]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In Haskell it is not true that    f = \x. f x
because f might be bottom, and 'seq' can distinguish them.

But it *is* true that   f = f `seq` \x. f x
and we'd like to simplify the latter to the former.  This amounts
to the rule that
  * when there is just *one* value argument,
  * f is not bottom
we can eta-reduce    \x. f x  ===>  f

This turned up in Trac #7542.


************************************************************************
*                                                                      *
\subsection{Determining non-updatable right-hand-sides}
*                                                                      *
************************************************************************

Top-level constructor applications can usually be allocated
statically, but they can't if the constructor, or any of the
arguments, come from another DLL (because we can't refer to static
labels in other DLLs).

If this happens we simply make the RHS into an updatable thunk,
and 'execute' it rather than allocating it statically.
-}

-- | This function is called only on *top-level* right-hand sides.
-- Returns @True@ if the RHS can be allocated statically in the output,
-- with no thunks involved at all.
rhsIsStatic
   :: Platform
   -> (Name -> Bool)         -- Which names are dynamic
   -> (LitNumType -> Integer -> Maybe CoreExpr)
      -- Desugaring for some literals (disgusting)
      -- C.f. Note [Disgusting computation of CafRefs] in TidyPgm
   -> CoreExpr -> Bool
-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
-- update flag on it and (iii) in DsExpr to decide how to expand
-- list literals
--
-- The basic idea is that rhsIsStatic returns True only if the RHS is
--      (a) a value lambda
--      (b) a saturated constructor application with static args
--
-- BUT watch out for
--  (i) Any cross-DLL references kill static-ness completely
--      because they must be 'executed' not statically allocated
--      ("DLL" here really only refers to Windows DLLs, on other platforms,
--      this is not necessary)
--
-- (ii) We treat partial applications as redexes, because in fact we
--      make a thunk for them that runs and builds a PAP
--      at run-time.  The only applications that are treated as
--      static are *saturated* applications of constructors.

-- We used to try to be clever with nested structures like this:
--              ys = (:) w ((:) w [])
-- on the grounds that CorePrep will flatten ANF-ise it later.
-- But supporting this special case made the function much more
-- complicated, because the special case only applies if there are no
-- enclosing type lambdas:
--              ys = /\ a -> Foo (Baz ([] a))
-- Here the nested (Baz []) won't float out to top level in CorePrep.
--
-- But in fact, even without -O, nested structures at top level are
-- flattened by the simplifier, so we don't need to be super-clever here.
--
-- Examples
--
--      f = \x::Int. x+7        TRUE
--      p = (True,False)        TRUE
--
--      d = (fst p, False)      FALSE because there's a redex inside
--                              (this particular one doesn't happen but...)
--
--      h = D# (1.0## /## 2.0##)        FALSE (redex again)
--      n = /\a. Nil a                  TRUE
--
--      t = /\a. (:) (case w a of ...) (Nil a)  FALSE (redex)
--
--
-- This is a bit like CoreUtils.exprIsHNF, with the following differences:
--    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
--
--    b) (C x xs), where C is a constructor is updatable if the application is
--         dynamic
--
--    c) don't look through unfolding of f in (f x).

rhsIsStatic :: Platform
-> (Name -> Bool)
-> (LitNumType -> Integer -> Maybe CoreExpr)
-> CoreExpr
-> Bool
rhsIsStatic platform :: Platform
platform is_dynamic_name :: Name -> Bool
is_dynamic_name cvt_literal :: LitNumType -> Integer -> Maybe CoreExpr
cvt_literal rhs :: CoreExpr
rhs = Bool -> CoreExpr -> Bool
is_static Bool
False CoreExpr
rhs
  where
  is_static :: Bool     -- True <=> in a constructor argument; must be atomic
            -> CoreExpr -> Bool

  is_static :: Bool -> CoreExpr -> Bool
is_static False  (Lam b :: Id
b e :: CoreExpr
e)              = Id -> Bool
isRuntimeVar Id
b Bool -> Bool -> Bool
|| Bool -> CoreExpr -> Bool
is_static Bool
False CoreExpr
e
  is_static in_arg :: Bool
in_arg (Tick n :: Tickish Id
n e :: CoreExpr
e)             = Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
n)
                                              Bool -> Bool -> Bool
&& Bool -> CoreExpr -> Bool
is_static Bool
in_arg CoreExpr
e
  is_static in_arg :: Bool
in_arg (Cast e :: CoreExpr
e _)             = Bool -> CoreExpr -> Bool
is_static Bool
in_arg CoreExpr
e
  is_static _      (Coercion {})          = Bool
True   -- Behaves just like a literal
  is_static in_arg :: Bool
in_arg (Lit (LitNumber nt :: LitNumType
nt i :: Integer
i _)) = case LitNumType -> Integer -> Maybe CoreExpr
cvt_literal LitNumType
nt Integer
i of
    Just e :: CoreExpr
e  -> Bool -> CoreExpr -> Bool
is_static Bool
in_arg CoreExpr
e
    Nothing -> Bool
True
  is_static _      (Lit (LitLabel {}))    = Bool
False
  is_static _      (Lit _)                = Bool
True
        -- A LitLabel (foreign import "&foo") in an argument
        -- prevents a constructor application from being static.  The
        -- reason is that it might give rise to unresolvable symbols
        -- in the object file: under Linux, references to "weak"
        -- symbols from the data segment give rise to "unresolvable
        -- relocation" errors at link time This might be due to a bug
        -- in the linker, but we'll work around it here anyway.
        -- SDM 24/2/2004

  is_static in_arg :: Bool
in_arg other_expr :: CoreExpr
other_expr = CoreExpr -> Int -> Bool
go CoreExpr
other_expr 0
   where
    go :: CoreExpr -> Int -> Bool
go (Var f :: Id
f) n_val_args :: Int
n_val_args
        | (Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
/= OS
OSMinGW32) Bool -> Bool -> Bool
||
          Bool -> Bool
not (Name -> Bool
is_dynamic_name (Id -> Name
idName Id
f))
        =  CheapAppFun
saturated_data_con Id
f Int
n_val_args
        Bool -> Bool -> Bool
|| (Bool
in_arg Bool -> Bool -> Bool
&& Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0)
                -- A naked un-applied variable is *not* deemed a static RHS
                -- E.g.         f = g
                -- Reason: better to update so that the indirection gets shorted
                --         out, and the true value will be seen
                -- NB: if you change this, you'll break the invariant that THUNK_STATICs
                --     are always updatable.  If you do so, make sure that non-updatable
                --     ones have enough space for their static link field!

    go (App f :: CoreExpr
f a :: CoreExpr
a) n_val_args :: Int
n_val_args
        | CoreExpr -> Bool
forall b. Expr b -> Bool
isTypeArg CoreExpr
a                    = CoreExpr -> Int -> Bool
go CoreExpr
f Int
n_val_args
        | Bool -> Bool
not Bool
in_arg Bool -> Bool -> Bool
&& Bool -> CoreExpr -> Bool
is_static Bool
True CoreExpr
a = CoreExpr -> Int -> Bool
go CoreExpr
f (Int
n_val_args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
        -- The (not in_arg) checks that we aren't in a constructor argument;
        -- if we are, we don't allow (value) applications of any sort
        --
        -- NB. In case you wonder, args are sometimes not atomic.  eg.
        --   x = D# (1.0## /## 2.0##)
        -- can't float because /## can fail.

    go (Tick n :: Tickish Id
n f :: CoreExpr
f) n_val_args :: Int
n_val_args = Bool -> Bool
not (Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode Tickish Id
n) Bool -> Bool -> Bool
&& CoreExpr -> Int -> Bool
go CoreExpr
f Int
n_val_args
    go (Cast e :: CoreExpr
e _) n_val_args :: Int
n_val_args = CoreExpr -> Int -> Bool
go CoreExpr
e Int
n_val_args
    go _          _          = Bool
False

    saturated_data_con :: CheapAppFun
saturated_data_con f :: Id
f n_val_args :: Int
n_val_args
        = case Id -> Maybe DataCon
isDataConWorkId_maybe Id
f of
            Just dc :: DataCon
dc -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> Int
dataConRepArity DataCon
dc
            Nothing -> Bool
False

{-
************************************************************************
*                                                                      *
\subsection{Type utilities}
*                                                                      *
************************************************************************
-}

-- | True if the type has no non-bottom elements, e.g. when it is an empty
-- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool.
-- See Note [Bottoming expressions]
--
-- See Note [No alternatives lint check] for another use of this function.
isEmptyTy :: Type -> Bool
isEmptyTy :: Type -> Bool
isEmptyTy ty :: Type
ty
    -- Data types where, given the particular type parameters, no data
    -- constructor matches, are empty.
    -- This includes data types with no constructors, e.g. Data.Void.Void.
    | Just (tc :: TyCon
tc, inst_tys :: [Type]
inst_tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
    , Just dcs :: [DataCon]
dcs <- TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tc
    , (DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Type] -> DataCon -> Bool
dataConCannotMatch [Type]
inst_tys) [DataCon]
dcs
    = Bool
True
    | Bool
otherwise
    = Bool
False

{-
*****************************************************
*
* StaticPtr
*
*****************************************************
-}

-- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields
-- @Just (makeStatic, t, srcLoc, e)@.
--
-- Returns @Nothing@ for every other expression.
collectMakeStaticArgs
  :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
collectMakeStaticArgs :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
collectMakeStaticArgs e :: CoreExpr
e
    | (fun :: CoreExpr
fun@(Var b :: Id
b), [Type t :: Type
t, loc :: CoreExpr
loc, arg :: CoreExpr
arg], _) <- (Tickish Id -> Bool)
-> CoreExpr -> (CoreExpr, [CoreExpr], [Tickish Id])
forall b.
(Tickish Id -> Bool) -> Expr b -> (Expr b, [Expr b], [Tickish Id])
collectArgsTicks (Bool -> Tickish Id -> Bool
forall a b. a -> b -> a
const Bool
True) CoreExpr
e
    , Id -> Name
idName Id
b Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
makeStaticName = (CoreExpr, Type, CoreExpr, CoreExpr)
-> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
forall a. a -> Maybe a
Just (CoreExpr
fun, Type
t, CoreExpr
loc, CoreExpr
arg)
collectMakeStaticArgs _          = Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
forall a. Maybe a
Nothing

{-
************************************************************************
*                                                                      *
\subsection{Join points}
*                                                                      *
************************************************************************
-}

-- | Does this binding bind a join point (or a recursive group of join points)?
isJoinBind :: CoreBind -> Bool
isJoinBind :: Bind Id -> Bool
isJoinBind (NonRec b :: Id
b _)       = Id -> Bool
isJoinId Id
b
isJoinBind (Rec ((b :: Id
b, _) : _)) = Id -> Bool
isJoinId Id
b
isJoinBind _                  = Bool
False