path: root/compiler/GHC/Core/Make.hs

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | Handy functions for creating much Core syntax
module GHC.Core.Make (
        -- * Constructing normal syntax
        mkCoreLet, mkCoreLets,
        mkCoreApp, mkCoreApps, mkCoreConApps,
        mkCoreLams, mkWildCase, mkIfThenElse,
        mkWildValBinder,
        mkSingleAltCase,
        sortQuantVars, castBottomExpr,

        -- * Constructing boxed literals
        mkLitRubbish,
        mkWordExpr,
        mkIntExpr, mkIntExprInt, mkUncheckedIntExpr,
        mkIntegerExpr, mkNaturalExpr,
        mkFloatExpr, mkDoubleExpr,
        mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,
        MkStringIds (..), getMkStringIds,

        -- * Floats
        FloatBind(..), wrapFloat, wrapFloats, floatBindings,

        -- * Constructing small tuples
        mkCoreVarTupTy, mkCoreTup, mkCoreUnboxedTuple, mkCoreUnboxedSum,
        mkCoreTupBoxity, unitExpr,

        -- * Constructing big tuples
        mkChunkified, chunkify,
        mkBigCoreVarTup, mkBigCoreVarTupSolo,
        mkBigCoreVarTupTy, mkBigCoreTupTy,
        mkBigCoreTup,

          -- * Deconstructing big tuples
        mkBigTupleSelector, mkBigTupleSelectorSolo, mkBigTupleCase,

        -- * Constructing list expressions
        mkNilExpr, mkConsExpr, mkListExpr,
        mkFoldrExpr, mkBuildExpr,

        -- * Constructing Maybe expressions
        mkNothingExpr, mkJustExpr,

        -- * Error Ids
        mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds,
        rEC_CON_ERROR_ID,
        nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
        pAT_ERROR_ID, rEC_SEL_ERROR_ID,
        tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID
    ) where

import GHC.Prelude
import GHC.Platform

import GHC.Types.Id
import GHC.Types.Var  ( setTyVarUnique, visArgConstraintLike )
import GHC.Types.TyThing
import GHC.Types.Id.Info
import GHC.Types.Cpr
import GHC.Types.Basic( TypeOrConstraint(..) )
import GHC.Types.Demand
import GHC.Types.Name      hiding ( varName )
import GHC.Types.Literal
import GHC.Types.Unique.Supply

import GHC.Core
import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec )
import GHC.Core.Type
import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.Coercion ( isCoVar )
import GHC.Core.DataCon  ( DataCon, dataConWorkId )
import GHC.Core.Multiplicity

import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Builtin.Types.Prim

import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain

import GHC.Settings.Constants( mAX_TUPLE_SIZE )
import GHC.Data.FastString

import Data.List        ( partition )
import Data.Char        ( ord )

infixl 4 `mkCoreApp`, `mkCoreApps`

{-
************************************************************************
*                                                                      *
\subsection{Basic GHC.Core construction}
*                                                                      *
************************************************************************
-}
-- | Sort the variables, putting type and covars first, in scoped order,
-- and then other Ids
--
-- It is a deterministic sort, meaning it doesn't look at the values of
-- Uniques. For explanation why it's important See Note [Unique Determinism]
-- in GHC.Types.Unique.
sortQuantVars :: [Var] -> [Var]
sortQuantVars vs = sorted_tcvs ++ ids
  where
    (tcvs, ids) = partition (isTyVar <||> isCoVar) vs
    sorted_tcvs = scopedSort tcvs

-- | Bind a binding group over an expression, using a @let@ or @case@ as
-- appropriate (see "GHC.Core#let_can_float_invariant")
mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (NonRec bndr rhs) body        -- See Note [Core let-can-float invariant]
  = bindNonRec bndr rhs body
mkCoreLet bind body
  = Let bind body

-- | Create a lambda where the given expression has a number of variables
-- bound over it. The leftmost binder is that bound by the outermost
-- lambda in the result
mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr
mkCoreLams = mkLams

-- | Bind a list of binding groups over an expression. The leftmost binding
-- group becomes the outermost group in the resulting expression
mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets binds body = foldr mkCoreLet body binds

-- | Construct an expression which represents the application of a number of
-- expressions to that of a data constructor expression. The leftmost expression
-- in the list is applied first
mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args

-- | Construct an expression which represents the application of a number of
-- expressions to another. The leftmost expression in the list is applied first
mkCoreApps :: CoreExpr -- ^ function
           -> [CoreExpr] -- ^ arguments
           -> CoreExpr
mkCoreApps fun args
  = fst $
    foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args
  where
    doc_string = ppr fun_ty $$ ppr fun $$ ppr args
    fun_ty = exprType fun

-- | Construct an expression which represents the application of one expression
-- to the other
mkCoreApp :: SDoc
          -> CoreExpr -- ^ function
          -> CoreExpr -- ^ argument
          -> CoreExpr
mkCoreApp s fun arg
  = fst $ mkCoreAppTyped s (fun, exprType fun) arg

-- | Construct an expression which represents the application of one expression
-- paired with its type to an argument. The result is paired with its type. This
-- function is not exported and used in the definition of 'mkCoreApp' and
-- 'mkCoreApps'.
mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
mkCoreAppTyped _ (fun, fun_ty) (Type ty)
  = (App fun (Type ty), piResultTy fun_ty ty)
mkCoreAppTyped _ (fun, fun_ty) (Coercion co)
  = (App fun (Coercion co), funResultTy fun_ty)
mkCoreAppTyped d (fun, fun_ty) arg
  = assertPpr (isFunTy fun_ty) (ppr fun $$ ppr arg $$ d)
    (App fun arg, funResultTy fun_ty)

{- *********************************************************************
*                                                                      *
              Building case expressions
*                                                                      *
********************************************************************* -}

-- | Make a /wildcard binder/. This is typically used when you need a binder
-- that you expect to use only at a *binding* site.  Do not use it at
-- occurrence sites because it has a single, fixed unique, and it's very
-- easy to get into difficulties with shadowing.  That's why it is used so little.
--
-- See Note [WildCard binders] in "GHC.Core.Opt.Simplify.Env"
mkWildValBinder :: Mult -> Type -> Id
mkWildValBinder w ty = mkLocalIdOrCoVar wildCardName w ty
  -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors
  -- (e.g. see test T15695). Ticket #17291 covers fixing this problem.

