{-# 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 :: [Id] -> [Id]
sortQuantVars [Id]
vs = [Id]
sorted_tcvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
ids
  where
    ([Id]
tcvs, [Id]
ids) = (Id -> Bool) -> [Id] -> ([Id], [Id])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Id -> Bool
isTyVar (Id -> Bool) -> (Id -> Bool) -> Id -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> Id -> Bool
isCoVar) [Id]
vs
    sorted_tcvs :: [Id]
sorted_tcvs = [Id] -> [Id]
scopedSort [Id]
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 :: CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (NonRec Id
bndr CoreExpr
rhs) CoreExpr
body        -- See Note [Core let-can-float invariant]
  = HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
bndr CoreExpr
rhs CoreExpr
body
mkCoreLet CoreBind
bind CoreExpr
body
  = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind CoreExpr
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 :: [Id] -> CoreExpr -> CoreExpr
mkCoreLams = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
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 :: [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
binds CoreExpr
body = (CoreBind -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreBind] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreBind -> CoreExpr -> CoreExpr
mkCoreLet CoreExpr
body [CoreBind]
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 :: DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
con [CoreExpr]
args = CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
con)) [CoreExpr]
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 :: CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps CoreExpr
fun [CoreExpr]
args
  = (CoreExpr, Kind) -> CoreExpr
forall a b. (a, b) -> a
fst ((CoreExpr, Kind) -> CoreExpr) -> (CoreExpr, Kind) -> CoreExpr
forall a b. (a -> b) -> a -> b
$
    ((CoreExpr, Kind) -> CoreExpr -> (CoreExpr, Kind))
-> (CoreExpr, Kind) -> [CoreExpr] -> (CoreExpr, Kind)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (SDoc -> (CoreExpr, Kind) -> CoreExpr -> (CoreExpr, Kind)
mkCoreAppTyped SDoc
doc_string) (CoreExpr
fun, Kind
fun_ty) [CoreExpr]
args
  where
    doc_string :: SDoc
doc_string = Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
fun_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
fun SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args
    fun_ty :: Kind
fun_ty = HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
fun

-- | Construct an expression which represents the application of one expression
-- to the other
mkCoreApp :: SDoc
          -> CoreExpr -- ^ function
          -> CoreExpr -- ^ argument
          -> CoreExpr
mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp SDoc
s CoreExpr
fun CoreExpr
arg
  = (CoreExpr, Kind) -> CoreExpr
forall a b. (a, b) -> a
fst ((CoreExpr, Kind) -> CoreExpr) -> (CoreExpr, Kind) -> CoreExpr
forall a b. (a -> b) -> a -> b
$ SDoc -> (CoreExpr, Kind) -> CoreExpr -> (CoreExpr, Kind)
mkCoreAppTyped SDoc
s (CoreExpr
fun, HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
fun) CoreExpr
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 :: SDoc -> (CoreExpr, Kind) -> CoreExpr -> (CoreExpr, Kind)
mkCoreAppTyped SDoc
_ (CoreExpr
fun, Kind
fun_ty) (Type Kind
ty)
  = (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun (Kind -> CoreExpr
forall b. Kind -> Expr b
Type Kind
ty), HasDebugCallStack => Kind -> Kind -> Kind
Kind -> Kind -> Kind
piResultTy Kind
fun_ty Kind
ty)
mkCoreAppTyped SDoc
_ (CoreExpr
fun, Kind
fun_ty) (Coercion Coercion
co)
  = (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun (Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
co), HasDebugCallStack => Kind -> Kind
Kind -> Kind
funResultTy Kind
fun_ty)
mkCoreAppTyped SDoc
d (CoreExpr
fun, Kind
fun_ty) CoreExpr
arg
  = Bool -> SDoc -> (CoreExpr, Kind) -> (CoreExpr, Kind)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Kind -> Bool
isFunTy Kind
fun_ty) (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
fun SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
arg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
d)
    (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun CoreExpr
arg, HasDebugCallStack => Kind -> Kind
Kind -> Kind
funResultTy Kind
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 :: Kind -> Kind -> Id
mkWildValBinder Kind
w Kind
ty = Name -> Kind -> Kind -> Id
mkLocalIdOrCoVar Name
wildCardName Kind
w Kind
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 :: CoreExpr -> Scaled Kind -> Kind -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
scrut (Scaled Kind
w Kind
scrut_ty) Kind
res_ty [CoreAlt]
alts
  = CoreExpr -> Id -> Kind -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Kind -> [Alt b] -> Expr b
Case CoreExpr
scrut (Kind -> Kind -> Id
mkWildValBinder Kind
w Kind
scrut_ty) Kind
res_ty [CoreAlt]
alts

mkIfThenElse :: CoreExpr -- ^ guard
             -> CoreExpr -- ^ then
             -> CoreExpr -- ^ else
             -> CoreExpr
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse CoreExpr
guard CoreExpr
then_expr CoreExpr
else_expr
-- Not going to be refining, so okay to take the type of the "then" clause
  = CoreExpr -> Scaled Kind -> Kind -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
guard (Kind -> Scaled Kind
forall a. a -> Scaled a
linear Kind
boolTy) (HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
then_expr)
         [ AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] CoreExpr
else_expr,       -- Increasing order of tag!
           AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  [] CoreExpr
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 :: CoreExpr -> Kind -> CoreExpr
castBottomExpr CoreExpr
e Kind
res_ty
  | Kind
e_ty Kind -> Kind -> Bool
`eqType` Kind
res_ty = CoreExpr
e
  | Bool
otherwise            = CoreExpr -> Id -> Kind -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Kind -> [Alt b] -> Expr b
Case CoreExpr
e (Kind -> Kind -> Id
mkWildValBinder Kind
OneTy Kind
e_ty) Kind
res_ty []
  where
    e_ty :: Kind
e_ty = HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
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 :: Kind -> Maybe CoreExpr
mkLitRubbish Kind
ty
  | Bool -> Bool
not (Kind -> Bool
noFreeVarsOfType Kind
rep)
  = Maybe CoreExpr
forall a. Maybe a
Nothing   -- Satisfy INVARIANT 1
  | Kind -> Bool
isCoVarType Kind
ty
  = Maybe CoreExpr
forall a. Maybe a
Nothing   -- Satisfy INVARIANT 2
  | Bool
otherwise
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (TypeOrConstraint -> Kind -> Literal
LitRubbish TypeOrConstraint
torc Kind
rep) CoreExpr -> [Kind] -> CoreExpr
forall b. Expr b -> [Kind] -> Expr b
`mkTyApps` [Kind
ty])
  where
    Just (TypeOrConstraint
torc, Kind
rep) = Kind -> Maybe (TypeOrConstraint, Kind)
sORTKind_maybe (HasDebugCallStack => Kind -> Kind
Kind -> Kind
typeKind Kind
ty)

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

-- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExpr :: Platform -> Integer -> CoreExpr        -- Result = I# i :: Int
mkIntExpr :: Platform -> Integer -> CoreExpr
mkIntExpr Platform
platform Integer
i = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
intDataCon  [Platform -> Integer -> CoreExpr
forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform Integer
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 :: Integer -> CoreExpr
mkUncheckedIntExpr Integer
i = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
intDataCon  [Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitIntUnchecked Integer
i)]

-- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExprInt :: Platform -> Int -> CoreExpr         -- Result = I# i :: Int
mkIntExprInt :: Platform -> Int -> CoreExpr
mkIntExprInt Platform
platform Int
i = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
intDataCon  [Platform -> Integer -> CoreExpr
forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)]

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

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

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

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

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


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

-- | Create a 'CoreExpr' which will evaluate to the given @String@
mkStringExpr   :: MonadThings m => String     -> m CoreExpr  -- Result :: String
mkStringExpr :: forall (m :: * -> *). MonadThings m => String -> m CoreExpr
mkStringExpr String
str = FastString -> m CoreExpr
forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS (String -> FastString
mkFastString String
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 :: forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS = (Name -> m Id) -> FastString -> m CoreExpr
forall (m :: * -> *).
Monad m =>
(Name -> m Id) -> FastString -> m CoreExpr
mkStringExprFSLookup Name -> m Id
forall (m :: * -> *). MonadThings m => Name -> m Id
lookupId

mkStringExprFSLookup :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr
mkStringExprFSLookup :: forall (m :: * -> *).
Monad m =>
(Name -> m Id) -> FastString -> m CoreExpr
mkStringExprFSLookup Name -> m Id
lookupM FastString
str = do
  MkStringIds
mk <- (Name -> m Id) -> m MkStringIds
forall (m :: * -> *).
Applicative m =>
(Name -> m Id) -> m MkStringIds
getMkStringIds Name -> m Id
lookupM
  CoreExpr -> m CoreExpr
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MkStringIds -> FastString -> CoreExpr
mkStringExprFSWith MkStringIds
mk FastString
str)

getMkStringIds :: Applicative m => (Name -> m Id) -> m MkStringIds
getMkStringIds :: forall (m :: * -> *).
Applicative m =>
(Name -> m Id) -> m MkStringIds
getMkStringIds Name -> m Id
lookupM = Id -> Id -> MkStringIds
MkStringIds (Id -> Id -> MkStringIds) -> m Id -> m (Id -> MkStringIds)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m Id
lookupM Name
unpackCStringName m (Id -> MkStringIds) -> m Id -> m MkStringIds
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> m Id
lookupM Name
unpackCStringUtf8Name

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

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

  | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
safeChar String
chars
  = let !unpack_id :: Id
unpack_id = MkStringIds -> Id
unpackCStringId MkStringIds
ids
    in CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
unpack_id) CoreExpr
lit

  | Bool
otherwise
  = let !unpack_utf8_id :: Id
unpack_utf8_id = MkStringIds -> Id
unpackCStringUtf8Id MkStringIds
ids
    in CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
unpack_utf8_id) CoreExpr
lit

  where
    chars :: String
chars = FastString -> String
unpackFS FastString
str
    safeChar :: Char -> Bool
safeChar Char
c = Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x7F
    lit :: CoreExpr
