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


Utility functions on @Core@ syntax
-}

-- | Commonly useful utilities for manipulating the Core language
module GHC.Core.Utils (
        -- * Constructing expressions
        mkCast, mkCastMCo, mkPiMCo,
        mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,
        bindNonRec, needsCaseBinding, needsCaseBindingL,
        mkAltExpr, mkDefaultCase, mkSingleAltCase,

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

        -- * Properties of expressions
        exprType, coreAltType, coreAltsType,
        mkLamType, mkLamTypes,
        mkFunctionType,
        exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe,
        trivial_expr_fold,
        exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,
        exprIsHNF, exprOkForSpeculation, exprOkToDiscard, exprOkForSpecEval,
        exprIsWorkFree, exprIsConLike,
        isCheapApp, isExpandableApp, isSaturatedConApp,
        exprIsTickedString, exprIsTickedString_maybe,
        exprIsTopLevelBindable,
        altsAreExhaustive, etaExpansionTick,

        -- * Equality
        cheapEqExpr, cheapEqExpr', diffBinds,

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

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

        -- * InScopeSet things which work over CoreBinds
        mkInScopeSetBndrs, extendInScopeSetBind, extendInScopeSetBndrs,

        -- * StaticPtr
        collectMakeStaticArgs,

        -- * Join points
        isJoinBind,

        -- * Tag inference
        mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId,

        -- * unsafeEqualityProof
        isUnsafeEqualityCase,

        -- * Dumping stuff
        dumpIdInfoOfProgram
    ) where

import GHC.Prelude
import GHC.Platform

import GHC.Core
import GHC.Core.Ppr
import GHC.Core.FVs( bindFreeVars )
import GHC.Core.DataCon
import GHC.Core.Type as Type
import GHC.Core.Predicate( isCoVarType )
import GHC.Core.FamInstEnv
import GHC.Core.TyCo.Compare( eqType, eqTypeX )
import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.Core.TyCon
import GHC.Core.Multiplicity

import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey, unsafeReflDataConKey )
import GHC.Builtin.PrimOps

import GHC.Types.Var
import GHC.Types.SrcLoc
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Literal
import GHC.Types.Tickish
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Basic( Arity )
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Types.Demand
import GHC.Types.RepType (isZeroBitTy)

import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.List.SetOps( minusList )
import GHC.Data.OrdList

import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc

import Data.ByteString     ( ByteString )
import Data.Function       ( on )
import Data.List           ( sort, sortBy, partition, zipWith4, mapAccumL )
import Data.Ord            ( comparing )
import Control.Monad       ( guard )
import qualified Data.Set as Set

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

exprType :: HasDebugCallStack => CoreExpr -> Type
-- ^ Recover the type of a well-typed Core expression. Fails when
-- applied to the actual 'GHC.Core.Type' expression as it cannot
-- really be said to have a type
exprType :: HasDebugCallStack => CoreExpr -> Type
exprType (Var Id
var)           = Id -> Type
idType Id
var
exprType (Lit Literal
lit)           = Literal -> Type
literalType Literal
lit
exprType (Coercion Coercion
co)       = Coercion -> Type
coercionType Coercion
co
exprType (Let Bind Id
bind CoreExpr
body)
  | NonRec Id
tv CoreExpr
rhs <- Bind Id
bind    -- See Note [Type bindings]
  , Type Type
ty <- CoreExpr
rhs           = [Id] -> [Type] -> Type -> Type
substTyWithUnchecked [Id
tv] [Type
ty] (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body)
  | Bool
otherwise                = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body
exprType (Case CoreExpr
_ Id
_ Type
ty [Alt Id]
_)     = Type
ty
exprType (Cast CoreExpr
_ Coercion
co)         = HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionRKind Coercion
co
exprType (Tick CoreTickish
_ CoreExpr
e)          = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e
exprType (Lam Id
binder CoreExpr
expr)   = HasDebugCallStack => Id -> Type -> Type
Id -> Type -> Type
mkLamType Id
binder (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
expr)
exprType e :: CoreExpr
e@(App CoreExpr
_ CoreExpr
_)
  = case CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e of
        (CoreExpr
fun, [CoreExpr]
args) -> HasDebugCallStack => SDoc -> Type -> [CoreExpr] -> Type
SDoc -> Type -> [CoreExpr] -> Type
applyTypeToArgs (CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
e) (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
fun) [CoreExpr]
args
exprType (Type Type
ty) = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"exprType" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)

coreAltType :: CoreAlt -> Type
-- ^ Returns the type of the alternatives right hand side
coreAltType :: Alt Id -> Type
coreAltType alt :: Alt Id
alt@(Alt AltCon
_ [Id]
bs CoreExpr
rhs)
  = case [Id] -> Type -> Maybe Type
occCheckExpand [Id]
bs Type
rhs_ty of
      -- Note [Existential variables and silly type synonyms]
      Just Type
ty -> Type
ty
      Maybe Type
Nothing -> String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreAltType" (Alt Id -> SDoc
forall a. OutputableBndr a => Alt a -> SDoc
pprCoreAlt Alt Id
alt SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty)
  where
    rhs_ty :: Type
rhs_ty = HasDebugCallStack => CoreExpr -> Type
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 :: [Alt Id] -> Type
coreAltsType (Alt Id
alt:[Alt Id]
_) = Alt Id -> Type
coreAltType Alt Id
alt
coreAltsType []      = String -> Type
forall a. HasCallStack => String -> a
panic String
"coreAltsType"

mkLamType  :: HasDebugCallStack => Var -> Type -> Type
-- ^ Makes a @(->)@ type or an implicit forall type, depending
-- on whether it is given a type variable or a term variable.
-- This is used, for example, when producing the type of a lambda.
--
mkLamTypes :: [Var] -> Type -> Type
-- ^ 'mkLamType' for multiple type or value arguments

mkLamType :: HasDebugCallStack => Id -> Type -> Type
mkLamType Id
v Type
body_ty
   | Id -> Bool
isTyVar Id
v
   = ForAllTyBinder -> Type -> Type
mkForAllTy (Id -> ForAllTyFlag -> ForAllTyBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
v ForAllTyFlag
coreTyLamForAllTyFlag) Type
body_ty
     -- coreTyLamForAllTyFlag: see Note [Required foralls in Core]
     --                        in GHC.Core.TyCo.Rep

   | Id -> Bool
isCoVar Id
v
   , Id
v Id -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
body_ty
     -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep
   = ForAllTyBinder -> Type -> Type
mkForAllTy (Id -> ForAllTyFlag -> ForAllTyBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
v ForAllTyFlag
coreTyLamForAllTyFlag) Type
body_ty

   | Bool
otherwise
   = HasDebugCallStack => Type -> Type -> Type -> Type
Type -> Type -> Type -> Type
mkFunctionType (Id -> Type
varMult Id
v) (Id -> Type
varType Id
v) Type
body_ty

mkLamTypes :: [Id] -> Type -> Type
mkLamTypes [Id]
vs Type
ty = (Id -> Type -> Type) -> Type -> [Id] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HasDebugCallStack => Id -> Type -> Type
Id -> Type -> Type
mkLamType Type
ty [Id]
vs

{-
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 (#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 #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.
-}

applyTypeToArgs :: HasDebugCallStack => SDoc -> Type -> [CoreExpr] -> Type
-- ^ Determines the type resulting from applying an expression with given type
--- to given argument expressions.
-- The first argument is just for debugging, and gives some context
applyTypeToArgs :: HasDebugCallStack => SDoc -> Type -> [CoreExpr] -> Type
applyTypeToArgs SDoc
pp_e Type
op_ty [CoreExpr]
args
  = Type -> [CoreExpr] -> Type
go Type
op_ty [CoreExpr]
args
  where
    go :: Type -> [CoreExpr] -> Type
go Type
op_ty []                   = Type
op_ty
    go Type
op_ty (Type Type
ty : [CoreExpr]
args)     = Type -> [Type] -> [CoreExpr] -> Type
go_ty_args Type
op_ty [Type
ty] [CoreExpr]
args
    go Type
op_ty (Coercion Coercion
co : [CoreExpr]
args) = Type -> [Type] -> [CoreExpr] -> Type
go_ty_args Type
op_ty [Coercion -> Type
mkCoercionTy Coercion
co] [CoreExpr]
args
    go Type
op_ty (CoreExpr
_ : [CoreExpr]
args)           | Just (FunTyFlag
_, Type
_, Type
_, Type
res_ty) <- Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
op_ty
                                  = Type -> [CoreExpr] -> Type
go Type
res_ty [CoreExpr]
args
    go Type
_ [CoreExpr]
args = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"applyTypeToArgs" ([CoreExpr] -> SDoc
panic_msg [CoreExpr]
args)

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

    panic_msg :: [CoreExpr] -> SDoc
panic_msg [CoreExpr]
as = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Expression:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp_e
                        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Type:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
op_ty
                        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args
                        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Args':" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
as ]

mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr
mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr
mkCastMCo CoreExpr
e MCoercionR
MRefl    = CoreExpr
e
mkCastMCo CoreExpr
e (MCo Coercion
co) = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
e Coercion
co
  -- We are careful to use (MCo co) only when co is not reflexive
  -- Hence (Cast e co) rather than (mkCast e co)

mkPiMCo :: Var -> MCoercionR -> MCoercionR
mkPiMCo :: Id -> MCoercionR -> MCoercionR
mkPiMCo Id
_  MCoercionR
MRefl   = MCoercionR
MRefl
mkPiMCo Id
v (MCo Coercion
co) = Coercion -> MCoercionR
MCo (Role -> Id -> Coercion -> Coercion
mkPiCo Role
Representational Id
v Coercion
co)


{- *********************************************************************
*                                                                      *
             Casts
*                                                                      *
********************************************************************* -}

-- | Wrap the given expression in the coercion safely, dropping
-- identity coercions and coalescing nested coercions
mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr

mkCast :: HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
expr Coercion
co
  = Bool -> SDoc -> CoreExpr -> CoreExpr
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Coercion -> Role
coercionRole Coercion
co Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Representational)
              (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"coercion" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"passed to mkCast"
               SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has wrong role" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Role
coercionRole Coercion
co)) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
    Bool -> String -> SDoc -> CoreExpr -> CoreExpr
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (Bool -> Bool
not (HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionLKind Coercion
co HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
expr))
          String
"Trying to coerce" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr
          SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"::" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
expr) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
")"
          SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Type
coercionType Coercion
co)
          SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
HasCallStack => SDoc
callStackDoc) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
    case CoreExpr
expr of
      Cast CoreExpr
expr Coercion
co2 -> HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
expr (Coercion -> Coercion -> Coercion
mkTransCo Coercion
co2 Coercion
co)
      Tick CoreTickish
t CoreExpr
expr   -> CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
expr Coercion
co)

      Coercion Coercion
e_co | Type -> Bool
isCoVarType (HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionRKind 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)

      CoreExpr
_ | Coercion -> Bool
isReflCo Coercion
co -> CoreExpr
expr
        | Bool
otherwise   -> CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
expr Coercion
co


{- *********************************************************************
*                                                                      *
             Attaching ticks
*                                                                      *
********************************************************************* -}

-- | Wraps the given expression in the source annotation, dropping the
-- annotation if possible.
mkTick :: CoreTickish -> CoreExpr -> CoreExpr
mkTick :: CoreTickish -> CoreExpr -> CoreExpr
mkTick CoreTickish
t 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 = CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCanSplit CoreTickish
t Bool -> Bool -> Bool
&& CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace (CoreTickish -> CoreTickish
forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoCount CoreTickish
t) TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
/= CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t

  -- mkTick' handles floating of ticks *into* the expression.
  -- In this function, `top` is applied after adding the tick, and `rest` before.
  -- This will result in applications that look like (top $ Tick t $ rest expr).
  -- If we want to push the tick deeper, we pre-compose `top` with a function
  -- adding the tick.
  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' CoreExpr -> CoreExpr
top CoreExpr -> CoreExpr
rest 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 CoreTickish
t2 CoreExpr
e
      | ProfNote{} <- CoreTickish
t2, ProfNote{} <- CoreTickish
t -> CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
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.
      | CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t2 TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
/= CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
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
. CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t2) CoreExpr -> CoreExpr
rest CoreExpr
e

    -- For annotations this is where we make sure to not introduce
    -- redundant ticks.
      | CoreTickish -> CoreTickish -> Bool