-- | Make a case expression whose case binder is unused
-- The alts and res_ty should not have any occurrences of WildId
mkWildCase :: CoreExpr -- ^ scrutinee
           -> Scaled Type
           -> Type -- ^ res_ty
           -> [CoreAlt] -- ^ alts
           -> CoreExpr
mkWildCase scrut (Scaled w scrut_ty) res_ty alts
  = Case scrut (mkWildValBinder w scrut_ty) res_ty alts

mkIfThenElse :: CoreExpr -- ^ guard
             -> CoreExpr -- ^ then
             -> CoreExpr -- ^ else
             -> CoreExpr
mkIfThenElse guard then_expr else_expr
-- Not going to be refining, so okay to take the type of the "then" clause
  = mkWildCase guard (linear boolTy) (exprType then_expr)
         [ Alt (DataAlt falseDataCon) [] else_expr,       -- Increasing order of tag!
           Alt (DataAlt trueDataCon)  [] then_expr ]

castBottomExpr :: CoreExpr -> Type -> CoreExpr
-- (castBottomExpr e ty), assuming that 'e' diverges,
-- return an expression of type 'ty'
-- See Note [Empty case alternatives] in GHC.Core
castBottomExpr e res_ty
  | e_ty `eqType` res_ty = e
  | otherwise            = Case e (mkWildValBinder OneTy e_ty) res_ty []
  where
    e_ty = exprType e

mkLitRubbish :: Type -> Maybe CoreExpr
-- Make a rubbish-literal CoreExpr of the given type.
-- Fail (returning Nothing) if
--    * the RuntimeRep of the Type is not monomorphic;
--    * the type is (a ~# b), the type of coercion
-- See INVARIANT 1 and 2 of item (2) in Note [Rubbish literals]
-- in GHC.Types.Literal
mkLitRubbish ty
  | not (noFreeVarsOfType rep)
  = Nothing   -- Satisfy INVARIANT 1
  | isCoVarType ty
  = Nothing   -- Satisfy INVARIANT 2
  | otherwise
  = Just (Lit (LitRubbish torc rep) `mkTyApps` [ty])
  where
    Just (torc, rep) = sORTKind_maybe (typeKind ty)

{-
************************************************************************
*                                                                      *
\subsection{Making literals}
*                                                                      *
************************************************************************
-}

-- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExpr :: Platform -> Integer -> CoreExpr        -- Result = I# i :: Int
mkIntExpr platform i = mkCoreConApps intDataCon  [mkIntLit platform i]

-- | Create a 'CoreExpr' which will evaluate to the given @Int@. Don't check
-- that the number is in the range of the target platform @Int@
mkUncheckedIntExpr :: Integer -> CoreExpr        -- Result = I# i :: Int
mkUncheckedIntExpr i = mkCoreConApps intDataCon  [Lit (mkLitIntUnchecked i)]

-- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExprInt :: Platform -> Int -> CoreExpr         -- Result = I# i :: Int
mkIntExprInt platform i = mkCoreConApps intDataCon  [mkIntLit platform (fromIntegral i)]

-- | Create a 'CoreExpr' which will evaluate to a @Word@ with the given value
mkWordExpr :: Platform -> Integer -> CoreExpr
mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w]

-- | Create a 'CoreExpr' which will evaluate to the given @Integer@
mkIntegerExpr  :: Platform -> Integer -> CoreExpr  -- Result :: Integer
mkIntegerExpr platform i
  | platformInIntRange platform i = mkCoreConApps integerISDataCon [mkIntLit platform i]
  | i < 0                         = mkCoreConApps integerINDataCon [Lit (mkLitBigNat (negate i))]
  | otherwise                     = mkCoreConApps integerIPDataCon [Lit (mkLitBigNat i)]

-- | Create a 'CoreExpr' which will evaluate to the given @Natural@
mkNaturalExpr  :: Platform -> Integer -> CoreExpr
mkNaturalExpr platform w
  | platformInWordRange platform w = mkCoreConApps naturalNSDataCon [mkWordLit platform w]
  | otherwise                      = mkCoreConApps naturalNBDataCon [Lit (mkLitBigNat w)]

-- | Create a 'CoreExpr' which will evaluate to the given @Float@
mkFloatExpr :: Float -> CoreExpr
mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f]

-- | Create a 'CoreExpr' which will evaluate to the given @Double@
mkDoubleExpr :: Double -> CoreExpr
mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d]


-- | Create a 'CoreExpr' which will evaluate to the given @Char@
mkCharExpr     :: Char             -> CoreExpr      -- Result = C# c :: Int
mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c]

-- | Create a 'CoreExpr' which will evaluate to the given @String@
mkStringExpr   :: MonadThings m => String     -> m CoreExpr  -- Result :: String
mkStringExpr str = mkStringExprFS (mkFastString str)

-- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@
mkStringExprFS :: MonadThings m => FastString -> m CoreExpr  -- Result :: String
mkStringExprFS = mkStringExprFSLookup lookupId

mkStringExprFSLookup :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr
mkStringExprFSLookup lookupM str = do
  mk <- getMkStringIds lookupM
  pure (mkStringExprFSWith mk str)

getMkStringIds :: Applicative m => (Name -> m Id) -> m MkStringIds
getMkStringIds lookupM = MkStringIds <$> lookupM unpackCStringName <*> lookupM unpackCStringUtf8Name

data MkStringIds = MkStringIds
  { unpackCStringId     :: !Id
  , unpackCStringUtf8Id :: !Id
  }

mkStringExprFSWith :: MkStringIds -> FastString -> CoreExpr
mkStringExprFSWith ids str
  | nullFS str
  = mkNilExpr charTy

  | all safeChar chars
  = let !unpack_id = unpackCStringId ids
    in App (Var unpack_id) lit

  | otherwise
  = let !unpack_utf8_id = unpackCStringUtf8Id ids
    in App (Var unpack_utf8_id) lit

  where
    chars = unpackFS str
    safeChar c = ord c >= 1 && ord c <= 0x7F
    lit = Lit (LitString (bytesFS str))