lit = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString (FastString -> ByteString
bytesFS FastString
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 :: HasDebugCallStack => [CoreExpr] -> CoreExpr
mkCoreBoxedTuple [CoreExpr]
cs
  = Bool
-> SDoc
-> (DataCon -> [CoreExpr] -> CoreExpr)
-> DataCon
-> [CoreExpr]
-> CoreExpr
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ((CoreExpr -> Bool) -> [CoreExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Kind -> Bool
tcIsLiftedTypeKind (Kind -> Bool) -> (CoreExpr -> Kind) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Kind -> Kind
Kind -> Kind
typeKind (Kind -> Kind) -> (CoreExpr -> Kind) -> CoreExpr -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType) [CoreExpr]
cs) ([CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
cs)
    DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed ([CoreExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
cs))
                  ((CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> CoreExpr
forall b. Kind -> Expr b
Type (Kind -> CoreExpr) -> (CoreExpr -> Kind) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType) [CoreExpr]
cs [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
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 :: [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple [CoreExpr]
exps
  = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
tys))
                  ((Kind -> CoreExpr) -> [Kind] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> CoreExpr
forall b. Kind -> Expr b
Type (Kind -> CoreExpr) -> (Kind -> Kind) -> Kind -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Kind -> Kind
Kind -> Kind
getRuntimeRep) [Kind]
tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ (Kind -> CoreExpr) -> [Kind] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> CoreExpr
forall b. Kind -> Expr b
Type [Kind]
tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
exps)
  where
    tys :: [Kind]
tys = (CoreExpr -> Kind) -> [CoreExpr] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType [CoreExpr]
exps

-- | Make a core tuple of the given boxity; don't flatten 1-tuples
mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
mkCoreTupBoxity Boxity
Boxed   [CoreExpr]
exps = [CoreExpr] -> CoreExpr
HasDebugCallStack => [CoreExpr] -> CoreExpr
mkCoreBoxedTuple   [CoreExpr]
exps
mkCoreTupBoxity Boxity
Unboxed [CoreExpr]
exps = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple [CoreExpr]
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 :: [Id] -> Kind
mkCoreVarTupTy [Id]
ids = [Kind] -> Kind
mkBoxedTupleTy ((Id -> Kind) -> [Id] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
idType [Id]
ids)

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

-- | Build an unboxed sum.
--
-- Alternative number ("alt") starts from 1.
mkCoreUnboxedSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUnboxedSum :: Int -> Int -> [Kind] -> CoreExpr -> CoreExpr
mkCoreUnboxedSum Int
arity Int
alt [Kind]
tys CoreExpr
exp
  = Bool -> CoreExpr -> CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert ([Kind] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
tys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arity) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
    Bool -> CoreExpr -> CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert (Int
alt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
arity) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
    DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Int -> Int -> DataCon
sumDataCon Int
alt Int
arity)
                  ((Kind -> CoreExpr) -> [Kind] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Kind -> CoreExpr
forall b. Kind -> Expr b
Type (Kind -> CoreExpr) -> (Kind -> Kind) -> Kind -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Kind -> Kind
Kind -> Kind
getRuntimeRep) [Kind]
tys
                   [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ (Kind -> CoreExpr) -> [Kind] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> CoreExpr
forall b. Kind -> Expr b
Type [Kind]
tys
                   [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr
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] -> CoreExpr
mkBigCoreVarTupSolo [Id
id] = [CoreExpr] -> CoreExpr
HasDebugCallStack => [CoreExpr] -> CoreExpr
mkCoreBoxedTuple [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
id]
mkBigCoreVarTupSolo [Id]
ids  = ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a. ([a] -> a) -> [a] -> a
mkChunkified [CoreExpr] -> CoreExpr
mkCoreTup ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
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 :: [Id] -> CoreExpr
mkBigCoreVarTup [Id]
ids = [CoreExpr] -> CoreExpr
mkBigCoreTup ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
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 :: [CoreExpr] -> CoreExpr
mkBigCoreTup [CoreExpr]
exprs = ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a. ([a] -> a) -> [a] -> a
mkChunkified [CoreExpr] -> CoreExpr
mkCoreTup ((CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> CoreExpr
wrapBox [CoreExpr]
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 :: [Id] -> Kind
mkBigCoreVarTupTy [Id]
ids = [Kind] -> Kind
mkBigCoreTupTy ((Id -> Kind) -> [Id] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
idType [Id]
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 :: [Kind] -> Kind
mkBigCoreTupTy [Kind]
tys = ([Kind] -> Kind) -> [Kind] -> Kind
forall a. ([a] -> a) -> [a] -> a
mkChunkified [Kind] -> Kind
mkBoxedTupleTy ([Kind] -> Kind) -> [Kind] -> Kind
forall a b. (a -> b) -> a -> b
$
                     (Kind -> Kind) -> [Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> Kind
boxTy [Kind]
tys

-- | The unit expression
unitExpr :: CoreExpr
unitExpr :: CoreExpr
unitExpr = Id -> CoreExpr
forall b. Id -> Expr b
Var Id
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 :: CoreExpr -> CoreExpr
wrapBox CoreExpr
e
  = case Kind -> BoxingInfo Id
forall b. Kind -> BoxingInfo b
boxingDataCon Kind
e_ty of
      BoxingInfo Id
BI_NoBoxNeeded                       -> CoreExpr
e
      BI_Box { bi_inst_con :: forall b. BoxingInfo b -> Expr b
bi_inst_con = CoreExpr
boxing_expr } -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
boxing_expr CoreExpr
e
      BoxingInfo Id
BI_NoBoxAvailable -> String -> SDoc -> CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"wrapBox" (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
e))
                           -- We should do better than panicing: #22336
  where
    e_ty :: Kind
e_ty = HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
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 :: Kind -> Kind
boxTy Kind
ty
  = case Kind -> BoxingInfo Any
forall b. Kind -> BoxingInfo b
boxingDataCon Kind
ty of
      BoxingInfo Any
BI_NoBoxNeeded -> Kind
ty
      BI_Box { bi_boxed_type :: forall b. BoxingInfo b -> Kind
bi_boxed_type = Kind
box_ty } -> Kind
box_ty
      BoxingInfo Any
BI_NoBoxAvailable -> String -> SDoc -> Kind
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"boxTy" (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
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 :: UniqSupply -> Id -> CoreExpr -> (UniqSupply, Id, CoreExpr)
unwrapBox UniqSupply
us Id
var CoreExpr
body
  = case Kind -> BoxingInfo Any
forall b. Kind -> BoxingInfo b
boxingDataCon Kind
var_ty of
      BoxingInfo Any
BI_NoBoxNeeded    -> (UniqSupply
us, Id
var, CoreExpr
body)
      BoxingInfo Any
BI_NoBoxAvailable -> String -> SDoc -> (UniqSupply, Id, CoreExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unwrapBox" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
var SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
var_ty)
                           -- We should do better than panicing: #22336
      BI_Box { bi_data_con :: forall b. BoxingInfo b -> DataCon
bi_data_con = DataCon
box_con, bi_boxed_type :: forall b. BoxingInfo b -> Kind
bi_boxed_type = Kind
box_ty }
         -> (UniqSupply
us', Id
var', CoreExpr
body')
         where
           var' :: Id
var'  = FastString -> Unique -> Kind -> Kind -> Id
mkSysLocal (String -> FastString
fsLit String
"uc") Unique
uniq Kind
ManyTy Kind
box_ty
           body' :: CoreExpr
body' = CoreExpr -> Id -> Kind -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Kind -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var') Id
var' (HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
body)
                        [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
box_con) [Id
var] CoreExpr
body]
  where
    var_ty :: Kind
var_ty      = Id -> Kind
idType Id
var
    (Unique
uniq, UniqSupply
us') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
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 :: forall a. ([a] -> a) -> [a] -> a
mkChunkified [a] -> a
small_tuple [a]
as = [[a]] -> a
mk_big_tuple ([a] -> [[a]]
forall a. [a] -> [[a]]
chunkify [a]
as)
  where
        -- Each sub-list is short enough to fit in a tuple
    mk_big_tuple :: [[a]] -> a
mk_big_tuple [[a]
as] = [a] -> a
small_tuple [a]
as
    mk_big_tuple [[a]]
as_s = [[a]] -> a
mk_big_tuple ([a] -> [[a]]
forall a. [a] -> [[a]]
chunkify (([a] -> a) -> [[a]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> a
small_tuple [[a]]
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 :: forall a. [a] -> [[a]]
chunkify [a]
xs
  | Int
n_xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
mAX_TUPLE_SIZE = [[a]
xs]
  | Bool
otherwise              = [a] -> [[a]]
forall a. [a] -> [[a]]
split [a]
xs
  where
    n_xs :: Int
n_xs     = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
    split :: [a] -> [[a]]
split [] = []
    split [a]
xs = let ([a]
as, [a]
bs) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
mAX_TUPLE_SIZE [a]
xs
               in [a]
as [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]]
split [a]
bs


{-
************************************************************************
*                                                                      *
\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 :: [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkBigTupleSelector [Id]
vars Id
the_var Id
scrut_var CoreExpr
scrut
  = [[Id]] -> Id -> CoreExpr
mk_tup_sel ([Id] -> [[Id]]
forall a. [a] -> [[a]]
chunkify [Id]
vars) Id
the_var
  where
    mk_tup_sel :: [[Id]] -> Id -> CoreExpr
mk_tup_sel [[Id]
vars] Id
the_var = [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkSmallTupleSelector [Id]
vars Id
the_var Id
scrut_var CoreExpr
scrut
    mk_tup_sel [[Id]]
vars_s Id
the_var = [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkSmallTupleSelector [Id]
group Id
the_var Id
tpl_v (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                                [[Id]] -> Id -> CoreExpr
mk_tup_sel ([Id] -> [[Id]]
forall a. [a] -> [[a]]
chunkify [Id]
tpl_vs) Id
tpl_v
        where
          tpl_tys :: [Kind]
tpl_tys = [[Kind] -> Kind
mkBoxedTupleTy ((Id -> Kind) -> [Id] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
idType [Id]
gp) | [Id]
gp <- [[Id]]
vars_s]
          tpl_vs :: [Id]
tpl_vs  = [Kind] -> [Id]
mkTemplateLocals [Kind]
tpl_tys
          [(Id
tpl_v, [Id]
group)] = [(Id
tpl,[Id]
gp) | (Id
tpl,[Id]
gp) <- String -> [Id] -> [[Id]] -> [(Id, [Id])]
forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"mkBigTupleSelector" [Id]
tpl_vs [[Id]]
vars_s,
                                         Id
the_var Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
gp ]
-- ^ 'mkBigTupleSelectorSolo' is like 'mkBigTupleSelector'
-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
mkBigTupleSelectorSolo :: [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkBigTupleSelectorSolo [Id]
vars Id
the_var Id
scrut_var CoreExpr
scrut
  | [Id
_] <- [Id]
vars
  = [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkSmallTupleSelector1 [Id]
vars Id
the_var Id
scrut_var CoreExpr
scrut
  | Bool
otherwise
  = [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkBigTupleSelector [Id]
vars Id
the_var Id
scrut_var CoreExpr
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 :: [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkSmallTupleSelector [Id
var] Id
should_be_the_same_var Id
_ CoreExpr
scrut
  = Bool -> CoreExpr -> CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert (Id
var Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
should_be_the_same_var) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
    CoreExpr
scrut  -- Special case for 1-tuples
mkSmallTupleSelector [Id]
vars Id
the_var Id
scrut_var CoreExpr
scrut
  = [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkSmallTupleSelector1 [Id]
vars Id
the_var Id
scrut_var CoreExpr
scrut

-- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector'
-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
mkSmallTupleSelector1 :: [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkSmallTupleSelector1 [Id]
vars Id
the_var Id
scrut_var CoreExpr
scrut
  = Bool -> CoreExpr -> CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert ([Id] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Id]
vars) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
    CoreExpr -> Id -> Kind -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Kind -> [Alt b] -> Expr b
Case CoreExpr
scrut Id
scrut_var (Id -> Kind
idType Id
the_var)
         [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
vars))) [Id]
vars (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
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 :: MonadUnique m    --   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
               -> m 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 :: forall (m :: * -> *).
MonadUnique m =>
[Id] -> CoreExpr -> CoreExpr -> m CoreExpr
mkBigTupleCase [Id]
vars CoreExpr
body CoreExpr
scrut
  = do UniqSupply
us <- m UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
       let (UniqSupply
wrapped_us, [Id]
wrapped_vars, CoreExpr
wrapped_body) = (Id
 -> (UniqSupply, [Id], CoreExpr) -> (UniqSupply, [Id], CoreExpr))
-> (UniqSupply, [Id], CoreExpr)
-> [Id]
-> (UniqSupply, [Id], 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 -> (UniqSupply, [Id], CoreExpr) -> (UniqSupply, [Id], CoreExpr)
unwrap (UniqSupply
us,[],CoreExpr
body) [Id]
vars
       CoreExpr -> m CoreExpr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> m CoreExpr) -> CoreExpr -> m CoreExpr
forall a b. (a -> b) -> a -> b
$ UniqSupply -> [[Id]] -> CoreExpr -> CoreExpr
mk_tuple_case UniqSupply
wrapped_us ([Id] -> [[Id]]
forall a. [a] -> [[a]]
chunkify [Id]
wrapped_vars) CoreExpr
wrapped_body
  where
    scrut_ty :: Kind
scrut_ty = HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
scrut

    unwrap :: Id -> (UniqSupply, [Id], CoreExpr) -> (UniqSupply, [Id], CoreExpr)
unwrap Id
var (UniqSupply
us,[Id]
vars,CoreExpr
body)
      = (UniqSupply
us', Id
var'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
vars, CoreExpr
body')
      where
        (UniqSupply
us', Id
var', CoreExpr
body') = UniqSupply -> Id -> CoreExpr -> (UniqSupply, Id, CoreExpr)
unwrapBox UniqSupply
us Id
var CoreExpr
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 :: UniqSupply -> [[Id]] -> CoreExpr -> CoreExpr
mk_tuple_case UniqSupply
us [[Id]
vars] CoreExpr
body
      = [Id] -> CoreExpr -> Id -> CoreExpr -> CoreExpr
mkSmallTupleCase [Id]
vars CoreExpr
body Id
scrut_var CoreExpr
scrut
      where
        scrut_var :: Id
scrut_var = case CoreExpr
scrut of
                       Var Id
v -> Id
v
                       CoreExpr
_ -> (UniqSupply, Id) -> Id
forall a b. (a, b) -> b
snd (UniqSupply -> Kind -> (UniqSupply, Id)
new_var UniqSupply
us Kind
scrut_ty)

    -- This is the case where we must nest tuples at least once
    mk_tuple_case UniqSupply
us [[Id]]
vars_s CoreExpr
body
      = UniqSupply -> [[Id]] -> CoreExpr -> CoreExpr
mk_tuple_case UniqSupply
us' ([Id] -> [[Id]]
forall a. [a] -> [[a]]
chunkify [Id]
vars') CoreExpr
body'
      where
        (UniqSupply
us', [Id]
vars', CoreExpr
body') = ([Id]
 -> (UniqSupply, [Id], CoreExpr) -> (UniqSupply, [Id], CoreExpr))
-> (UniqSupply, [Id], CoreExpr)
-> [[Id]]
-> (UniqSupply, [Id], 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]
-> (UniqSupply, [Id], CoreExpr) -> (UniqSupply, [Id], CoreExpr)
one_tuple_case (UniqSupply
us, [], CoreExpr
body) [[Id]]
vars_s

    one_tuple_case :: [Id]
-> (UniqSupply, [Id], CoreExpr) -> (UniqSupply, [Id], CoreExpr)
one_tuple_case [Id]
chunk_vars (UniqSupply
us, [Id]
vs, CoreExpr
body)
      = (UniqSupply
us', Id
scrut_varId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
vs, CoreExpr
body')
      where
        tup_ty :: Kind
tup_ty           = [Kind] -> Kind
mkBoxedTupleTy ((Id -> Kind) -> [Id] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
idType [Id]
chunk_vars)
        (UniqSupply
us', Id
scrut_var) = UniqSupply -> Kind -> (UniqSupply, Id)
new_var UniqSupply
us Kind
tup_ty
        body' :: CoreExpr
body' = [Id] -> CoreExpr -> Id -> CoreExpr -> CoreExpr
mkSmallTupleCase [Id]
chunk_vars CoreExpr
body Id
scrut_var (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
scrut_var)

    new_var :: UniqSupply -> Type -> (UniqSupply, Id)
    new_var :: UniqSupply -> Kind -> (UniqSupply, Id)
new_var UniqSupply
us Kind
ty = (UniqSupply
us', Id
id)
       where
         (Unique
uniq, UniqSupply
us') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us
         id :: Id
id = FastString -> Unique -> Kind -> Kind -> Id
mkSysLocal (String -> FastString
fsLit String
"ds") Unique
uniq Kind
ManyTy Kind
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 :: [Id] -> CoreExpr -> Id -> CoreExpr -> CoreExpr
mkSmallTupleCase [Id
var] CoreExpr
body Id
_scrut_var CoreExpr
scrut
  = HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
var CoreExpr
scrut CoreExpr
body
mkSmallTupleCase [Id]
vars CoreExpr
body Id
scrut_var CoreExpr
scrut
  = CoreExpr -> Id -> Kind -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Kind -> [Alt b] -> Expr b
Case CoreExpr
scrut Id
scrut_var (HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
body)
         [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
vars))) [Id]
vars CoreExpr
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 :: FloatBind -> SDoc
ppr (FloatLet CoreBind
b) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"LET" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
b
  ppr (FloatCase CoreExpr
e Id
b AltCon
c [Id]
bs) = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CASE" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b)
                                Int
2 (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
c SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
bs)

wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
wrapFloat (FloatLet CoreBind
defns)       CoreExpr
body = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
defns CoreExpr
body
wrapFloat (FloatCase CoreExpr
e Id
b AltCon
con [Id]
bs) CoreExpr
body = CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
e Id
b AltCon
con [Id]
bs CoreExpr
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 :: [FloatBind] -> CoreExpr -> CoreExpr
wrapFloats [FloatBind]
floats CoreExpr
expr = (FloatBind -> CoreExpr -> CoreExpr)
-> CoreExpr -> [FloatBind] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FloatBind -> CoreExpr -> CoreExpr
wrapFloat CoreExpr
expr [FloatBind]
floats

bindBindings :: CoreBind -> [Var]
bindBindings :: CoreBind -> [Id]
bindBindings (NonRec Id
b CoreExpr
_) = [Id
b]
bindBindings (Rec [(Id, CoreExpr)]
bnds) = ((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)]
bnds

floatBindings :: FloatBind -> [Var]
floatBindings :: FloatBind -> [Id]
floatBindings (FloatLet CoreBind
bnd) = CoreBind -> [Id]
bindBindings CoreBind
bnd
floatBindings (FloatCase CoreExpr
_ Id
b AltCon
_ [Id]
bs) = Id
bId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
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 :: Kind -> CoreExpr
mkNilExpr Kind
ty = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
nilDataCon [Kind -> CoreExpr
forall b. Kind -> Expr b
Type Kind
ty]

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

-- | Make a list containing the given expressions, where the list has the given type
mkListExpr :: Type -> [CoreExpr] -> CoreExpr
mkListExpr :: Kind -> [CoreExpr] -> CoreExpr
mkListExpr Kind
ty [CoreExpr]
xs = (CoreExpr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Kind -> CoreExpr -> CoreExpr -> CoreExpr
mkConsExpr Kind
ty) (Kind -> CoreExpr
mkNilExpr Kind
ty) [CoreExpr]
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 :: forall (m :: * -> *).
MonadThings m =>
Kind -> Kind -> CoreExpr -> CoreExpr -> CoreExpr -> m CoreExpr
mkFoldrExpr Kind
elt_ty Kind
result_ty CoreExpr
c CoreExpr
n CoreExpr
list = do
    Id
foldr_id <- Name -> m Id
forall (m :: * -> *). MonadThings m => Name -> m Id
lookupId Name
foldrName
    CoreExpr -> m CoreExpr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
foldr_id CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Kind -> CoreExpr
forall b. Kind -> Expr b
Type Kind
elt_ty
           CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Kind -> CoreExpr
forall b. Kind -> Expr b
Type Kind
result_ty
           CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
c
           CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
n
           CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
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 :: forall (m :: * -> *).
(MonadFail m, MonadThings m, MonadUnique m) =>
Kind -> ((Id, Kind) -> (Id, Kind) -> m CoreExpr) -> m CoreExpr
mkBuildExpr Kind
elt_ty (Id, Kind) -> (Id, Kind) -> m CoreExpr
mk_build_inside = do
    Id
n_tyvar <- Id -> m Id
forall {m :: * -> *}. MonadUnique m => Id -> m Id
newTyVar Id
alphaTyVar
    let n_ty :: Kind
n_ty = Id -> Kind
mkTyVarTy Id
n_tyvar
        c_ty :: Kind
c_ty = [Kind] -> Kind -> Kind
mkVisFunTysMany [Kind
elt_ty, Kind
n_ty] Kind
n_ty
    [Id
c, Id
n] <- [m Id] -> m [Id]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [FastString -> Kind -> Kind -> m Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> Kind -> Kind -> m Id
mkSysLocalM (String -> FastString
fsLit String
"c") Kind
ManyTy Kind
c_ty, FastString -> Kind -> Kind -> m Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> Kind -> Kind -> m Id
mkSysLocalM (String -> FastString
fsLit String
"n") Kind
ManyTy Kind
n_ty]

    CoreExpr
build_inside <- (Id, Kind) -> (Id, Kind) -> m CoreExpr
mk_build_inside (Id
c, Kind
c_ty) (Id
n, Kind
n_ty)

    Id
build_id <- Name -> m Id
forall (m :: * -> *). MonadThings m => Name -> m Id
lookupId Name
buildName
    CoreExpr -> m CoreExpr
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> m CoreExpr) -> CoreExpr -> m CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr
forall b. Id -> Expr b
Var Id
build_id CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Kind -> CoreExpr
forall b. Kind -> Expr b
Type Kind
elt_ty CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
n_tyvar, Id
c, Id
n] CoreExpr
build_inside
  where
    newTyVar :: Id -> m Id
newTyVar Id
tyvar_tmpl = do
      Unique
uniq <- m Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
      Id -> m Id
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Unique -> Id
setTyVarUnique Id
tyvar_tmpl Unique
uniq)

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


-- | Makes a Nothing for the specified type
mkNothingExpr :: Type -> CoreExpr
mkNothingExpr :: Kind -> CoreExpr
mkNothingExpr Kind
ty = DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
nothingDataCon [Kind -> CoreExpr
forall b. Kind -> Expr b
Type Kind
ty]

-- | Makes a Just from a value of the specified type
mkJustExpr :: Type -> CoreExpr -> CoreExpr
mkJustExpr :: Kind -> CoreExpr -> CoreExpr
mkJustExpr Kind
ty CoreExpr
val = DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
justDataCon [Kind -> CoreExpr
forall b. Kind -> Expr b
Type Kind
ty, CoreExpr
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 :: Id -> Kind -> String -> CoreExpr
mkRuntimeErrorApp Id
err_id Kind
res_ty String
err_msg
  = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
err_id) [ Kind -> CoreExpr
forall b. Kind -> Expr b
Type (HasDebugCallStack => Kind -> Kind
Kind -> Kind
getRuntimeRep Kind
res_ty)
                        , Kind -> CoreExpr
forall b. Kind -> Expr b
Type Kind
res_ty, CoreExpr
err_string ]
  where
    err_string :: CoreExpr
err_string = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (String -> Literal
mkLitString String
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 :: [Id]
errorIds
  = [ Id
nON_EXHAUSTIVE_GUARDS_ERROR_ID,
      Id
nO_METHOD_BINDING_ERROR_ID,
      Id
pAT_ERROR_ID,
      Id
rEC_CON_ERROR_ID,
      Id
rEC_SEL_ERROR_ID,
      Id
iMPOSSIBLE_ERROR_ID, Id
iMPOSSIBLE_CONSTRAINT_ERROR_ID,
      Id
aBSENT_ERROR_ID,  Id
aBSENT_CONSTRAINT_ERROR_ID,
      Id
aBSENT_SUM_FIELD_ERROR_ID,
      Id
tYPE_ERROR_ID   -- Used with Opt_DeferTypeErrors, see #10284
      ]

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

recSelErrorName :: Name
recSelErrorName     = String -> Unique -> Id -> Name
err_nm String
"recSelError"     Unique
recSelErrorIdKey     Id
rEC_SEL_ERROR_ID
recConErrorName :: Name
recConErrorName     = String -> Unique -> Id -> Name
err_nm String
"recConError"     Unique
recConErrorIdKey     Id
rEC_CON_ERROR_ID
patErrorName :: Name
patErrorName        = String -> Unique -> Id -> Name
err_nm String
"patError"        Unique
patErrorIdKey        Id
pAT_ERROR_ID
typeErrorName :: Name
typeErrorName       = String -> Unique -> Id -> Name
err_nm String
"typeError"       Unique
typeErrorIdKey       Id
tYPE_ERROR_ID

noMethodBindingErrorName :: Name
noMethodBindingErrorName     = String -> Unique -> Id -> Name
err_nm String
"noMethodBindingError"
                                  Unique
noMethodBindingErrorIdKey Id
nO_METHOD_BINDING_ERROR_ID
nonExhaustiveGuardsErrorName :: Name
nonExhaustiveGuardsErrorName = String -> Unique -> Id -> Name
err_nm String
"nonExhaustiveGuardsError"
                                  Unique
nonExhaustiveGuardsErrorIdKey Id
nON_EXHAUSTIVE_GUARDS_ERROR_ID

err_nm :: String -> Unique -> Id -> Name
err_nm :: String -> Unique -> Id -> Name
err_nm String
str Unique
uniq Id
id = Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName Module
cONTROL_EXCEPTION_BASE (String -> FastString
fsLit String
str) Unique
uniq Id
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 :: Id
rEC_SEL_ERROR_ID                = TypeOrConstraint -> Name -> Id
mkRuntimeErrorId TypeOrConstraint
TypeLike Name
recSelErrorName
rEC_CON_ERROR_ID :: Id
rEC_CON_ERROR_ID                = TypeOrConstraint -> Name -> Id
mkRuntimeErrorId TypeOrConstraint
TypeLike Name
recConErrorName
pAT_ERROR_ID :: Id
pAT_ERROR_ID                    = TypeOrConstraint -> Name -> Id
mkRuntimeErrorId TypeOrConstraint
TypeLike Name
patErrorName
nO_METHOD_BINDING_ERROR_ID :: Id
nO_METHOD_BINDING_ERROR_ID      = TypeOrConstraint -> Name -> Id
mkRuntimeErrorId TypeOrConstraint
TypeLike Name
noMethodBindingErrorName
nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
nON_EXHAUSTIVE_GUARDS_ERROR_ID  = TypeOrConstraint -> Name -> Id
mkRuntimeErrorId TypeOrConstraint
TypeLike Name
nonExhaustiveGuardsErrorName
tYPE_ERROR_ID :: Id
tYPE_ERROR_ID                   = TypeOrConstraint -> Name -> Id
mkRuntimeErrorId TypeOrConstraint
TypeLike Name
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 :: Name
absentSumFieldErrorName
   = Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName
      Module
gHC_PRIM_PANIC
      (String -> FastString
fsLit String
"absentSumFieldError")
      Unique
absentSumFieldErrorIdKey
      Id
aBSENT_SUM_FIELD_ERROR_ID

aBSENT_SUM_FIELD_ERROR_ID :: Id
aBSENT_SUM_FIELD_ERROR_ID = Name -> Id
mkExceptionId Name
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 -> Id
mkExceptionId Name
name
  = Name -> Kind -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
name
      ([Id] -> Kind -> Kind
mkSpecForAllTys [Id
alphaTyVar] (Id -> Kind
mkTyVarTy Id
alphaTyVar)) -- forall a . a
      ([Demand] -> IdInfo
divergingIdInfo [] IdInfo -> CafInfo -> IdInfo
`setCafInfo` CafInfo
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 :: [Demand] -> IdInfo
divergingIdInfo [Demand]
arg_dmds
  = IdInfo
vanillaIdInfo IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
                  IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` [Demand] -> Divergence -> DmdSig
mkClosedDmdSig [Demand]
arg_dmds Divergence
botDiv
                  IdInfo -> CprSig -> IdInfo
`setCprSigInfo` Int -> Cpr -> CprSig
mkCprSig Int
arity Cpr
botCpr
  where
    arity :: Int
arity = [Demand] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Demand]
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 :: Id
iMPOSSIBLE_ERROR_ID            = TypeOrConstraint -> Name -> Id
mkRuntimeErrorId TypeOrConstraint
TypeLike       Name
impossibleErrorName
iMPOSSIBLE_CONSTRAINT_ERROR_ID :: Id
iMPOSSIBLE_CONSTRAINT_ERROR_ID = TypeOrConstraint -> Name -> Id
mkRuntimeErrorId TypeOrConstraint
ConstraintLike Name
impossibleConstraintErrorName

impossibleErrorName, impossibleConstraintErrorName :: Name
impossibleErrorName :: Name
impossibleErrorName           = String -> Unique -> Id -> Name
err_nm String
"impossibleError"
                                Unique
impossibleErrorIdKey Id
iMPOSSIBLE_ERROR_ID
impossibleConstraintErrorName :: Name
impossibleConstraintErrorName = String -> Unique -> Id -> Name
err_nm String
"impossibleConstraintError"
                                Unique
impossibleConstraintErrorIdKey Id
iMPOSSIBLE_CONSTRAINT_ERROR_ID

mkImpossibleExpr :: Type -> String -> CoreExpr
mkImpossibleExpr :: Kind -> String -> CoreExpr
mkImpossibleExpr Kind
res_ty String
str
  = Id -> Kind -> String -> CoreExpr
mkRuntimeErrorApp Id
err_id Kind
res_ty String
str
  where    -- See Note [Type vs Constraint for error ids]
    err_id :: Id
err_id = case HasDebugCallStack => Kind -> TypeOrConstraint
Kind -> TypeOrConstraint
typeTypeOrConstraint Kind
res_ty of
               TypeOrConstraint
TypeLike       -> Id
iMPOSSIBLE_ERROR_ID
               TypeOrConstraint
ConstraintLike -> Id
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 :: Kind -> String -> CoreExpr
mkAbsentErrorApp Kind
res_ty String
err_msg
  = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
err_id) [ Kind -> CoreExpr
forall b. Kind -> Expr b
Type Kind
res_ty, CoreExpr
err_string ]
  where
    err_id :: Id
err_id = case HasDebugCallStack => Kind -> TypeOrConstraint
Kind -> TypeOrConstraint
typeTypeOrConstraint Kind
res_ty of
               TypeOrConstraint
TypeLike       -> Id
aBSENT_ERROR_ID
               TypeOrConstraint
ConstraintLike -> Id
aBSENT_CONSTRAINT_ERROR_ID
    err_string :: CoreExpr
err_string = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (String -> Literal
mkLitString String
err_msg)

absentErrorName, absentConstraintErrorName :: Name
absentErrorName :: Name
absentErrorName
   = Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM_PANIC (String -> FastString
fsLit String
"absentError")
      Unique
absentErrorIdKey Id
aBSENT_ERROR_ID

absentConstraintErrorName :: Name
absentConstraintErrorName   -- See Note [Type vs Constraint for error ids]
   = Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName Module
gHC_PRIM_PANIC (String -> FastString
fsLit String
"absentConstraintError")
      Unique
absentConstraintErrorIdKey Id
aBSENT_CONSTRAINT_ERROR_ID

aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID :: Id

aBSENT_ERROR_ID :: Id
aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID]
 = Name -> Kind -> Id
mk_runtime_error_id Name
absentErrorName Kind
absent_ty
 where
   -- absentError :: forall (a :: Type). Addr# -> a
   absent_ty :: Kind
absent_ty = [Id] -> Kind -> Kind
mkSpecForAllTys [Id
alphaTyVar] (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
               HasDebugCallStack => Kind -> Kind -> Kind
Kind -> Kind -> Kind
mkVisFunTyMany Kind
addrPrimTy (Id -> Kind
mkTyVarTy Id
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 :: Id
aBSENT_CONSTRAINT_ERROR_ID -- See Note [aBSENT_ERROR_ID]
 = Name -> Kind -> Id
mk_runtime_error_id Name
absentConstraintErrorName Kind
absent_ty
   -- See Note [Type vs Constraint for error ids]
 where
   -- absentConstraintError :: forall (a :: Constraint). Addr# -> a
   absent_ty :: Kind
absent_ty = [Id] -> Kind -> Kind
mkSpecForAllTys [Id
alphaConstraintTyVar] (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
               HasDebugCallStack => FunTyFlag -> Kind -> Kind -> Kind -> Kind
FunTyFlag -> Kind -> Kind -> Kind -> Kind
mkFunTy FunTyFlag
visArgConstraintLike Kind
ManyTy
                       Kind
addrPrimTy (Id -> Kind
mkTyVarTy Id
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 :: TypeOrConstraint -> Name -> Id
mkRuntimeErrorId TypeOrConstraint
torc Name
name = Name -> Kind -> Id
mk_runtime_error_id Name
name (TypeOrConstraint -> Kind
mkRuntimeErrorTy TypeOrConstraint
torc)


mk_runtime_error_id :: Name -> Type -> Id
mk_runtime_error_id :: Name -> Kind -> Id
mk_runtime_error_id Name
name Kind
ty
 = Name -> Kind -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
name Kind
ty ([Demand] -> IdInfo
divergingIdInfo [Demand
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 :: TypeOrConstraint -> Kind
mkRuntimeErrorTy TypeOrConstraint
torc = [Id] -> Kind -> Kind
mkSpecForAllTys [Id
runtimeRep1TyVar, Id
tyvar] (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
                        HasDebugCallStack => Kind -> Kind -> Kind -> Kind
Kind -> Kind -> Kind -> Kind
mkFunctionType Kind
ManyTy Kind
addrPrimTy (Id -> Kind
mkTyVarTy Id
tyvar)
  where
    (Id
tyvar:[Id]
_) = [Kind] -> [Id]
mkTemplateTyVars [Kind
kind]
    kind :: Kind
kind = case TypeOrConstraint
torc of
              TypeOrConstraint
TypeLike       -> Kind -> Kind
mkTYPEapp       Kind
runtimeRep1Ty
              TypeOrConstraint
ConstraintLike -> Kind -> Kind
mkCONSTRAINTapp Kind
runtimeRep1Ty