forall (pass :: TickishPass).
Eq (GenTickish pass) =>
GenTickish pass -> GenTickish pass -> Bool
tickishContains CoreTickish
t CoreTickish
t2              -> (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
mkTick' CoreExpr -> CoreExpr
top CoreExpr -> CoreExpr
rest CoreExpr
e
      | CoreTickish -> CoreTickish -> Bool
forall (pass :: TickishPass).
Eq (GenTickish pass) =>
GenTickish pass -> GenTickish pass -> Bool
tickishContains CoreTickish
t2 CoreTickish
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
. CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
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 CoreExpr
e 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 Coercion
co -> Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
co

    Lam Id
x 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
|| CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
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
$ CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick (CoreTickish -> CoreTickish
forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoScope CoreTickish
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
$ CoreTickish -> CoreExpr -> CoreExpr
mkTick (CoreTickish -> CoreTickish
forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoCount CoreTickish
t) CoreExpr
e

    App CoreExpr
f 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
&& (CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
tTickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
==TickishPlacement
PlaceCostCentre Bool -> Bool -> Bool
|| Bool
canSplit)
      -> if CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
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
$ CoreTickish -> CoreExpr -> CoreExpr
tickHNFArgs CoreTickish
t CoreExpr
expr
         else CoreExpr -> CoreExpr
top (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick (CoreTickish -> CoreTickish
forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoScope CoreTickish
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
$ CoreTickish -> CoreExpr -> CoreExpr
tickHNFArgs (CoreTickish -> CoreTickish
forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoCount CoreTickish
t) CoreExpr
expr

    Var Id
x
      | Bool
notFunction Bool -> Bool -> Bool
&& CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
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
$ CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick (CoreTickish -> CoreTickish
forall (pass :: TickishPass). GenTickish pass -> GenTickish pass
mkNoScope CoreTickish
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{}
      | CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
t TickishPlacement -> TickishPlacement -> Bool
forall a. Eq a => a -> a -> Bool
== TickishPlacement
PlaceCostCentre
      -> CoreExpr
orig_expr

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

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

isSaturatedConApp :: CoreExpr -> Bool
isSaturatedConApp :: CoreExpr -> Bool
isSaturatedConApp CoreExpr
e = CoreExpr -> [CoreExpr] -> Bool
forall {b}. Expr b -> [Expr b] -> Bool
go CoreExpr
e []
  where go :: Expr b -> [Expr b] -> Bool
go (App Expr b
f Expr b
a) [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 Id
fun) [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 Expr b
f Coercion
_) [Expr b]
as = Expr b -> [Expr b] -> Bool
go Expr b
f [Expr b]
as
        go Expr b
_ [Expr b]
_ = Bool
False

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

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

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

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

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

-- | Completely strip ticks satisfying a predicate from an
-- expression. Note this is O(n) in the size of the expression!
stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksE :: forall b. (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksE CoreTickish -> Bool
p Expr b
expr = Expr b -> Expr b
go Expr b
expr
  where go :: Expr b -> Expr b
go (App Expr b
e 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 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 Bind b
b 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 Expr b
e b
b Type
t [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 Expr b
e 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 CoreTickish
t Expr b
e)
          | CoreTickish -> Bool
p CoreTickish
t             = Expr b -> Expr b
go Expr b
e
          | Bool
otherwise       = CoreTickish -> Expr b -> Expr b
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (Expr b -> Expr b
go Expr b
e)
        go Expr b
other            = Expr b
other
        go_bs :: Bind b -> Bind b
go_bs (NonRec b
b 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 [(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, Expr b
e)         = (b
b, Expr b -> Expr b
go Expr b
e)
        go_a :: Alt b -> Alt b
go_a (Alt AltCon
c [b]
bs Expr b
e)   = AltCon -> [b] -> Expr b -> Alt b
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
c [b]
bs (Expr b -> Expr b
go Expr b
e)

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

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

bindNonRec :: HasDebugCallStack => 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 'GHC.Core.Make.mkCoreLet'
bindNonRec :: HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
bndr CoreExpr
rhs 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
  | HasDebugCallStack => Type -> CoreExpr -> Bool
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 -> CoreExpr -> CoreExpr
mkDefaultCase CoreExpr
rhs Id
bndr 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

-- | `needsCaseBinding` tests whether we have to use a @case@ rather than @let@
-- binding for this expression as per the invariants of 'CoreExpr': see
-- "GHC.Core#let_can_float_invariant"
-- (needsCaseBinding ty rhs) requires that `ty` has a well-defined levity, else
-- `typeLevity ty` will fail; but that should be the case because
-- `needsCaseBinding` is only called once typechecking is complete
needsCaseBinding :: HasDebugCallStack => Type -> CoreExpr -> Bool
needsCaseBinding :: HasDebugCallStack => Type -> CoreExpr -> Bool
needsCaseBinding Type
ty CoreExpr
rhs = Levity -> CoreExpr -> Bool
needsCaseBindingL (HasDebugCallStack => Type -> Levity
Type -> Levity
typeLevity Type
ty) CoreExpr
rhs

needsCaseBindingL :: Levity -> CoreExpr -> Bool
-- True <=> make a case expression instead of a let
-- These can arise either from the desugarer,
-- or from beta reductions: (\x.e) (x +# y)
needsCaseBindingL :: Levity -> CoreExpr -> Bool
needsCaseBindingL Levity
Lifted   CoreExpr
_rhs = Bool
False
needsCaseBindingL Levity
Unlifted CoreExpr
rhs = Bool -> Bool
not (CoreExpr -> Bool
exprOkForSpeculation CoreExpr
rhs)

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 DataCon
con) [Id]
args [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 Literal
lit) [] []
  = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit
mkAltExpr (LitAlt Literal
_) [Id]
_ [Type]
_ = String -> CoreExpr
forall a. HasCallStack => String -> a
panic String
"mkAltExpr LitAlt"
mkAltExpr AltCon
DEFAULT [Id]
_ [Type]
_ = String -> CoreExpr
forall a. HasCallStack => String -> a
panic String
"mkAltExpr DEFAULT"

mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr
-- Make (case x of y { DEFAULT -> e }
mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase CoreExpr
scrut Id
case_bndr CoreExpr
body
  = CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Id
case_bndr (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body) [AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
body]

mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr
-- Use this function if possible, when building a case,
-- because it ensures that the type on the Case itself
-- doesn't mention variables bound by the case
-- See Note [Care with the type of a case expression]
mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
scrut Id
case_bndr AltCon
con [Id]
bndrs CoreExpr
body
  = CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Id
case_bndr Type
case_ty [AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bndrs CoreExpr
body]
  where
    body_ty :: Type
body_ty = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body

    case_ty :: Type
case_ty -- See Note [Care with the type of a case expression]
      | Just Type
body_ty' <- [Id] -> Type -> Maybe Type
occCheckExpand [Id]
bndrs Type
body_ty
      = Type
body_ty'

      | Bool
otherwise
      = String -> SDoc -> Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkSingleAltCase" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
scrut SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
bndrs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
body_ty)

{- Note [Care with the type of a case expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a phantom type synonym
   type S a = Int
and we want to form the case expression
   case x of K (a::*) -> (e :: S a)

We must not make the type field of the case-expression (S a) because
'a' isn't in scope.  Hence the call to occCheckExpand.  This caused
issue #17056.

NB: this situation can only arise with type synonyms, which can
falsely "mention" type variables that aren't "really there", and which
can be eliminated by expanding the synonym.

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

************************************************************************
*                                                                      *
               Operations over 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 :: [Alt b] -> ([Alt b], Maybe (Expr b))
findDefault :: forall b. [Alt b] -> ([Alt b], Maybe (Expr b))
findDefault (Alt AltCon
DEFAULT [b]
args Expr b
rhs : [Alt b]
alts) = Bool -> ([Alt b], Maybe (Expr b)) -> ([Alt b], Maybe (Expr b))
forall a. HasCallStack => Bool -> a -> a
assert ([b] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
args) ([Alt b]
alts, Expr b -> Maybe (Expr b)
forall a. a -> Maybe a
Just Expr b
rhs)
findDefault [Alt b]
alts                          =                    ([Alt b]
alts, Maybe (Expr b)
forall a. Maybe a
Nothing)

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

isDefaultAlt :: Alt b -> Bool
isDefaultAlt :: forall b. Alt b -> Bool
isDefaultAlt (Alt AltCon
DEFAULT [b]
_ Expr b
_) = Bool
True
isDefaultAlt Alt b
_                 = Bool
False

-- | Find the case alternative corresponding to a particular
-- constructor: panics if no such constructor exists
findAlt :: AltCon -> [Alt b] -> Maybe (Alt b)
    -- A "Nothing" result *is* legitimate
    -- See Note [Unreachable code]
findAlt :: forall b. AltCon -> [Alt b] -> Maybe (Alt b)
findAlt AltCon
con [Alt b]
alts
  = case [Alt b]
alts of
        (deflt :: Alt b
deflt@(Alt AltCon
DEFAULT [b]
_ Expr b
_):[Alt b]
alts) -> [Alt b] -> Maybe (Alt b) -> Maybe (Alt b)
go [Alt b]
alts (Alt b -> Maybe (Alt b)
forall a. a -> Maybe a
Just Alt b
deflt)
        [Alt b]
_                              -> [Alt b] -> Maybe (Alt b) -> Maybe (Alt b)
go [Alt b]
alts Maybe (Alt b)
forall a. Maybe a
Nothing
  where
    go :: [Alt b] -> Maybe (Alt b) -> Maybe (Alt b)
go []                     Maybe (Alt b)
deflt = Maybe (Alt b)
deflt
    go (alt :: Alt b
alt@(Alt AltCon
con1 [b]
_ Expr b
_) : [Alt b]
alts) Maybe (Alt b)
deflt
      = case AltCon
con AltCon -> AltCon -> Ordering
`cmpAltCon` AltCon
con1 of
          Ordering
LT -> Maybe (Alt b)
deflt   -- Missed it already; the alts are in increasing order
          Ordering
EQ -> Alt b -> Maybe (Alt b)
forall a. a -> Maybe a
Just Alt b
alt
          Ordering
GT -> Bool -> Maybe (Alt b) -> Maybe (Alt b)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (AltCon
con1 AltCon -> AltCon -> Bool
forall a. Eq a => a -> a -> Bool
== AltCon
DEFAULT)) (Maybe (Alt b) -> Maybe (Alt b)) -> Maybe (Alt b) -> Maybe (Alt b)
forall a b. (a -> b) -> a -> b
$ [Alt b] -> Maybe (Alt b) -> Maybe (Alt b)
go [Alt b]
alts Maybe (Alt b)
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 #3118.)  Then the full-laziness 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 GHC.Core.Opt.Simplify.rebuildCase.
-}

---------------------------------
mergeCaseAlts :: Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt])
-- See Note [Merge Nested Cases]
mergeCaseAlts :: Id -> [Alt Id] -> Maybe ([Bind Id], [Alt Id])
mergeCaseAlts Id
outer_bndr (Alt AltCon
DEFAULT [Id]
_ CoreExpr
deflt_rhs : [Alt Id]
outer_alts)
  | Just ([Bind Id]
joins, [Alt Id]
inner_alts) <- CoreExpr -> Maybe ([Bind Id], [Alt Id])
go CoreExpr
deflt_rhs
  = ([Bind Id], [Alt Id]) -> Maybe ([Bind Id], [Alt Id])
forall a. a -> Maybe a
Just ([Bind Id]
joins, [Alt Id] -> [Alt Id] -> [Alt Id]
forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts [Alt Id]
outer_alts [Alt Id]
inner_alts)
                -- NB: mergeAlts gives priority to the left
                --      case x of
                --        A -> e1
                --        DEFAULT -> case x of
                --                      A -> e2
                --                      B -> e3
                -- When we merge, we must ensure that e1 takes
                -- precedence over e2 as the value for A!
  where
    go :: CoreExpr -> Maybe ([CoreBind], [CoreAlt])

    -- Whizzo: we can merge!
    go :: CoreExpr -> Maybe ([Bind Id], [Alt Id])
go (Case (Var Id
inner_scrut_var) Id
inner_bndr Type
_ [Alt Id]
inner_alts)
       | Id
inner_scrut_var Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
outer_bndr
       , Bool -> Bool
not (Id
inner_bndr Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
outer_bndr)   -- Avoid shadowing
       , let wrap_let :: CoreExpr -> CoreExpr
wrap_let CoreExpr
rhs' = 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
inner_bndr (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
outer_bndr)) CoreExpr
rhs'
                -- inner_bndr is never dead!  It's the scrutinee!
                -- The let is OK even for unboxed binders
                -- See Note [Merge Nested Cases] wrinkle (MC2)
             do_one :: Alt Id -> Maybe (Alt Id)
do_one (Alt AltCon
con [Id]
bndrs CoreExpr
rhs)
               | (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
outer_bndr) [Id]
bndrs = Maybe (Alt Id)
forall a. Maybe a
Nothing
               | Bool
otherwise                 = Alt Id -> Maybe (Alt Id)
forall a. a -> Maybe a
Just (AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bndrs (CoreExpr -> CoreExpr
wrap_let CoreExpr
rhs))
       = do { alts' <- (Alt Id -> Maybe (Alt Id)) -> [Alt Id] -> Maybe [Alt Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Alt Id -> Maybe (Alt Id)
do_one [Alt Id]
inner_alts
            ; return ([], alts') }

    -- Deal with tagToEnum# See Note [Merge Nested Cases] wrinkle (MC3)
    go (App (App (Var Id
f) (Type Type
type_arg)) (Var Id
v))
      | Id
v Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
outer_bndr
      , Just PrimOp
TagToEnumOp <- Id -> Maybe PrimOp
isPrimOpId_maybe Id
f
      , Just TyCon
tc  <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
type_arg
      , Just (DataCon
dc1:[DataCon]
dcs) <- TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tc   -- At least one data constructor
      , [DataCon]
dcs [DataCon] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtMost` Int
3  -- Arbitrary
      = ([Bind Id], [Alt Id]) -> Maybe ([Bind Id], [Alt Id])
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [], DataCon -> [DataCon] -> [Alt Id]
forall {b}. DataCon -> [DataCon] -> [Alt b]
mk_alts DataCon
dc1 [DataCon]
dcs)
      where
        mk_lit :: DataCon -> Literal
mk_lit DataCon
dc = Integer -> Literal
mkLitIntUnchecked (Integer -> Literal) -> Integer -> Literal
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ DataCon -> Int
dataConTagZ DataCon
dc
        mk_rhs :: DataCon -> Expr b
mk_rhs DataCon
dc = Id -> Expr b
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
dc)
        mk_alts :: DataCon -> [DataCon] -> [Alt b]
mk_alts DataCon
dc1 [DataCon]
dcs =  AltCon -> [b] -> Expr b -> Alt b
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT              [] (DataCon -> Expr b
forall {b}. DataCon -> Expr b
mk_rhs DataCon
dc1)
                        Alt b -> [Alt b] -> [Alt b]
forall a. a -> [a] -> [a]
: [AltCon -> [b] -> Expr b -> Alt b
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (Literal -> AltCon
LitAlt (DataCon -> Literal
mk_lit DataCon
dc)) [] (DataCon -> Expr b
forall {b}. DataCon -> Expr b
mk_rhs DataCon
dc) | DataCon
dc <- [DataCon]
dcs]

    -- Float out let/join bindings
    -- See Note [Merge Nested Cases] wrinkle (MC4)
    go (Let Bind Id
bind CoreExpr
body)
      | [Alt Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
outer_alts Bool -> Bool -> Bool
|| Bind Id -> Bool
isJoinBind Bind Id
bind
      = do { (joins, alts) <- CoreExpr -> Maybe ([Bind Id], [Alt Id])
go CoreExpr
body

             -- Check for capture; but only if we could otherwise do a merge
           ; let capture = Id
outer_bndr Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Bind Id -> [Id]
forall b. Bind b -> [b]
bindersOf Bind Id
bind
                           Bool -> Bool -> Bool
|| Id
outer_bndr Id -> VarSet -> Bool
`elemVarSet` Bind Id -> VarSet
bindFreeVars Bind Id
bind
           ; guard (not capture)

           ; return (bind:joins, alts ) }
      | Bool
otherwise
      = Maybe ([Bind Id], [Alt Id])
forall a. Maybe a
Nothing

    -- We don't want ticks to get in the way; just push them inwards.
    -- (This happens when you add SourceTicks e.g. GHC.Num.Integer.integerLt#)
    go (Tick CoreTickish
t CoreExpr
body)
      = do { (joins, alts) <- CoreExpr -> Maybe ([Bind Id], [Alt Id])
go CoreExpr
body
           ; return (joins, [Alt con bs (Tick t rhs) | Alt con bs rhs <- alts]) }

    go CoreExpr
_ = Maybe ([Bind Id], [Alt Id])
forall a. Maybe a
Nothing

mergeCaseAlts Id
_ [Alt Id]
_ = Maybe ([Bind Id], [Alt Id])
forall a. Maybe a
Nothing

---------------------------------
mergeAlts :: [Alt a] -> [Alt a] -> [Alt a]
-- ^ Merge alternatives preserving order; alternatives in
-- the first argument shadow ones in the second
mergeAlts :: forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts [] [Alt a]
as2 = [Alt a]
as2
mergeAlts [Alt a]
as1 [] = [Alt a]
as1
mergeAlts (Alt a
a1:[Alt a]
as1) (Alt a
a2:[Alt a]
as2)
  = case Alt a
a1 Alt a -> Alt a -> Ordering
forall a. Alt a -> Alt a -> Ordering
`cmpAlt` Alt a
a2 of
        Ordering
LT -> Alt a
a1 Alt a -> [Alt a] -> [Alt a]
forall a. a -> [a] -> [a]
: [Alt a] -> [Alt a] -> [Alt a]
forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts [Alt a]
as1      (Alt a
a2Alt a -> [Alt a] -> [Alt a]
forall a. a -> [a] -> [a]
:[Alt a]
as2)
        Ordering
EQ -> Alt a
a1 Alt a -> [Alt a] -> [Alt a]
forall a. a -> [a] -> [a]
: [Alt a] -> [Alt a] -> [Alt a]
forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts [Alt a]
as1      [Alt a]
as2       -- Discard a2
        Ordering
GT -> Alt a
a2 Alt a -> [Alt a] -> [Alt a]
forall a. a -> [a] -> [a]
: [Alt a] -> [Alt a] -> [Alt a]
forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts (Alt a
a1Alt a -> [Alt a] -> [Alt a]
forall a. a -> [a] -> [a]
:[Alt a]
as1) [Alt a]
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 AltCon
DEFAULT      [CoreExpr]
args = Bool -> [CoreExpr] -> [CoreExpr]
forall a. HasCallStack => Bool -> a -> a
assert ([CoreExpr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreExpr]
args) []
trimConArgs (LitAlt Literal
_)   [CoreExpr]
args = Bool -> [CoreExpr] -> [CoreExpr]
forall a. HasCallStack => Bool -> a -> a
assert ([CoreExpr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreExpr]
args) []
trimConArgs (DataAlt DataCon
dc) [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
           -> [Alt b] -- ^ Alternatives
           -> ([AltCon], [Alt b])
             -- 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 :: forall b.
TyCon -> [Type] -> [AltCon] -> [Alt b] -> ([AltCon], [Alt b])
filterAlts TyCon
_tycon [Type]
inst_tys [AltCon]
imposs_cons [Alt b]
alts
  = [AltCon]
imposs_deflt_cons [AltCon] -> ([AltCon], [Alt b]) -> ([AltCon], [Alt b])
forall a b. [a] -> b -> b
`seqList`
      ([AltCon]
imposs_deflt_cons, [Alt b] -> Maybe (Expr b) -> [Alt b]
forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
addDefault [Alt b]
trimmed_alts Maybe (Expr b)
maybe_deflt)
  -- Very important to force `imposs_deflt_cons` as that forces `alt_cons`, which
  -- is essentially as retaining `alts_wo_default` or any `Alt b` for that matter
  -- leads to a huge space leak (see #22102 and !8896)
  where
    ([Alt b]
alts_wo_default, Maybe (Expr b)
maybe_deflt) = [Alt b] -> ([Alt b], Maybe (Expr b))
forall b. [Alt b] -> ([Alt b], Maybe (Expr b))
findDefault [Alt b]
alts
    alt_cons :: [AltCon]
alt_cons = [AltCon
con | Alt AltCon
con [b]
_ Expr b
_ <- [Alt b]
alts_wo_default]

    trimmed_alts :: [Alt b]
trimmed_alts = (Alt b -> Bool) -> [Alt b] -> [Alt b]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ([Type] -> Alt b -> Bool
forall b. [Type] -> Alt b -> Bool
impossible_alt [Type]
inst_tys) [Alt b]
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] -> Alt b -> Bool
    impossible_alt :: forall b. [Type] -> Alt b -> Bool
impossible_alt [Type]
_ (Alt AltCon
con [b]
_ Expr b
_) | 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 [Type]
inst_tys (Alt (DataAlt DataCon
con) [b]
_ Expr b
_) = [Type] -> DataCon -> Bool
dataConCannotMatch [Type]
inst_tys DataCon
con
    impossible_alt [Type]
_  Alt b
_                             = Bool
False

-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so.
-- See Note [Refine DEFAULT case alternatives]
refineDefaultAlt :: [Unique]          -- ^ Uniques for constructing new binders
                 -> Mult              -- ^ Multiplicity annotation of the case expression
                 -> 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]
-> Type
-> TyCon
-> [Type]
-> [AltCon]
-> [Alt Id]
-> (Bool, [Alt Id])
refineDefaultAlt [Unique]
us Type
mult TyCon
tycon [Type]
tys [AltCon]
imposs_deflt_cons [Alt Id]
all_alts
  | Alt AltCon
DEFAULT [Id]
_ CoreExpr
rhs : [Alt Id]
rest_alts <- [Alt Id]
all_alts
  , TyCon -> Bool
isAlgTyCon TyCon
tycon            -- It's a data type, tuple, or unboxed tuples.
  , Bool -> Bool
not (TyCon -> Bool
isNewTyCon TyCon
tycon)      -- Exception 1 in Note [Refine DEFAULT case alternatives]
  , Bool -> Bool
not (TyCon -> Bool
isTypeDataTyCon TyCon
tycon) -- Exception 2 in Note [Refine DEFAULT case alternatives]
  , Just [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 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 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, [Alt Id]
rest_alts)

       -- It matches exactly one constructor, so fill it in:
       [DataCon
con] -> (Bool
True, [Alt Id] -> [Alt Id] -> [Alt Id]
forall a. [Alt a] -> [Alt a] -> [Alt a]
mergeAlts [Alt Id]
rest_alts [AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (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
                ([Id]
ex_tvs, [Id]
arg_ids) = [Unique] -> Type -> DataCon -> [Type] -> ([Id], [Id])
dataConRepInstPat [Unique]
us Type
mult DataCon
con [Type]
tys

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

  | Bool
debugIsOn, TyCon -> Bool
isAlgTyCon TyCon
tycon, [DataCon] -> Bool
forall a. [a] -> 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, [Alt Id]
all_alts)

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

{- Note [Merge Nested Cases]
~~~~~~~~~~~~~~~~~~~~~~~~~
       case e of b {             ==>   case e of b {
         p1 -> rhs1                      p1 -> rhs1
         ...                             ...
         pm -> rhsm                      pm -> rhsm
         _  -> case b of b' {            pn -> let b'=b in rhsn
                     pn -> rhsn          ...
                     ...                 po -> let b'=b in rhso
                     po -> rhso          _  -> let b'=b in rhsd
                     _  -> rhsd
       }

which merges two cases in one case when -- the default alternative of
the outer case scrutinises the same variable as the outer case. This
transformation is called Case Merging.  It avoids that the same
variable is scrutinised multiple times.

Wrinkles

(MC1) Historical note. I tried making `mergeCaseAlts` "looks though" an inner
     single-alternative case-on-variable. For example
       case x of {
          ...outer-alts...
          DEFAULT -> case y of (a,b) ->
                     case x of { A -> rhs1; B -> rhs2 }
    ===>
       case x of
         ...outer-alts...
         a -> case y of (a,b) -> rhs1
         B -> case y of (a,b) -> rhs2

    This duplicates the `case y` but it removes the case x; so it is a win
    in terms of execution time (combining the cases on x) at the cost of
    perhaps duplicating the `case y`.  A case in point is integerEq, which
    is defined thus
        integerEq :: Integer -> Integer -> Bool
        integerEq !x !y = isTrue# (integerEq# x y)
    which becomes
        integerEq
          = \ (x :: Integer) (y_aAL :: Integer) ->
              case x of x1 { __DEFAULT ->
              case y of y1 { __DEFAULT ->
              case x1 of {
                IS x2 -> case y1 of {
                           __DEFAULT -> GHC.Types.False;
                           IS y2     -> tagToEnum# @Bool (==# x2 y2) };
                IP x2 -> ...
                IN x2 -> ...
    We want to merge the outer `case x` with the inner `case x1`.

    But (a) this is all a bit dubious: see #24251, and
        (b) it is hard to combine with (MC4)
    So I'm not doing this any more.  If we want to do it, we'll handle it
    separately: #24251.

    End of historical note

(MC2) The auxiliary bindings b'=b are annoying, because they force another
      simplifier pass, but there seems no easy way to avoid them.  See
      Note [Which transformations are innocuous] in GHC.Core.Opt.Stats.

(MC3) Consider
         case f x of (r::Int#) -> tagToEnum# r :: Bool
      `mergeCaseAlts` as a special case to treat this as if it was
         case f x of r ->
           case r of { 0# -> False; 1# -> True }
      which can be merged to
         case f x of { 0# -> False; 1# -> True }

      To see why this is important, return to
         case f x of (r::Int#) -> tagToEnum# r :: Bool
      and supppose `f` inlines to a case expression.  Then then we get
         let $j r = tagToEnum# r
         case .. of { .. jump $j 0#; ...jump $j 1# ... }
      Now if the entire expression is consumed by another case-expression,
      that outer case will only see (tagToEnum# r) which it can't do much
      with.  Whereas the result of the above case-merge generates much better
      code: no branching on Int#

(MC4) Consider
          case f x of r ->
            join $j y = <rhs> in
            case r of { ...alts ... }
      This is pretty common, and it a pity for it to defeat the case-merge
      transformation; and it makes the optimiser fragile to inlining decisions
      for join points.

      So `mergeCaseAlts` floats out any join points. It doesn't float out
      non-join-points unless the /outer/ case has just one alternative; doing
      so would risk more allocation

(MC5) See Note [Cascading case merge]

See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils


Note [Cascading case merge]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Case merging should cascade in one sweep, because the Simplifier tries it /after/
simplifying (and hence case-merging) the inner case.  For example

      case e of a {
        DEFAULT -> case a of b
                      DEFAULT -> case b of c {
                                     DEFAULT -> e
                                     A -> ea
                      B -> eb
        C -> ec
==> {simplify inner case}
      case e of a {
        DEFAULT -> case a of b
                      DEFAULT -> let c = b in e
                      A -> let c = b in ea
                      B -> eb
        C -> ec
==> {case-merge on outer case}
      case e of a {
        DEFAULT -> let b = a in let c = b in e
        A -> let b = a in let c = b in ea
        B -> let b = a in eb
        C -> ec


However here's a tricky case that we still don't catch, and I don't
see how to catch it in one pass:

  case x of c1 { I# a1 ->
  case a1 of c2 ->
    0 -> ...
    DEFAULT -> case x of c3 { I# a2 ->
               case a2 of ...

After occurrence analysis (and its binder-swap) we get this

  case x of c1 { I# a1 ->
  let x = c1 in         -- Binder-swap addition
  case a1 of c2 ->
    0 -> ...
    DEFAULT -> case x of c3 { I# a2 ->
               case a2 of ...

When we simplify the inner case x, we'll see that
x=c1=I# a1.  So we'll bind a2 to a1, and get

  case x of c1 { I# a1 ->
  case a1 of c2 ->
    0 -> ...
    DEFAULT -> case a1 of ...

This is correct, but we can't do a case merge in this sweep
because c2 /= a1.  Reason: the binding c1=I# a1 went inwards
without getting changed to c1=I# c2.

I don't think this is worth fixing, even if I knew how. It'll
all come out in the next pass anyway.


Note [Refine DEFAULT case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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 !_ -> ()
which rewrites to
    foo :: () -> ()
    foo x = case x of () -> ()

There are two reasons in general why replacing a DEFAULT alternative
with a specific constructor is desirable.

1. We can simplify inner expressions.  For example

       data Foo = Foo1 ()

       test :: Foo -> ()
       test x = case x of
                  DEFAULT -> 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. If we don't
   refine DEFAULT to `Foo ip1`, we are left with both case expressions.

2. combineIdenticalAlts does a better job. For example (Simon Jacobi)
       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.
   But 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 GHC.Core.Opt.Simplify.Utils then the
   `imposs_deflt_cons` argument is populated with constructors which
   are matched elsewhere.

There are two exceptions where we avoid refining a DEFAULT case:

* Exception 1: Newtypes

  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!

* Exception 2: `type data` declarations

  The data constructors for a `type data` declaration (see
  Note [Type data declarations] in GHC.Rename.Module) do not exist at the
  value level. Nevertheless, it is possible to strictly evaluate a value
  whose type is a `type data` declaration. Test case
  type-data/should_compile/T2294b.hs contains an example:

    type data T a where
      A :: T Int

    f :: T a -> ()
    f !x = ()

  We want to generate the following Core for f:

    f = \(@a) (x :: T a) ->
         case x of
           __DEFAULT -> ()

  Namely, we do _not_ want to match on `A`, as it doesn't exist at the value
  level! See wrinkle (W2b) in Note [Type data declarations] in GHC.Rename.Module


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!

Note [Combine identical alternatives: wrinkles]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

* It's important that we try to combine alternatives *before*
  simplifying them, rather than after. Reason: because
  Simplify.simplAlt may zap the occurrence info on the binders in the
  alternatives, which in turn defeats combineIdenticalAlts use of
  isDeadBinder (see #7360).

  You can see this in the call to combineIdenticalAlts in
  GHC.Core.Opt.Simplify.Utils.prepareAlts.  Here the alternatives have type InAlt
  (the "In" meaning input) rather than OutAlt.

* combineIdenticalAlts does not work well for nullary constructors
      case x of y
         []    -> f []
         (_:_) -> f y
  Here we won't see that [] and y are the same.  Sigh! This problem
  is solved in CSE, in GHC.Core.Opt.CSE.combineAlts, which does a better version
  of combineIdenticalAlts. But sadly it doesn't have the occurrence info we have
  here.
  See Note [Combine case alts: awkward corner] in GHC.Core.Opt.CSE).

Note [Care with impossible-constructors when combining alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have (#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 #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] -> [Alt Id] -> (Bool, [AltCon], [Alt Id])
combineIdenticalAlts [AltCon]
imposs_deflt_cons (Alt AltCon
con1 [Id]
bndrs1 CoreExpr
rhs1 : [Alt Id]
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 ([Alt Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
elim_rest) -- alternative comes first
  = (Bool
True, [AltCon]
imposs_deflt_cons', Alt Id
deflt_alt Alt Id -> [Alt Id] -> [Alt Id]
forall a. a -> [a] -> [a]
: [Alt Id]
filtered_rest)
  where
    ([Alt Id]
elim_rest, [Alt Id]
filtered_rest) = (Alt Id -> Bool) -> [Alt Id] -> ([Alt Id], [Alt Id])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Alt Id -> Bool
identical_to_alt1 [Alt Id]
rest_alts
    deflt_alt :: Alt Id
deflt_alt = AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] ([CoreTickish] -> CoreExpr -> CoreExpr
mkTicks ([[CoreTickish]] -> [CoreTickish]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CoreTickish]]
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]
++ (Alt Id -> AltCon) -> [Alt Id] -> [AltCon]
forall a b. (a -> b) -> [a] -> [b]
map (\(Alt AltCon
con [Id]
_ CoreExpr
_) -> AltCon
con) [Alt Id]
elim_rest
    elim_con1 :: [AltCon]
elim_con1 = case AltCon
con1 of     -- Don't forget con1!
                  AltCon
DEFAULT -> []
                  AltCon
_       -> [AltCon
con1]

    cheapEqTicked :: Expr b -> Expr b -> Bool
cheapEqTicked Expr b
e1 Expr b
e2 = (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
forall b. (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable Expr b
e1 Expr b
e2
    identical_to_alt1 :: Alt Id -> Bool
identical_to_alt1 (Alt AltCon
_con [Id]
bndrs CoreExpr
rhs)
      = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isDeadBinder [Id]
bndrs Bool -> Bool -> Bool
&& CoreExpr
rhs CoreExpr -> CoreExpr -> Bool
forall {b}. Expr b -> Expr b -> Bool
`cheapEqTicked` CoreExpr
rhs1
    tickss :: [[CoreTickish]]
tickss = (Alt Id -> [CoreTickish]) -> [Alt Id] -> [[CoreTickish]]
forall a b. (a -> b) -> [a] -> [b]
map (\(Alt AltCon
_ [Id]
_ CoreExpr
rhs) -> (CoreTickish -> Bool) -> CoreExpr -> [CoreTickish]
forall b. (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
stripTicksT CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable CoreExpr
rhs) [Alt Id]
elim_rest

combineIdenticalAlts [AltCon]
imposs_cons [Alt Id]
alts
  = (Bool
False, [AltCon]
imposs_cons, [Alt Id]
alts)

-- Scales the multiplicity of the binders of a list of case alternatives. That
-- is, in [C x1…xn -> u], the multiplicity of x1…xn is scaled.
scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt]
scaleAltsBy :: Type -> [Alt Id] -> [Alt Id]
scaleAltsBy Type
w [Alt Id]
alts = (Alt Id -> Alt Id) -> [Alt Id] -> [Alt Id]
forall a b. (a -> b) -> [a] -> [b]
map Alt Id -> Alt Id
scaleAlt [Alt Id]
alts
  where
    scaleAlt :: CoreAlt -> CoreAlt
    scaleAlt :: Alt Id -> Alt Id
scaleAlt (Alt AltCon
con [Id]
bndrs CoreExpr
rhs) = AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con ((Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
scaleBndr [Id]
bndrs) CoreExpr
rhs

    scaleBndr :: CoreBndr -> CoreBndr
    scaleBndr :: Id -> Id
scaleBndr Id
b = Type -> Id -> Id
scaleVarBy Type
w Id
b


{- *********************************************************************
*                                                                      *
             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 GHC.Core.

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 (#11155). So best to kill
it off at source.
-}

{-# INLINE trivial_expr_fold #-}
trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r
-- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr]
-- This is meant to have the code of both functions in one place and make it
-- easy to derive custom predicates.
--
-- (trivial_expr_fold k_id k_triv k_not_triv e)
-- * returns (k_id x) if `e` is a variable `x` (with trivial wrapping)
-- * returns (k_lit x) if `e` is a trivial literal `l` (with trivial wrapping)
-- * returns k_triv if `e` is a literal, type, or coercion (with trivial wrapping)
-- * returns k_not_triv otherwise
--
-- where "trivial wrapping" is
-- * Type application or abstraction
-- * Ticks other than `tickishIsCode`
-- * `case e of {}` an empty case
trivial_expr_fold :: forall r. (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r
trivial_expr_fold Id -> r
k_id Literal -> r
k_lit r
k_triv r
k_not_triv = CoreExpr -> r
go
  where
    -- If you change this function, be sure to change SetLevels.notWorthFloating
    -- as well!
    -- (Or yet better: Come up with a way to share code with this function.)
    go :: CoreExpr -> r
go (Var Id
v)                            = Id -> r
k_id Id
v  -- See Note [Variables are trivial]
    go (Lit Literal
l)    | Literal -> Bool
litIsTrivial Literal
l        = Literal -> r
k_lit Literal
l
    go (Type Type
_)                           = r
k_triv
    go (Coercion Coercion
_)                       = r
k_triv
    go (App CoreExpr
f CoreExpr
t)  | Bool -> Bool
not (CoreExpr -> Bool
isRuntimeArg CoreExpr
t)  = CoreExpr -> r
go CoreExpr
f
    go (Lam Id
b CoreExpr
e)  | Bool -> Bool
not (Id -> Bool
isRuntimeVar Id
b)  = CoreExpr -> r
go CoreExpr
e
    go (Tick CoreTickish
t CoreExpr
e) | Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) = CoreExpr -> r
go CoreExpr
e              -- See Note [Tick trivial]
    go (Cast CoreExpr
e Coercion
_)                         = CoreExpr -> r
go CoreExpr
e
    go (Case CoreExpr
e Id
b Type
_ [Alt Id]
as)
      | [Alt Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
as
      = CoreExpr -> r
go CoreExpr
e     -- See Note [Empty case is trivial]
      | Just CoreExpr
rhs <- CoreExpr -> Id -> [Alt Id] -> Maybe CoreExpr
isUnsafeEqualityCase CoreExpr
e Id
b [Alt Id]
as
      = CoreExpr -> r
go CoreExpr
rhs   -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
    go CoreExpr
_                                  = r
k_not_triv

exprIsTrivial :: CoreExpr -> Bool
exprIsTrivial :: CoreExpr -> Bool
exprIsTrivial CoreExpr
e = (Id -> Bool)
-> (Literal -> Bool) -> Bool -> Bool -> CoreExpr -> Bool
forall r. (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r
trivial_expr_fold (Bool -> Id -> Bool
forall a b. a -> b -> a
const Bool
True) (Bool -> Literal -> Bool
forall a b. a -> b -> a
const Bool
True) Bool
True Bool
False CoreExpr
e

{-
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
-- See Note [getIdFromTrivialExpr]
getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id
getIdFromTrivialExpr CoreExpr
e = (Id -> Id) -> (Literal -> Id) -> Id -> Id -> CoreExpr -> Id
forall r. (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r
trivial_expr_fold Id -> Id
forall a. a -> a
id (Id -> Literal -> Id
forall a b. a -> b -> a
const Id
panic) Id
panic Id
panic CoreExpr
e
  where
    panic :: Id
panic = String -> SDoc -> Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getIdFromTrivialExpr" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)

getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id
getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id
getIdFromTrivialExpr_maybe CoreExpr
e = (Id -> Maybe Id)
-> (Literal -> Maybe Id)
-> Maybe Id
-> Maybe Id
-> CoreExpr
-> Maybe Id
forall r. (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r
trivial_expr_fold Id -> Maybe Id
forall a. a -> Maybe a
Just (Maybe Id -> Literal -> Maybe Id
forall a b. a -> b -> a
const Maybe Id
forall a. Maybe a
Nothing) Maybe Id
forall a. Maybe a
Nothing Maybe Id
forall a. Maybe a
Nothing CoreExpr
e

{- *********************************************************************
*                                                                      *
             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 :: Platform -> CoreExpr -> Bool
exprIsDupable :: Platform -> CoreExpr -> Bool
exprIsDupable Platform
platform 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 Int
n (Type {})     = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
    go Int
n (Coercion {}) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
    go Int
n (Var {})      = Int -> Maybe Int
decrement Int
n
    go Int
n (Tick CoreTickish
_ CoreExpr
e)    = Int -> CoreExpr -> Maybe Int
go Int
n CoreExpr
e
    go Int
n (Cast CoreExpr
e Coercion
_)    = Int -> CoreExpr -> Maybe Int
go Int
n CoreExpr
e
    go Int
n (App CoreExpr
f CoreExpr
a) | Just Int
n' <- Int -> CoreExpr -> Maybe Int
go Int
n CoreExpr
a = Int -> CoreExpr -> Maybe Int
go Int
n' CoreExpr
f
    go Int
n (Lit Literal
lit) | Platform -> Literal -> Bool
litIsDupable Platform
platform Literal
lit = Int -> Maybe Int
decrement Int
n
    go Int
_ CoreExpr
_ = Maybe Int
forall a. Maybe a
Nothing

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

dupAppSize :: Int
dupAppSize :: Int
dupAppSize = Int
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 #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 (#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 exprIsWorkFree and lone variables] in GHC.Core.Unfold

@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 CoreExpr
e = CheapAppFun -> CoreExpr -> Bool
exprIsCheapX CheapAppFun
isWorkFreeApp CoreExpr
e

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

exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool
{-# INLINE exprIsCheapX #-}
-- allow specialization of exprIsCheap and exprIsWorkFree
-- instead of having an unknown call to ok_app
exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool
exprIsCheapX CheapAppFun
ok_app CoreExpr
e
  = CoreExpr -> Bool
ok CoreExpr
e
  where
    ok :: CoreExpr -> Bool
ok CoreExpr
e = Int -> CoreExpr -> Bool
go Int
0 CoreExpr
e

    -- n is the number of value arguments
    go :: Int -> CoreExpr -> Bool
go Int
n (Var Id
v)                      = CheapAppFun
ok_app Id
v Int
n
    go Int
_ (Lit {})                     = Bool
True
    go Int
_ (Type {})                    = Bool
True
    go Int
_ (Coercion {})                = Bool
True
    go Int
n (Cast CoreExpr
e Coercion
_)                   = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
    go Int
n (Case CoreExpr
scrut Id
_ Type
_ [Alt Id]
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 | Alt AltCon
_ [Id]
_ CoreExpr
rhs <- [Alt Id]
alts ]
    go Int
n (Tick CoreTickish
t CoreExpr
e) | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
t = Bool
False
                    | Bool
otherwise       = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
    go Int
n (Lam Id
x CoreExpr
e)  | Id -> Bool
isRuntimeVar Id
x  = Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 Bool -> Bool -> Bool
|| Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) CoreExpr
e
                    | Bool
otherwise       = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e
    go Int
n (App CoreExpr
f CoreExpr
e)  | CoreExpr -> Bool
isRuntimeArg CoreExpr
e  = Int -> CoreExpr -> Bool
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) CoreExpr
f Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
e
                    | Bool
otherwise       = Int -> CoreExpr -> Bool
go Int
n CoreExpr
f
    go Int
n (Let (NonRec Id
_ CoreExpr
r) CoreExpr
e)         = Int -> CoreExpr -> Bool
go Int
n CoreExpr
e Bool -> Bool -> Bool
&& CoreExpr -> Bool
ok CoreExpr
r
    go Int
n (Let (Rec [(Id, CoreExpr)]
prs) 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 GHC.Core.Unfold),
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 GHC.Types.Basic.
  (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 #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 CoreExpr
e
  = CoreExpr -> Bool
ok CoreExpr
e
  where
    ok :: CoreExpr -> Bool
ok CoreExpr
e = Int -> CoreExpr -> Bool
go Int
0 CoreExpr
e

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

isWorkFreeApp :: CheapAppFun
isWorkFreeApp :: CheapAppFun
isWorkFreeApp Id
fn Int
n_val_args
  | Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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
      PrimOpId PrimOp
op ConcreteTyVars
_    -> PrimOp -> Bool
primOpIsWorkFree PrimOp
op
      IdDetails
_                -> Bool
False

isCheapApp :: CheapAppFun
isCheapApp :: CheapAppFun
isCheapApp Id
fn Int
n_val_args
  | CheapAppFun
isWorkFreeApp Id
fn Int
n_val_args = Bool
True
  | Id -> Bool
isDeadEndId 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
== Int
1  -- See Note [Record selection]
      ClassOpId {}     -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
      PrimOpId PrimOp
op ConcreteTyVars
_    -> PrimOp -> Bool
primOpIsCheap PrimOp
op
      IdDetails
_                -> 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 Id
fn Int
n_val_args
  | CheapAppFun
isWorkFreeApp Id
fn Int
n_val_args = Bool
True
  | Bool
otherwise
  = case Id -> IdDetails
idDetails Id
fn of
      RecSelId {}  -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1  -- See Note [Record selection]
      ClassOpId {} -> Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
      PrimOpId {}  -> Bool
False
      IdDetails
_ | Id -> Bool
isDeadEndId Id
fn     -> Bool
False
          -- See Note [isExpandableApp: bottoming functions]
        | Id -> Bool
isConLikeId 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 {t}. (Eq t, Num t) => t -> Type -> Bool
all_pred_args Int
n_val_args (Id -> Type
idType Id
fn)

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

       | Just (PiTyBinder
bndr, Type
ty) <- Type -> Maybe (PiTyBinder, Type)
splitPiTy_maybe Type
ty
       = case PiTyBinder
bndr of
           Named {}  -> t -> Type -> Bool
all_pred_args t
n_val_args Type
ty
           Anon Scaled Type
_ FunTyFlag
af -> FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af Bool -> Bool -> Bool
&& t -> Type -> Bool
all_pred_args (t
n_val_argst -> t -> t
forall a. Num a => a -> a -> a
-t
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))....
They'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
*                                                                      *
************************************************************************
-}

-----------------------------
-- | To a first approximation, 'exprOkForSpeculation' returns True of
-- an expression that is:
--
--  * Safe to evaluate even if normal order eval might not
--    evaluate the expression at all, and
--
--  * Safe /not/ to evaluate even if normal order would do so
--
-- More specifically, this means that:
--  * A: Evaluation of the expression reaches weak-head-normal-form,
--  * B: soon,
--  * C: without causing a write side effect (e.g. writing a mutable variable).
--
-- In particular, an expression that may
--  * throw a synchronous Haskell exception, or
--  * risk an unchecked runtime exception (e.g. array
--    out of bounds, divide by zero)
-- is /not/ considered OK-for-speculation, as these violate condition A.
--
-- For 'exprOkToDiscard', condition A is weakened to allow expressions
-- that might risk an unchecked runtime exception but must otherwise
-- reach weak-head-normal-form.
-- (Note that 'exprOkForSpeculation' implies 'exprOkToDiscard')
--
-- But in fact both functions are a bit more conservative than the above,
-- in at least the following ways:
--
--  * W1: We do not take advantage of already-evaluated lifted variables.
--        As a result, 'exprIsHNF' DOES NOT imply 'exprOkForSpeculation';
--        if @y@ is a case-binder of lifted type, then @exprIsHNF y@ is
--        'True', while @exprOkForSpeculation y@ is 'False'.
--        See Note [exprOkForSpeculation and evaluated variables] for why.
--  * W2: Read-effects on mutable variables are currently also included.
--        See Note [Classifying primop effects] "GHC.Builtin.PrimOps".
--  * W3: Currently, 'exprOkForSpeculation' always returns 'False' for
--        let-expressions.  Lets can be stacked deeply, so we just give up.
--        In any case, the argument of 'exprOkForSpeculation' is usually in
--        a strict context, so any lets will have been floated away.
--
--
-- 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.
--
--
-- See also Note [Classifying primop effects] in "GHC.Builtin.PrimOps"
-- and Note [Transformations affected by primop effects].
--
-- 'exprOkForSpeculation' is used to define Core's let-can-float
-- invariant.  (See Note [Core let-can-float invariant] in
-- "GHC.Core".)  It is therefore frequently called on arguments of
-- unlifted type, especially via 'needsCaseBinding'.  But it is
-- sometimes called on expressions of lifted type as well.  For
-- example, see Note [Speculative evaluation] in "GHC.CoreToStg.Prep".


exprOkForSpeculation, exprOkToDiscard :: CoreExpr -> Bool
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation = (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_always_ok PrimOp -> Bool
primOpOkForSpeculation
exprOkToDiscard :: CoreExpr -> Bool
exprOkToDiscard      = (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_always_ok PrimOp -> Bool
primOpOkToDiscard

fun_always_ok :: Id -> Bool
fun_always_ok :: Id -> Bool
fun_always_ok Id
_ = Bool
True

-- | A special version of 'exprOkForSpeculation' used during
-- Note [Speculative evaluation]. When the predicate arg `fun_ok` returns False
-- for `b`, then `b` is never considered ok-for-spec.
exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool
exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool
exprOkForSpecEval Id -> Bool
fun_ok = (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primOpOkForSpeculation

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

expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok (Var Id
v)    = (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok Id
v []
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok (Cast CoreExpr
e Coercion
_) = (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok CoreExpr
e
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok (Lam Id
b CoreExpr
e)
                 | Id -> Bool
isTyVar Id
b = (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_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 Id -> Bool
fun_ok PrimOp -> Bool
primop_ok (Tick CoreTickish
tickish CoreExpr
e)
   | CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
tickish = Bool
False
   | Bool
otherwise             = (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok CoreExpr
e

expr_ok Id -> Bool
_ PrimOp -> Bool
_ (Let {}) = Bool
False
-- See W3 in the Haddock comment for exprOkForSpeculation

expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok (Case CoreExpr
scrut Id
bndr Type
_ [Alt Id]
alts)
  =  -- See Note [exprOkForSpeculation: case expressions]
     (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok CoreExpr
scrut
  Bool -> Bool -> Bool
&& HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
bndr)
      -- OK to call isUnliftedType: binders always have a fixed RuntimeRep
  Bool -> Bool -> Bool
&& (Alt Id -> Bool) -> [Alt Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Alt AltCon
_ [Id]
_ CoreExpr
rhs) -> (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok CoreExpr
rhs) [Alt Id]
alts
  Bool -> Bool -> Bool
&& [Alt Id] -> Bool
forall b. [Alt b] -> Bool
altsAreExhaustive [Alt Id]
alts

expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok CoreExpr
other_expr
  | (CoreExpr
expr, [CoreExpr]
args) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
other_expr
  = case (CoreTickish -> Bool) -> CoreExpr -> CoreExpr
forall b. (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksTopE (Bool -> Bool
not (Bool -> Bool) -> (CoreTickish -> Bool) -> CoreTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts) CoreExpr
expr of
        Var Id
f ->
           (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok Id -> Bool
fun_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).
        -- See Note [How a rubbish literal can be the head of an application]
        -- in GHC.Types.Literal
        Lit Literal
lit | Bool
debugIsOn, Bool -> Bool
not (Literal -> Bool
isLitRubbish Literal
lit)
                 -> String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Non-rubbish lit in app head" (Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
lit)
                 | Bool
otherwise
                 -> Bool
True

        CoreExpr
_ -> Bool
False

-----------------------------
app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
app_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok Id
fun [CoreExpr]
args
  | Bool -> Bool
not (Id -> Bool
fun_ok Id
fun)
  = Bool
False -- This code path is only taken for Note [Speculative evaluation]

  | Id -> Int
idArity Id
fun Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n_val_args
  -- Partial application: just check passing the arguments is OK
  = Bool
args_ok

  | Bool
otherwise
  = case Id -> IdDetails
idDetails Id
fun of
      DFunId 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
args_ok
                -- The strictness of the constructor has already
                -- been expressed by its "wrapper", so we don't need
                -- to take the arguments into account
                   -- Well, we thought so.  But it's definitely wrong!
                   -- See #20749 and Note [How untagged pointers can
                   -- end up in strict fields] in GHC.Stg.InferTags

      ClassOpId Class
_ Bool
is_terminating_result
        | Bool
is_terminating_result -- See Note [exprOkForSpeculation and type classes]
        -> Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fun SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
           Bool
True
           -- assert: terminating result type => can't be applied;
           -- c.f the _other case below

      PrimOpId PrimOp
op ConcreteTyVars
_
        | PrimOp -> Bool
primOpIsDiv PrimOp
op
        , Lit Literal
divisor <- [CoreExpr] -> CoreExpr
forall a. HasCallStack => [a] -> a
last [CoreExpr]
args
            -- there can be 2 args (most div primops) or 3 args
            -- (WordQuotRem2Op), hence the use of last/init
        -> Bool -> Bool
not (Literal -> Bool
isZeroLit Literal
divisor) Bool -> Bool -> Bool
&& (CoreExpr -> Bool) -> [CoreExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok) ([CoreExpr] -> [CoreExpr]
forall a. HasCallStack => [a] -> [a]
init [CoreExpr]
args)
              -- 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

        | Bool
otherwise -> PrimOp -> Bool
primop_ok PrimOp
op Bool -> Bool -> Bool
&& Bool
args_ok

      IdDetails
_other  -- Unlifted and terminating types;
              -- Also c.f. the Var case of exprIsHNF
         |  HasDebugCallStack => Type -> Bool
Type -> Bool
isTerminatingType Type
fun_ty  -- See Note [exprOkForSpeculation and type classes]
         Bool -> Bool -> Bool
|| Type -> Bool
definitelyUnliftedType Type
fun_ty
         -> Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fun SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args)
            Bool
True  -- Both terminating types (e.g. Eq a), and unlifted types (e.g. Int#)
                  -- are non-functions and so will have no value args.  The assert is
                  -- just to check this.
                  -- (If we added unlifted function types this would change,
                  -- and we'd need to actually test n_val_args == 0.)

         -- Functions that terminate fast without raising exceptions etc
         -- See (U12) of Note [Implementing unsafeCoerce]
         | Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unsafeEqualityProofIdKey -> Bool
True

         | Bool
otherwise -> Bool
False
             -- NB: even in the nullary case, do /not/ check
             --     for evaluated-ness of the fun;
             --     see Note [exprOkForSpeculation and evaluated variables]
  where
    fun_ty :: Type
fun_ty       = Id -> Type
idType Id
fun
    n_val_args :: Int
n_val_args   = [CoreExpr] -> Int
forall b. [Arg b] -> Int
valArgCount [CoreExpr]
args
    ([PiTyBinder]
arg_tys, Type
_) = Type -> ([PiTyBinder], Type)
splitPiTys Type
fun_ty

    -- Even if a function call itself is OK, any unlifted
    -- args are still evaluated eagerly and must be checked
    args_ok :: Bool
args_ok = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((PiTyBinder -> CoreExpr -> Bool)
-> [PiTyBinder] -> [CoreExpr] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith PiTyBinder -> CoreExpr -> Bool
arg_ok [PiTyBinder]
arg_tys [CoreExpr]
args)
    arg_ok :: PiTyVarBinder -> CoreExpr -> Bool
    arg_ok :: PiTyBinder -> CoreExpr -> Bool
arg_ok (Named ForAllTyBinder
_) CoreExpr
_ = Bool
True   -- A type argument
    arg_ok (Anon Scaled Type
ty FunTyFlag
_) CoreExpr
arg      -- A term argument
       | Type -> Bool
definitelyLiftedType (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
ty)
       = Bool
True -- lifted args are not evaluated eagerly
       | Bool
otherwise
       = (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool
expr_ok Id -> Bool
fun_ok PrimOp -> Bool
primop_ok CoreExpr
arg

-----------------------------
altsAreExhaustive :: [Alt b] -> Bool
-- True  <=> the case alternatives are definitely exhaustive
-- False <=> they may or may not be
altsAreExhaustive :: forall b. [Alt b] -> Bool
altsAreExhaustive []
  = Bool
True    -- The scrutinee never returns; see Note [Empty case alternatives] in GHC.Core
altsAreExhaustive (Alt AltCon
con1 [b]
_ Expr b
_ : [Alt b]
alts)
  = case AltCon
con1 of
      AltCon
DEFAULT   -> Bool
True
      LitAlt {} -> Bool
False
      DataAlt 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
- Int
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

-- | Should we look past this tick when eta-expanding the given function?
--
-- See Note [Ticks and mandatory eta expansion]
-- Takes the function we are applying as argument.
etaExpansionTick :: Id -> GenTickish pass -> Bool
etaExpansionTick :: forall (pass :: TickishPass). Id -> GenTickish pass -> Bool
etaExpansionTick Id
id GenTickish pass
t
  = Id -> Bool
hasNoBinding Id
id Bool -> Bool -> Bool
&&
    ( GenTickish pass -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable GenTickish pass
t Bool -> Bool -> Bool
|| GenTickish pass -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
isProfTick GenTickish pass
t )

{- Note [exprOkForSpeculation and type classes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (#22745, #15205)

  \(d :: C a b). case eq_sel (sc_sel d) of
                   (co :: t1 ~# t2) [Dead] ->  blah

We know that
* eq_sel's argument (sc_sel d) has dictionary type, so it definitely terminates
  (again Note [NON-BOTTOM-DICTS invariant] in GHC.Core)
* eq_sel is simply a superclass selector, and hence is fast
* The field that eq_sel picks is of unlifted type, and hence can't be bottom
  (remember the dictionary argument itself is non-bottom)

So we can treat (eq_sel (sc_sel d)) as ok-for-speculation.  We must check

a) That the function is a class-op, with IdDetails of ClassOpId

b) That the result type of the class-op is terminating or unlifted.  E.g. for
     class C a => D a where ...
     class C a where { op :: a -> a }
   Since C is represented by a newtype, (sc_sel (d :: D a)) might
   not be terminating.

Rather than repeatedly test if the result of the class-op is a
terminating/unlifted type, we cache it as a field of ClassOpId. See
GHC.Types.Id.Make.mkDictSelId for where this field is initialised.

Note [exprOkForSpeculation: case expressions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
exprOkForSpeculation accepts very special case expressions.
Reason: (a ==# b) is ok-for-speculation, but the litEq rules
in GHC.Core.Opt.ConstantFold convert it (a ==# 3#) to
   case a of { DEFAULT -> 0#; 3# -> 1# }
for excellent reasons described in
  GHC.Core.Opt.ConstantFold 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-can-float invariant?  Previously we said
  yes, on the grounds that y is evaluated.  But the binder-swap done
  by GHC.Core.Opt.SetLevels would transform the inner alternative to
     DEFAULT -> ... (let v::Int# = case x of { ... }
                     in ...) ....
  which does /not/ satisfy the let-can-float invariant, because x is
  not evaluated. See Note [Binder-swap during float-out]
  in GHC.Core.Opt.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: #15696: --------
  Previously GHC.Core.Opt.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 GHC.Core.Opt.SetLevels considers the inner nested case as
  ok-for-speculation it can do case-floating (in GHC.Core.Opt.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 #5453.

----- Historical note: #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 [exprOkForSpeculation and evaluated variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider these examples:
 * case x of y { DEFAULT -> ....y.... }
   Should 'y' (alone) be considered ok-for-speculation?

 * case x of y { DEFAULT -> ....let z = dataToTagLarge# y... }
   Should (dataToTagLarge# y) be considered ok-for-spec? Recall that
     dataToTagLarge# :: forall a. a -> Int#
   must always evaluate its argument. (See also Note [DataToTag overview].)

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 -> ....let z = dataToTagLarge# x... }

And now the expression does not obey the let-can-float invariant!  Yikes!
Moreover we really might float (dataToTagLarge# x) outside the case,
and then it really, really doesn't obey the let-can-float 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 primops that perform evaluation.  We achieve the latter
by marking the relevant primops as "ThrowsException" or
"ReadWriteEffect"; see also Note [Classifying primop effects] in
GHC.Builtin.PrimOps.

Note that exprIsHNF /can/ and does take advantage of evaluated-ness;
it doesn't have the trickiness of the let-can-float 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 perform case-to-let for lifted expressions, which changes:
--
-- > case x of x' { _ -> e }
--
--    into:
--
-- > let x' = x in e
--
-- and in so doing makes the binding lazy.
--
-- 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.
-- We check for this using needsCaseBinding below
exprIsHNF :: CoreExpr -> Bool           -- True => Value-lambda, constructor, PAP
exprIsHNF :: CoreExpr -> Bool
exprIsHNF = HasDebugCallStack =>
(Id -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
(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 = HasDebugCallStack =>
(Id -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
(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 :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike :: HasDebugCallStack =>
(Id -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
exprIsHNFlike Id -> Bool
is_con Unfolding -> Bool
is_con_unf = CoreExpr -> Bool
is_hnf_like
  where
    is_hnf_like :: CoreExpr -> Bool
is_hnf_like (Var Id
v) -- NB: There are no value args at this point
      =  CheapAppFun
id_app_is_value Id
v Int
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 (IdUnfoldingFun
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

      Bool -> Bool -> Bool
|| Type -> Bool
definitelyUnliftedType (Id -> Type
idType Id
v)
        -- Unlifted binders are always evaluated (#20140)

    is_hnf_like (Lit Literal
l)          = Bool -> Bool
not (Literal -> Bool
isLitRubbish Literal
l)
        -- Regarding a LitRubbish as ConLike leads to unproductive inlining in
        -- WWRec, see #20035
    is_hnf_like (Type Type
_)         = Bool
True       -- Types are honorary Values;
                                              -- we don't mind copying them
    is_hnf_like (Coercion Coercion
_)     = Bool
True       -- Same for coercions
    is_hnf_like (Lam Id
b CoreExpr
e)        = Id -> Bool
isRuntimeVar Id
b Bool -> Bool -> Bool
|| CoreExpr -> Bool
is_hnf_like CoreExpr
e
    is_hnf_like (Tick CoreTickish
tickish CoreExpr
e) = Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishCounts CoreTickish
tickish)
                                   Bool -> Bool -> Bool
&& CoreExpr -> Bool
is_hnf_like CoreExpr
e
                                      -- See Note [exprIsHNF Tick]
    is_hnf_like (Cast CoreExpr
e Coercion
_)       = CoreExpr -> Bool
is_hnf_like CoreExpr
e
    is_hnf_like (App CoreExpr
e CoreExpr
a)
      | CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg CoreExpr
a               = CoreExpr -> Int -> Bool
app_is_value CoreExpr
e Int
1
      | Bool
otherwise                = CoreExpr -> Bool
is_hnf_like CoreExpr
e
    is_hnf_like (Let Bind Id
_ CoreExpr
e)        = CoreExpr -> Bool
is_hnf_like CoreExpr
e  -- Lazy let(rec)s don't affect us
    is_hnf_like (Case CoreExpr
e Id
b Type
_ [Alt Id]
as)
      | Just CoreExpr
rhs <- CoreExpr -> Id -> [Alt Id] -> Maybe CoreExpr
isUnsafeEqualityCase CoreExpr
e Id
b [Alt Id]
as
      = CoreExpr -> Bool
is_hnf_like CoreExpr
rhs
    is_hnf_like CoreExpr
_                = 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 Id
f)    Int
nva = CheapAppFun
id_app_is_value Id
f Int
nva
    app_is_value (Tick CoreTickish
_ CoreExpr
f) Int
nva = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f Int
nva
    app_is_value (Cast CoreExpr
f Coercion
_) Int
nva = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f Int
nva
    app_is_value (App CoreExpr
f CoreExpr
a)  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
+ Int
1) Bool -> Bool -> Bool
&&
        Bool -> Bool
not (HasDebugCallStack => Type -> CoreExpr -> Bool
Type -> CoreExpr -> Bool
needsCaseBinding (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
a) CoreExpr
a)
          -- For example  f (x /# y)  where f has arity two, and the first
          -- argument is unboxed. This is not a value!
          -- But  f 34#  is a value.
          -- NB: Check app_is_value first, the arity check is cheaper
      | Bool
otherwise               = CoreExpr -> Int -> Bool
app_is_value CoreExpr
f Int
nva
    app_is_value CoreExpr
_          Int
_   = Bool
False

    id_app_is_value :: CheapAppFun
id_app_is_value Id
id 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

{-
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 [Core top-level string literals]
-- Precondition: exprType expr = ty
-- Top-level literal strings can't even be wrapped in ticks
--   see Note [Core top-level string literals] in "GHC.Core"
exprIsTopLevelBindable :: CoreExpr -> Type -> Bool
exprIsTopLevelBindable CoreExpr
expr Type
ty
  = Bool -> Bool
not (Type -> Bool
mightBeUnliftedType Type
ty)
    -- Note that 'expr' may not have a fixed runtime representation here,
    -- consequently we must use 'mightBeUnliftedType' rather than 'isUnliftedType',
    -- as the latter would panic.
  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 ByteString
bs)) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs
exprIsTickedString_maybe (Tick CoreTickish
t CoreExpr
e)
  -- we don't tick literals with CostCentre ticks, compare to mkTick
  | CoreTickish -> TickishPlacement
forall (pass :: TickishPass). GenTickish pass -> TickishPlacement
tickishPlace CoreTickish
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 CoreExpr
_ = Maybe ByteString
forall a. Maybe a
Nothing

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

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

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

dataConRepInstPat :: [Unique] -> Type -> DataCon -> [Type] -> ([Id], [Id])
dataConRepInstPat   = [FastString]
-> [Unique] -> Type -> DataCon -> [Type] -> ([Id], [Id])
dataConInstPat (FastString -> [FastString]
forall a. a -> [a]
repeat ((String -> FastString
fsLit String
"ipv")))
dataConRepFSInstPat :: [FastString]
-> [Unique] -> Type -> DataCon -> [Type] -> ([Id], [Id])
dataConRepFSInstPat = [FastString]
-> [Unique] -> Type -> 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
               -> Mult                  -- The multiplicity annotation of the case expression: scales the multiplicity of variables
               -> DataCon
               -> [Type]                -- Types to instantiate the universally quantified tyvars
               -> ([TyCoVar], [Id])     -- Return instantiated variables
-- dataConInstPat arg_fun fss us mult 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 intended 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] -> Type -> DataCon -> [Type] -> ([Id], [Id])
dataConInstPat [FastString]
fss [Unique]
uniqs Type
mult DataCon
con [Type]
inst_tys
  = Bool -> ([Id], [Id]) -> ([Id], [Id])
forall a. HasCallStack => Bool -> a -> a
assert ([Id]
univ_tvs [Id] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Type]
inst_tys) (([Id], [Id]) -> ([Id], [Id])) -> ([Id], [Id]) -> ([Id], [Id])
forall a b. (a -> b) -> a -> b
$
    ([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 :: [Scaled Type]
arg_tys  = DataCon -> [Scaled 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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
ex_tvs

      -- split the Uniques and FastStrings
    ([Unique]
ex_uniqs, [Unique]
id_uniqs) = Int -> [Unique] -> ([Unique], [Unique])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_ex [Unique]
uniqs
    ([FastString]
ex_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 :: Subst
univ_subst = [Id] -> [Type] -> Subst
HasDebugCallStack => [Id] -> [Type] -> Subst
zipTvSubst [Id]
univ_tvs [Type]
inst_tys

      -- Make existential type variables, applying and extending the substitution
    (Subst
full_subst, [Id]
ex_bndrs) = (Subst -> (Id, FastString, Unique) -> (Subst, Id))
-> Subst -> [(Id, FastString, Unique)] -> (Subst, [Id])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Subst -> (Id, FastString, Unique) -> (Subst, Id)
mk_ex_var Subst
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 :: Subst -> (TyCoVar, FastString, Unique) -> (Subst, TyCoVar)
    mk_ex_var :: Subst -> (Id, FastString, Unique) -> (Subst, Id)
mk_ex_var Subst
subst (Id
tv, FastString
fs, Unique
uniq) = (Subst -> Id -> Id -> Subst
Type.extendTCvSubstWithClone Subst
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   = Subst -> Type -> Type
Type.substTyUnchecked Subst
subst (Id -> Type
varType Id
tv)

      -- Make value vars, instantiating types
    arg_ids :: [Id]
arg_ids = (Unique -> FastString -> Scaled Type -> StrictnessMark -> Id)
-> [Unique]
-> [FastString]
-> [Scaled Type]
-> [StrictnessMark]
-> [Id]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 Unique -> FastString -> Scaled Type -> StrictnessMark -> Id
mk_id_var [Unique]
id_uniqs [FastString]
id_fss [Scaled Type]
arg_tys [StrictnessMark]
arg_strs
    mk_id_var :: Unique -> FastString -> Scaled Type -> StrictnessMark -> Id
mk_id_var Unique
uniq FastString
fs (Scaled Type
m Type
ty) StrictnessMark
str
      = StrictnessMark -> Id -> Id
setCaseBndrEvald StrictnessMark
str (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$  -- See Note [Mark evaluated arguments]
        OccName -> Unique -> Type -> Type -> SrcSpan -> Id
mkUserLocalOrCoVar (FastString -> OccName
mkVarOccFS FastString
fs) Unique
uniq
                           (Type
mult Type -> Type -> Type
`mkMultMul` Type
m) (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
Type.substTy Subst
full_subst Type
ty) 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 GHC.Core.Opt.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.
cheapEqExpr :: Expr b -> Expr b -> Bool
cheapEqExpr :: forall {b}. Expr b -> Expr b -> Bool
cheapEqExpr = (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
forall b. (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' (Bool -> CoreTickish -> Bool
forall a b. a -> b -> a
const Bool
False)

-- | Cheap expression equality test, can ignore ticks by type.
cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
{-# INLINE cheapEqExpr' #-}
cheapEqExpr' :: forall b. (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool
cheapEqExpr' CoreTickish -> Bool
ignoreTick Expr b
e1 Expr b
e2
  = Expr b -> Expr b -> Bool
go Expr b
e1 Expr b
e2
  where
    go :: Expr b -> Expr b -> Bool
go (Var Id
v1)   (Var Id
v2)         = Id
v1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v2
    go (Lit Literal
lit1) (Lit Literal
lit2)       = Literal
lit1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit2
    go (Type Type
t1)  (Type Type
t2)        = Type
t1 HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
t2
    go (Coercion Coercion
c1) (Coercion Coercion
c2) = Coercion
c1 Coercion -> Coercion -> Bool
`eqCoercion` Coercion
c2
    go (App Expr b
f1 Expr b
a1) (App Expr b
f2 Expr b
a2)     = Expr b
f1 Expr b -> Expr b -> Bool
`go` Expr b
f2 Bool -> Bool -> Bool
&& Expr b
a1 Expr b -> Expr b -> Bool
`go` Expr b
a2
    go (Cast Expr b
e1 Coercion
t1) (Cast Expr b
e2 Coercion
t2)   = Expr b
e1 Expr b -> Expr b -> Bool
`go` Expr b
e2 Bool -> Bool -> Bool
&& Coercion
t1 Coercion -> Coercion -> Bool
`eqCoercion` Coercion
t2

    go (Tick CoreTickish
t1 Expr b
e1) Expr b
e2 | CoreTickish -> Bool
ignoreTick CoreTickish
t1 = Expr b -> Expr b -> Bool
go Expr b
e1 Expr b
e2
    go Expr b
e1 (Tick CoreTickish
t2 Expr b
e2) | CoreTickish -> Bool
ignoreTick CoreTickish
t2 = Expr b -> Expr b -> Bool
go Expr b
e1 Expr b
e2
    go (Tick CoreTickish
t1 Expr b
e1) (Tick CoreTickish
t2 Expr b
e2) = CoreTickish
t1 CoreTickish -> CoreTickish -> Bool
forall a. Eq a => a -> a -> Bool
== CoreTickish
t2 Bool -> Bool -> Bool
&& Expr b
e1 Expr b -> Expr b -> Bool
`go` Expr b
e2

    go Expr b
_ Expr b
_ = Bool
False



-- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots
eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish RnEnv2
env (Breakpoint XBreakpoint 'TickishPassCore
lext Int
lid [XTickishId 'TickishPassCore]
lids Module
lmod) (Breakpoint XBreakpoint 'TickishPassCore
rext Int
rid [XTickishId 'TickishPassCore]
rids Module
rmod)
      = 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]
[XTickishId 'TickishPassCore]
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]
[XTickishId 'TickishPassCore]
rids Bool -> Bool -> Bool
&&
        NoExtField
XBreakpoint 'TickishPassCore
lext NoExtField -> NoExtField -> Bool
forall a. Eq a => a -> a -> Bool
== NoExtField
XBreakpoint 'TickishPassCore
rext Bool -> Bool -> Bool
&&
        Module
lmod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
rmod
eqTickish RnEnv2
_ CoreTickish
l CoreTickish
r = CoreTickish
l CoreTickish -> CoreTickish -> Bool
forall a. Eq a => a -> a -> Bool
== CoreTickish
r

-- | 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.
--
-- Only used in GHC.Core.Lint.lintAnnots
diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
          -> ([SDoc], RnEnv2)
diffBinds :: Bool
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
diffBinds Bool
top RnEnv2
env [(Id, CoreExpr)]
binds1 = Int
-> RnEnv2
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
-> ([SDoc], RnEnv2)
go ([(Id, CoreExpr)] -> Int
forall a. [a] -> 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 Int
_    RnEnv2
env []     []
          = ([], RnEnv2
env)
       go Int
_fuel RnEnv2
env [] [(Id, CoreExpr)]
binds2
          -- No binds remaining to compare on the left? Bail out early.
          = (RnEnv2 -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [SDoc]
warn RnEnv2
env [] [(Id, CoreExpr)]
binds2, RnEnv2
env)
       go Int
_fuel RnEnv2
env [(Id, CoreExpr)]
binds1 []
          -- No binds remaining to compare on the right? Bail out early.
          = (RnEnv2 -> [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [SDoc]
warn RnEnv2
env [(Id, CoreExpr)]
binds1 [], RnEnv2
env)
       go Int
fuel RnEnv2
env binds1 :: [(Id, CoreExpr)]
binds1@((Id, CoreExpr)
bind1:[(Id, CoreExpr)]
_) binds2 :: [(Id, CoreExpr)]
binds2@((Id, CoreExpr)
_:[(Id, CoreExpr)]
_)
          -- 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
== Int
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)
bind1
            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 a. [a] -> 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 Int
fuel RnEnv2
env ((Id
bndr1,CoreExpr
expr1):[(Id, CoreExpr)]
binds1) [(Id, CoreExpr)]
binds2
          | let matchExpr :: (Id, CoreExpr) -> Bool
matchExpr (Id
bndr,CoreExpr
expr) =
                  (Id -> Bool
isTyVar Id
bndr Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
top Bool -> Bool -> Bool
|| [SDoc] -> Bool
forall a. [a] -> 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 a. [a] -> 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)

          , ([(Id, CoreExpr)]
binds2l, (Id
bndr2,CoreExpr
_):[(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 a. [a] -> 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
-Int
1) RnEnv2
env ([(Id, CoreExpr)]
binds1[(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++[(Id
bndr1,CoreExpr
expr1)]) [(Id, CoreExpr)]
binds2

       -- 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 RnEnv2
env [(Id, CoreExpr)]
binds1 [(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 String
"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 String
"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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds1') ([(Id, CoreExpr)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, CoreExpr)]
binds2')
       unmatched :: String -> [(b, Expr b)] -> [SDoc]
unmatched String
_   [] = []
       unmatched String
txt [(b, Expr b)]
bs = [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
txt SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ 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 RnEnv2
env (Id
bndr1,CoreExpr
expr1) (Id
bndr2,CoreExpr
expr2)
         | ds :: [SDoc]
ds@(SDoc
_:[SDoc]
_) <- Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
expr1 CoreExpr
expr2
         = String -> Id -> Id -> [SDoc] -> [SDoc]
locBind String
"in binding" Id
bndr1 Id
bndr2 [SDoc]
ds
         -- Special case for TyVar, which we checked were bound to the same types in
         -- diffExpr, but don't have any IdInfo we would panic if called diffIdInfo.
         -- These let-bound types are created temporarily by the simplifier but inlined
         -- immediately.
         | Id -> Bool
isTyVar Id
bndr1 Bool -> Bool -> Bool
&& Id -> Bool
isTyVar Id
bndr2
         = []
         | Bool
otherwise
         = RnEnv2 -> Id -> Id -> [SDoc]
diffIdInfo RnEnv2
env Id
bndr1 Id
bndr2

-- | 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 Bool
_   RnEnv2
env (Var Id
v1)   (Var 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 Bool
_   RnEnv2
_   (Lit Literal
lit1) (Lit Literal
lit2) | Literal
lit1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
lit2                   = []
diffExpr Bool
_   RnEnv2
env (Type Type
t1)  (Type Type
t2)  | HasCallStack => RnEnv2 -> Type -> Type -> Bool
RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2              = []
diffExpr Bool
_   RnEnv2
env (Coercion Coercion
co1) (Coercion Coercion
co2)
                                       | RnEnv2 -> Coercion -> Coercion -> Bool
eqCoercionX RnEnv2
env Coercion
co1 Coercion
co2        = []
diffExpr Bool
top RnEnv2
env (Cast CoreExpr
e1 Coercion
co1)  (Cast CoreExpr
e2 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 Bool
top RnEnv2
env (Tick CoreTickish
n1 CoreExpr
e1)   CoreExpr
e2
  | Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
n1)                 = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2
diffExpr Bool
top RnEnv2
env CoreExpr
e1             (Tick CoreTickish
n2 CoreExpr
e2)
  | Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
n2)                 = Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
diffExpr Bool
top RnEnv2
env CoreExpr
e1 CoreExpr
e2
diffExpr Bool
top RnEnv2
env (Tick CoreTickish
n1 CoreExpr
e1)   (Tick CoreTickish
n2 CoreExpr
e2)
  | RnEnv2 -> CoreTickish -> CoreTickish -> Bool
eqTickish RnEnv2
env CoreTickish
n1 CoreTickish
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 Bool
_   RnEnv2
_   (App (App (Var Id
absent) CoreExpr
_) CoreExpr
_)
                 (App (App (Var Id
absent2) CoreExpr
_) CoreExpr
_)
  | Id -> Bool
isDeadEndId Id
absent Bool -> Bool -> Bool
&& Id -> Bool
isDeadEndId Id
absent2 = []
diffExpr Bool
top RnEnv2
env (App CoreExpr
f1 CoreExpr
a1)    (App CoreExpr
f2 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 Bool
top RnEnv2
env (Lam Id
b1 CoreExpr
e1)  (Lam Id
b2 CoreExpr
e2)
  | HasCallStack => RnEnv2 -> Type -> Type -> Bool
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 Bool
top RnEnv2
env (Let Bind Id
bs1 CoreExpr
e1) (Let Bind Id
bs2 CoreExpr
e2)
  = let ([SDoc]
ds, 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 Bool
top RnEnv2
env (Case CoreExpr
e1 Id
b1 Type
t1 [Alt Id]
a1) (Case CoreExpr
e2 Id
b2 Type
t2 [Alt Id]
a2)
  | [Alt Id] -> [Alt Id] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Alt Id]
a1 [Alt Id]
a2 Bool -> Bool -> Bool
&& Bool -> Bool
not ([Alt Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
a1) Bool -> Bool -> Bool
|| HasCallStack => RnEnv2 -> Type -> Type -> Bool
RnEnv2 -> Type -> Type -> Bool
eqTypeX RnEnv2
env Type
t1 Type
t2
    -- See Note [Empty case alternatives] in GHC.Data.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 ((Alt Id -> Alt Id -> [SDoc]) -> [Alt Id] -> [Alt Id] -> [[SDoc]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Alt Id -> Alt Id -> [SDoc]
diffAlt [Alt Id]
a1 [Alt Id]
a2)
  where env' :: RnEnv2
env' = RnEnv2 -> Id -> Id -> RnEnv2
rnBndr2 RnEnv2
env Id
b1 Id
b2
        diffAlt :: Alt Id -> Alt Id -> [SDoc]
diffAlt (Alt AltCon
c1 [Id]
bs1 CoreExpr
e1) (Alt AltCon
c2 [Id]
bs2 CoreExpr
e2)
          | AltCon
c1 AltCon -> AltCon -> Bool
forall a. Eq a => a -> a -> Bool
/= AltCon
c2  = [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"alt-cons " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
c1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" /= " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
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 Bool
_  RnEnv2
_ CoreExpr
e1 CoreExpr
e2
  = [[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep [CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e1, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"/=", CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e2]]

-- | 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 RnEnv2
env Id
bndr1 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
  = String -> Id -> Id -> [SDoc] -> [SDoc]
locBind String
"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
realUnfoldingInfo IdInfo
info1) (IdInfo -> Unfolding
realUnfoldingInfo IdInfo
info2)
  | Bool
otherwise
  = String -> Id -> Id -> [SDoc] -> [SDoc]
locBind String
"in Id info of" Id
bndr1 Id
bndr2
    [[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep [BindingSite -> Id -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Id
bndr1, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"/=", 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 RnEnv2
_   Unfolding
NoUnfolding    Unfolding
NoUnfolding                 = []
diffUnfold RnEnv2
_   Unfolding
BootUnfolding  Unfolding
BootUnfolding               = []
diffUnfold RnEnv2
_   (OtherCon [AltCon]
cs1) (OtherCon [AltCon]
cs2) | [AltCon]
cs1 [AltCon] -> [AltCon] -> Bool
forall a. Eq a => a -> a -> Bool
== [AltCon]
cs2 = []
diffUnfold RnEnv2
env (DFunUnfolding [Id]
bs1 DataCon
c1 [CoreExpr]
a1)
               (DFunUnfolding [Id]
bs2 DataCon
c2 [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 RnEnv2
env (CoreUnfolding CoreExpr
t1 UnfoldingSource
_ Bool
_ UnfoldingCache
c1 UnfoldingGuidance
g1)
               (CoreUnfolding CoreExpr
t2 UnfoldingSource
_ Bool
_ UnfoldingCache
c2 UnfoldingGuidance
g2)
  | UnfoldingCache
c1 UnfoldingCache -> UnfoldingCache -> Bool
forall a. Eq a => a -> a -> Bool
== UnfoldingCache
c2 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 RnEnv2
_   Unfolding
uf1 Unfolding
uf2
  = [[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep [Unfolding -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unfolding
uf1, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"/=", 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 String
loc Id
b1 Id
b2 [SDoc]
diffs = (SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map SDoc -> SDoc
addLoc [SDoc]
diffs
  where addLoc :: SDoc -> SDoc
addLoc SDoc
d            = SDoc
d SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
loc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'/' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b2


{- *********************************************************************
*                                                                      *
\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.
-}

{-
************************************************************************
*                                                                      *
\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 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 (TyCon
tc, [Type]
inst_tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
    , Just [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

-- | If @normSplitTyConApp_maybe _ ty = Just (tc, tys, co)@
-- then @ty |> co = tc tys@. It's 'splitTyConApp_maybe', but looks through
-- coercions via 'topNormaliseType_maybe'. Hence the \"norm\" prefix.
normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)
normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)
normSplitTyConApp_maybe FamInstEnvs
fam_envs Type
ty
  | let Reduction Coercion
co Type
ty1 = FamInstEnvs -> Type -> Maybe Reduction
topNormaliseType_maybe FamInstEnvs
fam_envs Type
ty
                           Maybe Reduction -> Reduction -> Reduction
forall a. Maybe a -> a -> a
`orElse` (Role -> Type -> Reduction
mkReflRedn Role
Representational Type
ty)
  , Just (TyCon
tc, [Type]
tc_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty1
  = (TyCon, [Type], Coercion) -> Maybe (TyCon, [Type], Coercion)
forall a. a -> Maybe a
Just (TyCon
tc, [Type]
tc_args, Coercion
co)
normSplitTyConApp_maybe FamInstEnvs
_ Type
_ = Maybe (TyCon, [Type], Coercion)
forall a. Maybe a
Nothing

{-
*****************************************************
*
* InScopeSet things
*
*****************************************************
-}


extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet
extendInScopeSetBind :: InScopeSet -> Bind Id -> InScopeSet
extendInScopeSetBind (InScope VarSet
in_scope) Bind Id
binds
   = VarSet -> InScopeSet
InScope (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ (VarSet -> Id -> VarSet) -> VarSet -> Bind Id -> VarSet
forall a b. (a -> b -> a) -> a -> Bind b -> a
foldBindersOfBindStrict VarSet -> Id -> VarSet
extendVarSet VarSet
in_scope Bind Id
binds

extendInScopeSetBndrs :: InScopeSet -> [CoreBind] -> InScopeSet
extendInScopeSetBndrs :: InScopeSet -> [Bind Id] -> InScopeSet
extendInScopeSetBndrs (InScope VarSet
in_scope) [Bind Id]
binds
   = VarSet -> InScopeSet
InScope (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ (VarSet -> Id -> VarSet) -> VarSet -> [Bind Id] -> VarSet
forall a b. (a -> b -> a) -> a -> [Bind b] -> a
foldBindersOfBindsStrict VarSet -> Id -> VarSet
extendVarSet VarSet
in_scope [Bind Id]
binds

mkInScopeSetBndrs :: [CoreBind] -> InScopeSet
mkInScopeSetBndrs :: [Bind Id] -> InScopeSet
mkInScopeSetBndrs [Bind Id]
binds = (InScopeSet -> Id -> InScopeSet)
-> InScopeSet -> [Bind Id] -> InScopeSet
forall a b. (a -> b -> a) -> a -> [Bind b] -> a
foldBindersOfBindsStrict InScopeSet -> Id -> InScopeSet
extendInScopeSet InScopeSet
emptyInScopeSet [Bind Id]
binds

{-
*****************************************************
*
* 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 CoreExpr
e
    | (fun :: CoreExpr
fun@(Var Id
b), [Type Type
t, CoreExpr
loc, CoreExpr
arg], [CoreTickish]
_) <- (CoreTickish -> Bool)
-> CoreExpr -> (CoreExpr, [CoreExpr], [CoreTickish])
forall b.
(CoreTickish -> Bool)
-> Expr b -> (Expr b, [Expr b], [CoreTickish])
collectArgsTicks (Bool -> CoreTickish -> 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 CoreExpr
_          = 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 Id
b CoreExpr
_)       = Id -> Bool
isJoinId Id
b
isJoinBind (Rec ((Id
b, CoreExpr
_) : [(Id, CoreExpr)]
_)) = Id -> Bool
isJoinId Id
b
isJoinBind Bind Id
_                  = Bool
False

dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc
dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> [Bind Id] -> SDoc
dumpIdInfoOfProgram Bool
dump_locals IdInfo -> SDoc
ppr_id_info [Bind Id]
binds = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> SDoc
printId [Id]
ids)
  where
  ids :: [Id]
ids = (Id -> Id -> Ordering) -> [Id] -> [Id]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Name -> Name -> Ordering
stableNameCmp (Name -> Name -> Ordering) -> (Id -> Name) -> Id -> Id -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Id -> Name
forall a. NamedThing a => a -> Name
getName) ((Bind Id -> [Id]) -> [Bind Id] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind Id -> [Id]
forall b. Bind b -> [b]
getIds [Bind Id]
binds)
  getIds :: Bind a -> [a]
getIds (NonRec a
i Expr a
_) = [ a
i ]
  getIds (Rec [(a, Expr a)]
bs)     = ((a, Expr a) -> a) -> [(a, Expr a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Expr a) -> a
forall a b. (a, b) -> a
fst [(a, Expr a)]
bs
  -- By default only include full info for exported ids, unless we run in the verbose
  -- pprDebug mode.
  printId :: Id -> SDoc
printId Id
id | Id -> Bool
isExportedId Id
id Bool -> Bool -> Bool
|| Bool
dump_locals = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (IdInfo -> SDoc
ppr_id_info (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id))
             | Bool
otherwise       = SDoc
forall doc. IsOutput doc => doc
empty

{-
************************************************************************
*                                                                      *
\subsection{Tag inference things}
*                                                                      *
************************************************************************
-}

{- Note [Call-by-value for worker args]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we unbox a constructor with strict fields we want to
preserve the information that some of the arguments came
out of strict fields and therefore should be already properly
tagged, however we can't express this directly in core.

Instead what we do is generate a worker like this:

  data T = MkT A !B

  foo = case T of MkT a b -> $wfoo a b

  $wfoo a b = case b of b' -> rhs[b/b']

This makes the worker strict in b causing us to use a more efficient
calling convention for `b` where the caller needs to ensure `b` is
properly tagged and evaluated before it's passed to $wfoo. See Note [CBV Function Ids].

Usually the argument will be known to be properly tagged at the call site so there is
no additional work for the caller and the worker can be more efficient since it can
assume the presence of a tag.

This is especially true for recursive functions like this:
    -- myPred expect it's argument properly tagged
    myPred !x = ...

    loop :: MyPair -> Int
    loop (MyPair !x !y) =
        case x of
            A -> 1
            B -> 2
            _ -> loop (MyPair (myPred x) (myPred y))

Here we would ordinarily not be strict in y after unboxing.
However if we pass it as a regular argument then this means on
every iteration of loop we will incur an extra seq on y before
we can pass it to `myPred` which isn't great! That is in STG after
tag inference we get:

    Rec {
    Find.$wloop [InlPrag=[2], Occ=LoopBreaker]
      :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int#
    [GblId[StrictWorker([!, ~])],
    Arity=2,
    Str=<1L><ML>,
    Unf=OtherCon []] =
        {} \r [x y]
            case x<TagProper> of x' [Occ=Once1] {
              __DEFAULT ->
                  case y of y' [Occ=Once1] {
                  __DEFAULT ->
                  case Find.$wmyPred y' of pred_y [Occ=Once1] {
                  __DEFAULT ->
                  case Find.$wmyPred x' of pred_x [Occ=Once1] {
                  __DEFAULT -> Find.$wloop pred_x pred_y;
                  };
                  };
              Find.A -> 1#;
              Find.B -> 2#;
            };
    end Rec }

Here comes the tricky part: If we make $wloop strict in both x/y and we get:

    Rec {
    Find.$wloop [InlPrag=[2], Occ=LoopBreaker]
      :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int#
    [GblId[StrictWorker([!, !])],
    Arity=2,
    Str=<1L><!L>,
    Unf=OtherCon []] =
        {} \r [x y]
            case y<TagProper> of y' [Occ=Once1] { __DEFAULT ->
            case x<TagProper> of x' [Occ=Once1] {
              __DEFAULT ->
                  case Find.$wmyPred y' of pred_y [Occ=Once1] {
                  __DEFAULT ->
                  case Find.$wmyPred x' of pred_x [Occ=Once1] {
                  __DEFAULT -> Find.$wloop pred_x pred_y;
                  };
                  };
              Find.A -> 1#;
              Find.B -> 2#;
            };
    end Rec }

Here both x and y are known to be tagged in the function body since we pass strict worker args using unlifted cbv.
This means the seqs on x and y both become no-ops and compared to the first version the seq on `y` disappears at runtime.

The downside is that the caller of $wfoo potentially has to evaluate `y` once if we can't prove it isn't already evaluated.
But y coming out of a strict field is in WHNF so safe to evaluated. And most of the time it will be properly tagged+evaluated
already at the call site because of the Strict Field Invariant! See Note [Strict Field Invariant] for more in this.
This makes GHC itself around 1% faster despite doing slightly more work! So this is generally quite good.

We only apply this when we think there is a benefit in doing so however. There are a number of cases in which
it would be useless to insert an extra seq. ShouldStrictifyIdForCbv tries to identify these to avoid churn in the
simplifier. See Note [Which Ids should be strictified] for details on this.
-}
mkStrictFieldSeqs :: [(Id,StrictnessMark)] -> CoreExpr -> (CoreExpr)
mkStrictFieldSeqs :: [(Id, StrictnessMark)] -> CoreExpr -> CoreExpr
mkStrictFieldSeqs [(Id, StrictnessMark)]
args CoreExpr
rhs =
  ((Id, StrictnessMark) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [(Id, StrictnessMark)] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Id, StrictnessMark) -> CoreExpr -> CoreExpr
addEval CoreExpr
rhs [(Id, StrictnessMark)]
args
    where
      case_ty :: Type
case_ty = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
rhs
      addEval :: (Id,StrictnessMark) -> (CoreExpr) -> (CoreExpr)
      addEval :: (Id, StrictnessMark) -> CoreExpr -> CoreExpr
addEval (Id
arg_id,StrictnessMark
arg_cbv) (CoreExpr
rhs)
        -- Argument representing strict field.
        | StrictnessMark -> Bool
isMarkedStrict StrictnessMark
arg_cbv
        , Id -> Bool
shouldStrictifyIdForCbv Id
arg_id
        -- Make sure to remove unfoldings here to avoid the simplifier dropping those for OtherCon[] unfoldings.
        = CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var (Id -> CoreExpr) -> Id -> CoreExpr
forall a b. (a -> b) -> a -> b
$! Id -> Id
zapIdUnfolding Id
arg_id) Id
arg_id Type
case_ty ([AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
rhs])
        -- Normal argument
        | Bool
otherwise = do
          rhs

{- Note [Which Ids should be strictified]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For some arguments we would like to convince GHC to pass them call by value.
One way to achieve this is described in see Note [Call-by-value for worker args].

We separate the concerns of "should we pass this argument using cbv" and
"should we do so by making the rhs strict in this argument".
This note deals with the second part.

There are multiple reasons why we might not want to insert a seq in the rhs to
strictify a functions argument:

1) The argument doesn't exist at runtime.

For zero width types (like Types) there is no benefit as we don't operate on them
at runtime at all. This includes things like void#, coercions and state tokens.

2) The argument is a unlifted type.

If the argument is a unlifted type the calling convention already is explicitly
cbv. This means inserting a seq on this argument wouldn't do anything as the seq
would be a no-op *and* it wouldn't affect the calling convention.

3) The argument is absent.

If the argument is absent in the body there is no advantage to it being passed as
cbv to the function. The function won't ever look at it so we don't safe any work.

This mostly happens for join point. For example we might have:

    data T = MkT ![Int] [Char]
    f t = case t of MkT xs{strict} ys-> snd (xs,ys)

and abstract the case alternative to:

    f t = join j1 = \xs ys -> snd (xs,ys)
          in case t of MkT xs{strict} ys-> j1 xs xy

While we "use" xs inside `j1` it's not used inside the function `snd` we pass it to.
In short a absent demand means neither our RHS, nor any function we pass the argument
to will inspect it. So there is no work to be saved by forcing `xs` early.

NB: There is an edge case where if we rebox we *can* end up seqing an absent value.
Note [Absent fillers] has an example of this. However this is so rare it's not worth
caring about here.

4) The argument is already strict.

Consider this code:

    data T = MkT ![Int]
    f t = case t of MkT xs{strict} -> reverse xs

The `xs{strict}` indicates that `xs` is used strictly by the `reverse xs`.
If we do a w/w split, and add the extra eval on `xs`, we'll get

    $wf xs =
        case xs of xs1 ->
            let t = MkT xs1 in
            case t of MkT xs2 -> reverse xs2

That's not wrong; but the w/w body will simplify to

    $wf xs = case xs of xs1 -> reverse xs1

and now we'll drop the `case xs` because `xs1` is used strictly in its scope.
Adding that eval was a waste of time.  So don't add it for strictly-demanded Ids.

5) Functions

Functions are tricky (see Note [TagInfo of functions] in InferTags).
But the gist of it even if we make a higher order function argument strict
we can't avoid the tag check when it's used later in the body.
So there is no benefit.

-}
-- | Do we expect there to be any benefit if we make this var strict
-- in order for it to get treated as as cbv argument?
-- See Note [Which Ids should be strictified]
-- See Note [CBV Function Ids] for more background.
shouldStrictifyIdForCbv :: Var -> Bool
shouldStrictifyIdForCbv :: Id -> Bool
shouldStrictifyIdForCbv = Bool -> Id -> Bool
wantCbvForId Bool
False

-- Like shouldStrictifyIdForCbv but also wants to use cbv for strict args.
shouldUseCbvForId :: Var -> Bool
shouldUseCbvForId :: Id -> Bool
shouldUseCbvForId = Bool -> Id -> Bool
wantCbvForId Bool
True

-- When we strictify we want to skip strict args otherwise the logic is the same
-- as for shouldUseCbvForId so we common up the logic here.
-- Basically returns true if it would be beneficial for runtime to pass this argument
-- as CBV independent of weither or not it's correct. E.g. it might return true for lazy args
-- we are not allowed to force.
wantCbvForId :: Bool -> Var -> Bool
wantCbvForId :: Bool -> Id -> Bool
wantCbvForId Bool
cbv_for_strict Id
v
  -- Must be a runtime var.
  -- See Note [Which Ids should be strictified] point 1)
  | Id -> Bool
isId Id
v
  , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> Bool
Type -> Bool
isZeroBitTy Type
ty
  -- Unlifted things don't need special measures to be treated as cbv
  -- See Note [Which Ids should be strictified] point 2)
  , Type -> Bool
mightBeLiftedType Type
ty
  -- Functions sometimes get a zero tag so we can't eliminate the tag check.
  -- See Note [TagInfo of functions] in InferTags.
  -- See Note [Which Ids should be strictified] point 5)
  , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Bool
isFunTy Type
ty
  -- If the var is strict already a seq is redundant.
  -- See Note [Which Ids should be strictified] point 4)
  , Bool -> Bool
not (Demand -> Bool
isStrictDmd Demand
dmd) Bool -> Bool -> Bool
|| Bool
cbv_for_strict
  -- If the var is absent a seq is almost always useless.
  -- See Note [Which Ids should be strictified] point 3)
  , Bool -> Bool
not (Demand -> Bool
isAbsDmd Demand
dmd)
  = Bool
True
  | Bool
otherwise
  = Bool
False
  where
    ty :: Type
ty = Id -> Type
idType Id
v
    dmd :: Demand
dmd = Id -> Demand
idDemandInfo Id
v

{- *********************************************************************
*                                                                      *
             unsafeEqualityProof
*                                                                      *
********************************************************************* -}

isUnsafeEqualityCase :: CoreExpr -> Id -> [CoreAlt] -> Maybe CoreExpr
-- See (U3) and (U4) in
-- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
isUnsafeEqualityCase :: CoreExpr -> Id -> [Alt Id] -> Maybe CoreExpr
isUnsafeEqualityCase CoreExpr
scrut Id
bndr [Alt Id]
alts
  | [Alt AltCon
ac [Id]
_ CoreExpr
rhs] <- [Alt Id]
alts
  , DataAlt DataCon
dc <- AltCon
ac
  , DataCon
dc DataCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unsafeReflDataConKey
  , Id -> Bool
isDeadBinder Id
bndr
      -- We can only discard the case if the case-binder is dead
      -- It usually is, but see #18227
  , Var Id
v `App` CoreExpr
_ `App` CoreExpr
_ `App` CoreExpr
_ <- CoreExpr
scrut
  , Id
v Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unsafeEqualityProofIdKey
      -- Check that the scrutinee really is unsafeEqualityProof
      -- and not, say, error
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
rhs
  | Bool
otherwise
  = Maybe CoreExpr
forall a. Maybe a
Nothing