{-
************************************************************************
*                                                                      *
     Creating tuples and their types for Core expressions
*                                                                      *
************************************************************************
-}

{- Note [Flattening one-tuples]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This family of functions creates a tuple of variables/expressions/types.
  mkCoreTup [e1,e2,e3] = (e1,e2,e3)
What if there is just one variable/expression/type in the argument?
We could do one of two things:

* Flatten it out, so that
    mkCoreTup [e1] = e1

* Build a one-tuple (see Note [One-tuples] in GHC.Builtin.Types)
    mkCoreTupSolo [e1] = Solo e1
  We use a suffix "Solo" to indicate this.

Usually we want the former, but occasionally the latter.

NB: The logic in tupleDataCon knows about () and Solo and (,), etc.

Note [Don't flatten tuples from HsSyn]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we get an explicit 1-tuple from HsSyn somehow (likely: Template Haskell),
we should treat it really as a 1-tuple, without flattening. Note that a
1-tuple and a flattened value have different performance and laziness
characteristics, so should just do what we're asked.

This arose from discussions in #16881.

One-tuples that arise internally depend on the circumstance; often flattening
is a good idea. Decisions are made on a case-by-case basis.

'mkCoreBoxedTuple` and `mkBigCoreVarTupSolo` build tuples without flattening.
-}

-- | Build a small tuple holding the specified expressions
-- One-tuples are *not* flattened; see Note [Flattening one-tuples]
-- See also Note [Don't flatten tuples from HsSyn]
-- Arguments must have kind Type
mkCoreBoxedTuple :: HasDebugCallStack => [CoreExpr] -> CoreExpr
mkCoreBoxedTuple cs
  = assertPpr (all (tcIsLiftedTypeKind . typeKind . exprType) cs) (ppr cs)
    mkCoreConApps (tupleDataCon Boxed (length cs))
                  (map (Type . exprType) cs ++ cs)


-- | Build a small unboxed tuple holding the specified expressions.
-- Do not include the RuntimeRep specifiers; this function calculates them
-- for you.
-- Does /not/ flatten one-tuples; see Note [Flattening one-tuples]
mkCoreUnboxedTuple :: [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple exps
  = mkCoreConApps (tupleDataCon Unboxed (length tys))
                  (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps)
  where
    tys = map exprType exps

-- | Make a core tuple of the given boxity; don't flatten 1-tuples
mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
mkCoreTupBoxity Boxed   exps = mkCoreBoxedTuple   exps
mkCoreTupBoxity Unboxed exps = mkCoreUnboxedTuple exps

-- | Build the type of a small tuple that holds the specified variables
-- One-tuples are flattened; see Note [Flattening one-tuples]
mkCoreVarTupTy :: [Id] -> Type
mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)

-- | Build a small tuple holding the specified expressions
-- One-tuples are flattened; see Note [Flattening one-tuples]
mkCoreTup :: [CoreExpr] -> CoreExpr
mkCoreTup [c] = c
mkCoreTup cs  = mkCoreBoxedTuple cs   -- non-1-tuples are uniform

-- | Build an unboxed sum.
--
-- Alternative number ("alt") starts from 1.
mkCoreUnboxedSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUnboxedSum arity alt tys exp
  = assert (length tys == arity) $
    assert (alt <= arity) $
    mkCoreConApps (sumDataCon alt arity)
                  (map (Type . getRuntimeRep) tys
                   ++ map Type tys
                   ++ [exp])

{- Note [Big tuples]
~~~~~~~~~~~~~~~~~~~~
"Big" tuples (`mkBigCoreTup` and friends) are more general than "small"
ones (`mkCoreTup` and friends) in two ways.

1. GHCs built-in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
   we might conceivably want to build such a massive tuple as part of the
   output of a desugaring stage (notably that for list comprehensions).

   `mkBigCoreTup` encodes such big tuples by creating and pattern
   matching on /nested/ small tuples that are directly expressible by
   GHC.

   Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
   than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
   construction to be big.

2. When desugaring arrows we gather up a tuple of free variables, which
   may include dictionaries (of kind Constraint) and unboxed values.

   These can't live in a tuple. `mkBigCoreTup` encodes such tuples by
   boxing up the offending arguments: see Note [Boxing constructors]
   in GHC.Builtin.Types.

If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkBigTupleSelector'
and 'mkBigTupleCase' functions to do all your work with tuples you should be
fine, and not have to worry about the arity limitation, or kind limitation at
all.

The "big" tuple operations flatten 1-tuples just like "small" tuples.
But see Note [Don't flatten tuples from HsSyn]
-}

mkBigCoreVarTupSolo :: [Id] -> CoreExpr
-- Same as mkBigCoreVarTup, but:
--   - one-tuples are not flattened
--     see Note [Flattening one-tuples]
--   - arguments should have kind Type
mkBigCoreVarTupSolo [id] = mkCoreBoxedTuple [Var id]
mkBigCoreVarTupSolo ids  = mkChunkified mkCoreTup (map Var ids)

-- | Build a big tuple holding the specified variables
-- One-tuples are flattened; see Note [Flattening one-tuples]
-- Arguments don't have to have kind Type
mkBigCoreVarTup :: [Id] -> CoreExpr
mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)

-- | Build a "big" tuple holding the specified expressions
-- One-tuples are flattened; see Note [Flattening one-tuples]
-- Arguments don't have to have kind Type; ones that do not are boxed
-- This function crashes (in wrapBox) if given a non-Type
-- argument that it doesn't know how to box.
mkBigCoreTup :: [CoreExpr] -> CoreExpr
mkBigCoreTup exprs = mkChunkified mkCoreTup (map wrapBox exprs)

-- | Build the type of a big tuple that holds the specified variables
-- One-tuples are flattened; see Note [Flattening one-tuples]
mkBigCoreVarTupTy :: [Id] -> Type
mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)

-- | Build the type of a big tuple that holds the specified type of thing
-- One-tuples are flattened; see Note [Flattening one-tuples]
mkBigCoreTupTy :: [Type] -> Type
mkBigCoreTupTy tys = mkChunkified mkBoxedTupleTy $
                     map boxTy tys

-- | The unit expression
unitExpr :: CoreExpr
unitExpr = Var unitDataConId

--------------------------------------------------------------
wrapBox :: CoreExpr -> CoreExpr
-- ^ If (e :: ty) and (ty :: Type), wrapBox is a no-op
-- But if (ty :: ki), and ki is not Type, wrapBox returns (K @ty e)
--     which has kind Type
-- where K is the boxing data constructor for ki
-- See Note [Boxing constructors] in GHC.Builtin.Types
-- Panics if there /is/ no boxing data con
wrapBox e
  = case boxingDataCon e_ty of
      BI_NoBoxNeeded                       -> e
      BI_Box { bi_inst_con = boxing_expr } -> App boxing_expr e
      BI_NoBoxAvailable -> pprPanic "wrapBox" (ppr e $$ ppr (exprType e))
                           -- We should do better than panicing: #22336
  where
    e_ty = exprType e

boxTy :: Type -> Type
-- ^ `boxTy ty` is the boxed version of `ty`. That is,
-- if `e :: ty`, then `wrapBox e :: boxTy ty`.
-- Note that if `ty :: Type`, `boxTy ty` just returns `ty`.
-- Panics if it is not possible to box `ty`, like `wrapBox` (#22336)
-- See Note [Boxing constructors] in GHC.Builtin.Types
boxTy ty
  = case boxingDataCon ty of
      BI_NoBoxNeeded -> ty
      BI_Box { bi_boxed_type = box_ty } -> box_ty
      BI_NoBoxAvailable -> pprPanic "boxTy" (ppr ty)
                           -- We should do better than panicing: #22336

unwrapBox :: UniqSupply -> Id -> CoreExpr
                 -> (UniqSupply, Id, CoreExpr)
-- If v's type required boxing (i.e it is unlifted or a constraint)
-- then (unwrapBox us v body) returns
--          (case box_v of MkDict v -> body)
--          together with box_v
--      where box_v is a fresh variable
-- Otherwise unwrapBox is a no-op
-- Panics if no box is available (#22336)
unwrapBox us var body
  = case boxingDataCon var_ty of
      BI_NoBoxNeeded    -> (us, var, body)
      BI_NoBoxAvailable -> pprPanic "unwrapBox" (ppr var $$ ppr var_ty)
                           -- We should do better than panicing: #22336
      BI_Box { bi_data_con = box_con, bi_boxed_type = box_ty }
         -> (us', var', body')
         where
           var'  = mkSysLocal (fsLit "uc") uniq ManyTy box_ty
           body' = Case (Var var') var' (exprType body)
                        [Alt (DataAlt box_con) [var] body]
  where
    var_ty      = idType var
    (uniq, us') = takeUniqFromSupply us

-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decomposition
mkChunkified :: ([a] -> a)      -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
             -> [a]             -- ^ Possible \"big\" list of things to construct from
             -> a               -- ^ Constructed thing made possible by recursive decomposition
mkChunkified small_tuple as = mk_big_tuple (chunkify as)
  where
        -- Each sub-list is short enough to fit in a tuple
    mk_big_tuple [as] = small_tuple as
    mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))

chunkify :: [a] -> [[a]]
-- ^ Split a list into lists that are small enough to have a corresponding
-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
chunkify xs
  | n_xs <= mAX_TUPLE_SIZE = [xs]
  | otherwise              = split xs
  where
    n_xs     = length xs
    split [] = []
    split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)


{-
************************************************************************
*                                                                      *
\subsection{Tuple destructors}
*                                                                      *
************************************************************************
-}

-- | Builds a selector which scrutinises the given
-- expression and extracts the one name from the list given.
-- If you want the no-shadowing rule to apply, the caller
-- is responsible for making sure that none of these names
-- are in scope.
--
-- If there is just one 'Id' in the tuple, then the selector is
-- just the identity.
--
-- If necessary, we pattern match on a \"big\" tuple.
--
-- A tuple selector is not linear in its argument. Consequently, the case
-- expression built by `mkBigTupleSelector` must consume its scrutinee 'Many'
-- times. And all the argument variables must have multiplicity 'Many'.
mkBigTupleSelector, mkBigTupleSelectorSolo
    :: [Id]         -- ^ The 'Id's to pattern match the tuple against
    -> Id           -- ^ The 'Id' to select
    -> Id           -- ^ A variable of the same type as the scrutinee
    -> CoreExpr     -- ^ Scrutinee
    -> CoreExpr     -- ^ Selector expression

-- mkBigTupleSelector [a,b,c,d] b v e
--          = case e of v {
--                (p,q) -> case p of p {
--                           (a,b) -> b }}
-- We use 'tpl' vars for the p,q, since shadowing does not matter.
--
-- In fact, it's more convenient to generate it innermost first, getting
--
--        case (case e of v
--                (p,q) -> p) of p
--          (a,b) -> b
mkBigTupleSelector vars the_var scrut_var scrut
  = mk_tup_sel (chunkify vars) the_var
  where
    mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut
    mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $
                                mk_tup_sel (chunkify tpl_vs) tpl_v
        where
          tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]
          tpl_vs  = mkTemplateLocals tpl_tys
          [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkBigTupleSelector" tpl_vs vars_s,
                                         the_var `elem` gp ]
-- ^ 'mkBigTupleSelectorSolo' is like 'mkBigTupleSelector'
-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
mkBigTupleSelectorSolo vars the_var scrut_var scrut
  | [_] <- vars
  = mkSmallTupleSelector1 vars the_var scrut_var scrut
  | otherwise
  = mkBigTupleSelector vars the_var scrut_var scrut

-- | `mkSmallTupleSelector` is like 'mkBigTupleSelector', but for tuples that
-- are guaranteed never to be "big".  Also does not unwrap boxed types.
--
-- > mkSmallTupleSelector [x] x v e = [| e |]
-- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |]
mkSmallTupleSelector, mkSmallTupleSelector1
          :: [Id]        -- The tuple args
          -> Id          -- The selected one
          -> Id          -- A variable of the same type as the scrutinee
          -> CoreExpr    -- Scrutinee
          -> CoreExpr
mkSmallTupleSelector [var] should_be_the_same_var _ scrut
  = assert (var == should_be_the_same_var) $
    scrut  -- Special case for 1-tuples
mkSmallTupleSelector vars the_var scrut_var scrut
  = mkSmallTupleSelector1 vars the_var scrut_var scrut

-- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector'
-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
mkSmallTupleSelector1 vars the_var scrut_var scrut
  = assert (notNull vars) $
    Case scrut scrut_var (idType the_var)
         [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)]

-- | A generalization of 'mkBigTupleSelector', allowing the body
-- of the case to be an arbitrary expression.
--
-- To avoid shadowing, we use uniques to invent new variables.
--
-- If necessary we pattern match on a "big" tuple.
mkBigTupleCase :: UniqSupply       -- ^ For inventing names of intermediate variables
               -> [Id]             -- ^ The tuple identifiers to pattern match on;
                                   --   Bring these into scope in the body
               -> CoreExpr         -- ^ Body of the case
               -> CoreExpr         -- ^ Scrutinee
               -> CoreExpr
-- ToDo: eliminate cases where none of the variables are needed.
--
--         mkBigTupleCase uniqs [a,b,c,d] body v e
--           = case e of v { (p,q) ->
--             case p of p { (a,b) ->
--             case q of q { (c,d) ->
--             body }}}
mkBigTupleCase us vars body scrut
  = mk_tuple_case wrapped_us (chunkify wrapped_vars) wrapped_body
  where
    (wrapped_us, wrapped_vars, wrapped_body) = foldr unwrap (us,[],body) vars

    scrut_ty = exprType scrut

    unwrap var (us,vars,body)
      = (us', var':vars, body')
      where
        (us', var', body') = unwrapBox us var body

    mk_tuple_case :: UniqSupply -> [[Id]] -> CoreExpr -> CoreExpr
    -- mk_tuple_case [[a1..an], [b1..bm], ...] body
    --    case scrut of (p,q, ...) ->
    --    case p of (a1,..an) ->
    --    case q of (b1,..bm) ->
    --    ... -> body
    -- This is the case where don't need any nesting
    mk_tuple_case us [vars] body
      = mkSmallTupleCase vars body scrut_var scrut
      where
        scrut_var = case scrut of
                       Var v -> v
                       _ -> snd (new_var us scrut_ty)

    -- This is the case where we must nest tuples at least once
    mk_tuple_case us vars_s body
      = mk_tuple_case us' (chunkify vars') body'
      where
        (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s

    one_tuple_case chunk_vars (us, vs, body)
      = (us', scrut_var:vs, body')
      where
        tup_ty           = mkBoxedTupleTy (map idType chunk_vars)
        (us', scrut_var) = new_var us tup_ty
        body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)

    new_var :: UniqSupply -> Type -> (UniqSupply, Id)
    new_var us ty = (us', id)
       where
         (uniq, us') = takeUniqFromSupply us
         id = mkSysLocal (fsLit "ds") uniq ManyTy ty

-- | As 'mkBigTupleCase', but for a tuple that is small enough to be guaranteed
-- not to need nesting.
mkSmallTupleCase
        :: [Id]         -- ^ The tuple args
        -> CoreExpr     -- ^ Body of the case
        -> Id           -- ^ A variable of the same type as the scrutinee
        -> CoreExpr     -- ^ Scrutinee
        -> CoreExpr

mkSmallTupleCase [var] body _scrut_var scrut
  = bindNonRec var scrut body
mkSmallTupleCase vars body scrut_var scrut
  = Case scrut scrut_var (exprType body)
         [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body]

{-
************************************************************************
*                                                                      *
                Floats
*                                                                      *
************************************************************************
-}

data FloatBind
  = FloatLet  CoreBind
  | FloatCase CoreExpr Id AltCon [Var]
      -- case e of y { C ys -> ... }
      -- See Note [Floating single-alternative cases] in GHC.Core.Opt.SetLevels

instance Outputable FloatBind where
  ppr (FloatLet b) = text "LET" <+> ppr b
  ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> text "of" <+> ppr b)
                                2 (ppr c <+> ppr bs)

wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
wrapFloat (FloatLet defns)       body = Let defns body
wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body

-- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn]
-- u = let b1 in let b2 in … in let bn in u@
wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr
wrapFloats floats expr = foldr wrapFloat expr floats

bindBindings :: CoreBind -> [Var]
bindBindings (NonRec b _) = [b]
bindBindings (Rec bnds) = map fst bnds

floatBindings :: FloatBind -> [Var]
floatBindings (FloatLet bnd) = bindBindings bnd
floatBindings (FloatCase _ b _ bs) = b:bs

{-
************************************************************************
*                                                                      *
\subsection{Common list manipulation expressions}
*                                                                      *
************************************************************************

Call the constructor Ids when building explicit lists, so that they
interact well with rules.
-}

-- | Makes a list @[]@ for lists of the specified type
mkNilExpr :: Type -> CoreExpr
mkNilExpr ty = mkCoreConApps nilDataCon [Type ty]

-- | Makes a list @(:)@ for lists of the specified type
mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl]

-- | Make a list containing the given expressions, where the list has the given type
mkListExpr :: Type -> [CoreExpr] -> CoreExpr
mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs

-- | Make a fully applied 'foldr' expression
mkFoldrExpr :: MonadThings m
            => Type             -- ^ Element type of the list
            -> Type             -- ^ Fold result type
            -> CoreExpr         -- ^ "Cons" function expression for the fold
            -> CoreExpr         -- ^ "Nil" expression for the fold
            -> CoreExpr         -- ^ List expression being folded acress
            -> m CoreExpr
mkFoldrExpr elt_ty result_ty c n list = do
    foldr_id <- lookupId foldrName
    return (Var foldr_id `App` Type elt_ty
           `App` Type result_ty
           `App` c
           `App` n
           `App` list)

-- | Make a 'build' expression applied to a locally-bound worker function
mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m)
            => Type                                     -- ^ Type of list elements to be built
            -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's
                                                        -- of the binders for the build worker function, returns
                                                        -- the body of that worker
            -> m CoreExpr
mkBuildExpr elt_ty mk_build_inside = do
    n_tyvar <- newTyVar alphaTyVar
    let n_ty = mkTyVarTy n_tyvar
        c_ty = mkVisFunTysMany [elt_ty, n_ty] n_ty
    [c, n] <- sequence [mkSysLocalM (fsLit "c") ManyTy c_ty, mkSysLocalM (fsLit "n") ManyTy n_ty]

    build_inside <- mk_build_inside (c, c_ty) (n, n_ty)

    build_id <- lookupId buildName
    return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside
  where
    newTyVar tyvar_tmpl = do
      uniq <- getUniqueM
      return (setTyVarUnique tyvar_tmpl uniq)

{-
************************************************************************
*                                                                      *
             Manipulating Maybe data type
*                                                                      *
************************************************************************
-}


-- | Makes a Nothing for the specified type
mkNothingExpr :: Type -> CoreExpr
mkNothingExpr ty = mkConApp nothingDataCon [Type ty]

-- | Makes a Just from a value of the specified type
mkJustExpr :: Type -> CoreExpr -> CoreExpr
mkJustExpr ty val = mkConApp justDataCon [Type ty, val]


{-
************************************************************************
*                                                                      *
                      Error expressions
*                                                                      *
************************************************************************
-}

mkRuntimeErrorApp
        :: Id           -- Should be of type
                        --   forall (r::RuntimeRep) (a::TYPE r). Addr# -> a
                        --      or (a :: CONSTRAINT r)
                        --      where Addr# points to a UTF8 encoded string
        -> Type         -- The type to instantiate 'a'
        -> String       -- The string to print
        -> CoreExpr

mkRuntimeErrorApp err_id res_ty err_msg
  = mkApps (Var err_id) [ Type (getRuntimeRep res_ty)
                        , Type res_ty, err_string ]
  where
    err_string = Lit (mkLitString err_msg)

{-
************************************************************************
*                                                                      *
                     Error Ids
*                                                                      *
************************************************************************

GHC randomly injects these into the code.

@patError@ is just a version of @error@ for pattern-matching
failures.  It knows various ``codes'' which expand to longer
strings---this saves space!

@absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
well shouldn't be yanked on, but if one is, then you will get a
friendly message from @absentErr@ (rather than a totally random
crash).
-}

errorIds :: [Id]
errorIds
  = [ nON_EXHAUSTIVE_GUARDS_ERROR_ID,
      nO_METHOD_BINDING_ERROR_ID,
      pAT_ERROR_ID,
      rEC_CON_ERROR_ID,
      rEC_SEL_ERROR_ID,
      iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID,
      aBSENT_ERROR_ID,  aBSENT_CONSTRAINT_ERROR_ID,
      aBSENT_SUM_FIELD_ERROR_ID,
      tYPE_ERROR_ID   -- Used with Opt_DeferTypeErrors, see #10284
      ]

recSelErrorName, recConErrorName, patErrorName :: Name
nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
typeErrorName :: Name
absentSumFieldErrorName :: Name

recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID
recConErrorName     = err_nm "recConError"     recConErrorIdKey     rEC_CON_ERROR_ID
patErrorName        = err_nm "patError"        patErrorIdKey        pAT_ERROR_ID
typeErrorName       = err_nm "typeError"       typeErrorIdKey       tYPE_ERROR_ID

noMethodBindingErrorName     = err_nm "noMethodBindingError"
                                  noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"
                                  nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID

err_nm :: String -> Unique -> Id -> Name
err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id

rEC_SEL_ERROR_ID, rEC_CON_ERROR_ID :: Id
pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id
rEC_SEL_ERROR_ID                = mkRuntimeErrorId TypeLike recSelErrorName
rEC_CON_ERROR_ID                = mkRuntimeErrorId TypeLike recConErrorName
pAT_ERROR_ID                    = mkRuntimeErrorId TypeLike patErrorName
nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId TypeLike noMethodBindingErrorName
nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId TypeLike nonExhaustiveGuardsErrorName
tYPE_ERROR_ID                   = mkRuntimeErrorId TypeLike typeErrorName

-- Note [aBSENT_SUM_FIELD_ERROR_ID]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Unboxed sums are transformed into unboxed tuples in GHC.Stg.Unarise.mkUbxSum
-- and fields that can't be reached are filled with rubbish values.
-- For instance, consider the case of the program:
--
--     f :: (# Int | Float# #) -> Int
--     f = ...
--
--     x = f (# | 2.0## #)
--
-- Unarise will represent f's unboxed sum argument as a tuple (# Int#, Int,
-- Float# #), where Int# is a tag. Consequently, `x` will be rewritten to:
--
--     x = f (# 2#, ???, 2.0## #)
--
-- We must come up with some rubbish literal to use in place of `???`. In the
-- case of unboxed integer types this is easy: we can simply use 0 for
-- Int#/Word# and 0.0 Float#/Double#.
--
-- However, coming up with a rubbish pointer value is more delicate as the
-- value must satisfy the following requirements:
--
--    1. it needs to be a valid closure pointer for the GC (not a NULL pointer)
--
--    2. it can't take arguments because it's used in unarise and applying an
--       argument would require allocating a thunk, which is both difficult to
--       do and costly.
--
--    3. it shouldn't be CAFfy since this would make otherwise non-CAFfy
--       bindings CAFfy, incurring a cost in GC performance. Given that unboxed
--       sums are intended to be used in performance-critical code, this is to
--       We work-around this by declaring the absentSumFieldError as non-CAFfy,
--       as described in Note [Wired-in exceptions are not CAFfy].
--
--       Getting this wrong causes hard-to-debug runtime issues, see #15038.
--
--    4. it can't be defined in `base` package.  Afterall, not all code which
--       uses unboxed sums uses depends upon `base`.  Specifically, this became
--       an issue when we wanted to use unboxed sums in boot libraries used by
--       `base`, see #17791.
--
-- To fill this role we define `ghc-prim:GHC.Prim.Panic.absentSumFieldError`
-- with the type:
--
--    absentSumFieldError :: forall a. a
--
-- Note that this type is something of a lie since Unarise may use it at an
-- unlifted type. However, this lie is benign as absent sum fields are examined
-- only by the GC, which does not care about levity..
--
-- When entered, this closure calls `stg_panic#`, which immediately halts
-- execution and cannot be caught. This is in contrast to most other runtime
-- errors, which are thrown as proper Haskell exceptions. This design is
-- intentional since entering an absent sum field is an indication that
-- something has gone horribly wrong, very likely due to a compiler bug.
--

-- Note [Wired-in exceptions are not CAFfy]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- GHC has logic wiring-in a small number of exceptions, which may be thrown in
-- generated code. Specifically, these are implemented via closures (defined
-- in `GHC.Prim.Exception` in `ghc-prim`) which, when entered, raise the desired
-- exception. For instance, in the case of OverflowError we have
--
--     raiseOverflow :: forall a. a
--     raiseOverflow = runRW# (\s ->
--         case raiseOverflow# s of
--           (# _, _ #) -> let x = x in x)
--
-- where `raiseOverflow#` is defined in the rts/Exception.cmm.
--
-- Note that `raiseOverflow` and friends, being top-level thunks, are CAFs.
-- Normally, this would be reflected in their IdInfo; however, as these
-- functions are widely used and CAFfyness is transitive, we very much want to
-- avoid declaring them as CAFfy. This is especially true in especially in
-- performance-critical code like that using unboxed sums and
-- absentSumFieldError.
--
-- Consequently, `mkExceptionId` instead declares the exceptions to be
-- non-CAFfy and rather ensure in the RTS (in `initBuiltinGcRoots` in
-- rts/RtsStartup.c) that these closures remain reachable by creating a
-- StablePtr to each. Note that we are using the StablePtr mechanism not
-- because we need a StablePtr# object, but rather because the stable pointer
-- table is a source of GC roots.
--
-- At some point we could consider removing this optimisation as it is quite
-- fragile, but we do want to be careful to avoid adding undue cost. Unboxed
-- sums in particular are intended to be used in performance-critical contexts.
--
-- See #15038, #21141.

absentSumFieldErrorName
   = mkWiredInIdName
      gHC_PRIM_PANIC
      (fsLit "absentSumFieldError")
      absentSumFieldErrorIdKey
      aBSENT_SUM_FIELD_ERROR_ID

aBSENT_SUM_FIELD_ERROR_ID = mkExceptionId absentSumFieldErrorName

-- | Exception with type \"forall a. a\"
--
-- Any exceptions added via this function needs to be added to
-- the RTS's initBuiltinGcRoots() function.
mkExceptionId :: Name -> Id
mkExceptionId name
  = mkVanillaGlobalWithInfo name
      (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a
      (divergingIdInfo [] `setCafInfo` NoCafRefs)
         -- See Note [Wired-in exceptions are not CAFfy]

-- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID', that
-- throws an (imprecise) exception after being supplied one value arg for every
-- argument 'Demand' in the list. The demands end up in the demand signature.
--
-- 1. Sets the demand signature to unleash the given arg dmds 'botDiv'
-- 2. Sets the arity info so that it matches the length of arg demands
-- 3. Sets a bottoming CPR sig with the correct arity
--
-- It's important that all 3 agree on the arity, which is what this defn ensures.
divergingIdInfo :: [Demand] -> IdInfo
divergingIdInfo arg_dmds
  = vanillaIdInfo `setArityInfo` arity
                  `setDmdSigInfo` mkClosedDmdSig arg_dmds botDiv
                  `setCprSigInfo` mkCprSig arity botCpr
  where
    arity = length arg_dmds

{- Note [Error and friends have an "open-tyvar" forall]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'error' and 'undefined' have types
        error     :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a
        undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a
Notice the runtime-representation polymorphism. This ensures that
"error" can be instantiated at unboxed as well as boxed types.
This is OK because it never returns, so the return type is irrelevant.


************************************************************************
*                                                                      *
                     iMPOSSIBLE_ERROR_ID
*                                                                      *
************************************************************************
-}

iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID :: Id
iMPOSSIBLE_ERROR_ID            = mkRuntimeErrorId TypeLike       impossibleErrorName
iMPOSSIBLE_CONSTRAINT_ERROR_ID = mkRuntimeErrorId ConstraintLike impossibleConstraintErrorName

impossibleErrorName, impossibleConstraintErrorName :: Name
impossibleErrorName           = err_nm "impossibleError"
                                impossibleErrorIdKey iMPOSSIBLE_ERROR_ID
impossibleConstraintErrorName = err_nm "impossibleConstraintError"
                                impossibleConstraintErrorIdKey iMPOSSIBLE_CONSTRAINT_ERROR_ID

mkImpossibleExpr :: Type -> String -> CoreExpr
mkImpossibleExpr res_ty str
  = mkRuntimeErrorApp err_id res_ty str
  where    -- See Note [Type vs Constraint for error ids]
    err_id = case typeTypeOrConstraint res_ty of
               TypeLike       -> iMPOSSIBLE_ERROR_ID
               ConstraintLike -> iMPOSSIBLE_CONSTRAINT_ERROR_ID

{- Note [Type vs Constraint for error ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need both
  iMPOSSIBLE_ERROR_ID            :: forall (r::RuntimeRep) (a::TYPE r).       Addr# -> a
  iMPOSSIBLE_CONSTRAINT_ERROR_ID :: forall (r::RuntimeRep) (a::CONSTRAINT r). Addr# -> a

because we don't have polymorphism over TYPE vs CONSTRAINT.  You
might wonder if iMPOSSIBLE_CONSTRAINT_ERROR_ID is ever needed in
practice, but it is: see #22634.  So:

* In Control.Exception.Base we have
      impossibleError           :: forall (a::Type). Addr# -> a
      impossibleConstraintError :: forall (a::Type). Addr# -> a
  This generates the code for `impossibleError`, but because they are wired in
  the interface file definitions are never looked at (indeed, they don't
  even get serialised).

* In this module GHC.Core.Make we define /wired-in/ Ids for
      iMPOSSIBLE_ERROR_ID
      iMPOSSIBLE_CONSTRAINT_ERROR_ID
   with the desired above types (i.e. runtime-rep polymorphic, and returning a
   constraint for the latter.

Much the same plan works for aBSENT_ERROR_ID and aBSENT_CONSTRAINT_ERROR_ID


************************************************************************
*                                                                      *
                     aBSENT_ERROR_ID
*                                                                      *
************************************************************************

Note [aBSENT_ERROR_ID]
~~~~~~~~~~~~~~~~~~~~~~
We use aBSENT_ERROR_ID to build absent fillers for lifted types in workers. E.g.

   f x = (case x of (a,b) -> b) + 1::Int

The demand analyser figures out that only the second component of x is
used, and does a w/w split thus

   f x = case x of (a,b) -> $wf b

   $wf b = let a = absentError "blah"
               x = (a,b)
           in <the original RHS of f>

After some simplification, the (absentError "blah") thunk normally goes away.
See also Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils.

Historical Note
---------------
We used to have exprIsHNF respond True to absentError and *not* mark it as diverging.
Here's the reason for the former. It doesn't apply anymore because we no longer say
that `a` is absent (A). Instead it gets (head strict) demand 1A and we won't
emit the absent error:

#14285 had, roughly

   data T a = MkT a !a
   {-# INLINABLE f #-}
   f x = case x of MkT a b -> g (MkT b a)

It turned out that g didn't use the second component, and hence f doesn't use
the first.  But the stable-unfolding for f looks like
   \x. case x of MkT a b -> g ($WMkT b a)
where $WMkT is the wrapper for MkT that evaluates its arguments.  We
apply the same w/w split to this unfolding (see Note [Worker/wrapper
for INLINABLE functions] in GHC.Core.Opt.WorkWrap) so the template ends up like
   \b. let a = absentError "blah"
           x = MkT a b
        in case x of MkT a b -> g ($WMkT b a)

After doing case-of-known-constructor, and expanding $WMkT we get
   \b -> g (case absentError "blah" of a -> MkT b a)

Yikes!  That bogusly appears to evaluate the absentError!

This is extremely tiresome.  Another way to think of this is that, in
Core, it is an invariant that a strict data constructor, like MkT, must
be applied only to an argument in HNF. So (absentError "blah") had
better be non-bottom.

So the "solution" is to add a special case for absentError to exprIsHNFlike.
This allows Simplify.rebuildCase, in the Note [Case to let transformation]
branch, to convert the case on absentError into a let. We also make
absentError *not* be diverging, unlike the other error-ids, so that we
can be sure not to remove the case branches before converting the case to
a let.

If, by some bug or bizarre happenstance, we ever call absentError, we should
throw an exception.  This should never happen, of course, but we definitely
can't return anything.  e.g. if somehow we had
    case absentError "foo" of
       Nothing -> ...
       Just x  -> ...
then if we return, the case expression will select a field and continue.
Seg fault city. Better to throw an exception. (Even though we've said
it is in HNF :-)

It might seem a bit surprising that seq on absentError is simply erased

    absentError "foo" `seq` x ==> x

but that should be okay; since there's no pattern match we can't really
be relying on anything from it.
-}

-- We need two absentError Ids:
--   absentError           :: forall (a :: Type).       Addr# -> a
--   absentConstraintError :: forall (a :: Constraint). Addr# -> a
-- We don't have polymorphism over TypeOrConstraint!
-- mkAbsentErrorApp chooses which one to use, based on the kind
-- See Note [Type vs Constraint for error ids]

mkAbsentErrorApp :: Type         -- The type to instantiate 'a'
                 -> String       -- The string to print
                 -> CoreExpr

mkAbsentErrorApp res_ty err_msg
  = mkApps (Var err_id) [ Type res_ty, err_string ]
  where
    err_id = case typeTypeOrConstraint res_ty of
               TypeLike       -> aBSENT_ERROR_ID
               ConstraintLike -> aBSENT_CONSTRAINT_ERROR_ID
    err_string = Lit (mkLitString err_msg)

absentErrorName, absentConstraintErrorName :: Name
absentErrorName
   = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentError")
      absentErrorIdKey aBSENT_ERROR_ID

absentConstraintErrorName   -- See Note [Type vs Constraint for error ids]
   = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentConstraintError")
      absentConstraintErrorIdKey aBSENT_CONSTRAINT_ERROR_ID

aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID :: Id

aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID]
 = mk_runtime_error_id absentErrorName absent_ty
 where
   -- absentError :: forall (a :: Type). Addr# -> a
   absent_ty = mkSpecForAllTys [alphaTyVar] $
               mkVisFunTyMany addrPrimTy (mkTyVarTy alphaTyVar)
   -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
   -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils

aBSENT_CONSTRAINT_ERROR_ID -- See Note [aBSENT_ERROR_ID]
 = mk_runtime_error_id absentConstraintErrorName absent_ty
   -- See Note [Type vs Constraint for error ids]
 where
   -- absentConstraintError :: forall (a :: Constraint). Addr# -> a
   absent_ty = mkSpecForAllTys [alphaConstraintTyVar] $
               mkFunTy visArgConstraintLike ManyTy
                       addrPrimTy (mkTyVarTy alphaConstraintTyVar)


{-
************************************************************************
*                                                                      *
                     mkRuntimeErrorId
*                                                                      *
************************************************************************
-}

mkRuntimeErrorId :: TypeOrConstraint -> Name -> Id
-- Error function
--   with type:  forall (r:RuntimeRep) (a:TYPE r). Addr# -> a
--   with arity: 1
-- which diverges after being given one argument
-- The Addr# is expected to be the address of
--   a UTF8-encoded error string
mkRuntimeErrorId torc name = mk_runtime_error_id name (mkRuntimeErrorTy torc)


mk_runtime_error_id :: Name -> Type -> Id
mk_runtime_error_id name ty
 = mkVanillaGlobalWithInfo name ty (divergingIdInfo [evalDmd])
     -- Do *not* mark them as NoCafRefs, because they can indeed have
     -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
     -- which has some CAFs
     -- In due course we may arrange that these error-y things are
     -- regarded by the GC as permanently live, in which case we
     -- can give them NoCaf info.  As it is, any function that calls
     -- any pc_bottoming_Id will itself have CafRefs, which bloats
     -- SRTs.

mkRuntimeErrorTy :: TypeOrConstraint -> Type
-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
--   See Note [Error and friends have an "open-tyvar" forall]
mkRuntimeErrorTy torc = mkSpecForAllTys [runtimeRep1TyVar, tyvar] $
                        mkFunctionType ManyTy addrPrimTy (mkTyVarTy tyvar)
  where
    (tyvar:_) = mkTemplateTyVars [kind]
    kind = case torc of
              TypeLike       -> mkTYPEapp       runtimeRep1Ty
              ConstraintLike -> mkCONSTRAINTapp runtimeRep1Ty