{-# LANGUAGE CPP #-}

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

        -- * Constructing boxed literals
        mkWordExpr, mkWordExprWord,
        mkIntExpr, mkIntExprInt,
        mkIntegerExpr, mkNaturalExpr,
        mkFloatExpr, mkDoubleExpr,
        mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,

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

        -- * Constructing small tuples
        mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup,
        mkCoreTupBoxity, unitExpr,

        -- * Constructing big tuples
        mkBigCoreVarTup, mkBigCoreVarTup1,
        mkBigCoreVarTupTy, mkBigCoreTupTy,
        mkBigCoreTup,

        -- * Deconstructing small tuples
        mkSmallTupleSelector, mkSmallTupleCase,

        -- * Deconstructing big tuples
        mkTupleSelector, mkTupleSelector1, mkTupleCase,

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

        -- * Constructing Maybe expressions
        mkNothingExpr, mkJustExpr,

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

#include "HsVersions.h"

import GhcPrelude

import Id
import Var      ( EvVar, setTyVarUnique )

import CoreSyn
import CoreUtils        ( exprType, needsCaseBinding, bindNonRec )
import Literal
import HscTypes

import TysWiredIn
import PrelNames

import HsUtils          ( mkChunkified, chunkify )
import Type
import Coercion         ( isCoVar )
import TysPrim
import DataCon          ( DataCon, dataConWorkId )
import IdInfo
import Demand
import Name      hiding ( varName )
import Outputable
import FastString
import UniqSupply
import BasicTypes
import Util
import DynFlags
import Data.List

import Data.Char        ( ord )
import Control.Monad.Fail as MonadFail ( MonadFail )

infixl 4 `mkCoreApp`, `mkCoreApps`

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

-- | Bind a binding group over an expression, using a @let@ or @case@ as
-- appropriate (see "CoreSyn#let_app_invariant")
mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (NonRec bndr :: Var
bndr rhs :: CoreExpr
rhs) body :: CoreExpr
body        -- See Note [CoreSyn let/app invariant]
  = Var -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Var
bndr CoreExpr
rhs CoreExpr
body
mkCoreLet bind :: CoreBind
bind body :: CoreExpr
body
  = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind CoreExpr
body

-- | 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 binds :: [CoreBind]
binds body :: CoreExpr
body = (CoreBind -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreBind] -> CoreExpr
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 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'.
-- Respects the let/app invariant by building a case expression where necessary
--   See CoreSyn Note [CoreSyn let/app invariant]
mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
mkCoreAppTyped _ (fun :: CoreExpr
fun, fun_ty :: Type
fun_ty) (Type ty :: Type
ty)
  = (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun (Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty), HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
piResultTy Type
fun_ty Type
ty)
mkCoreAppTyped _ (fun :: CoreExpr
fun, fun_ty :: Type
fun_ty) (Coercion co :: 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), Type
res_ty)
  where
    (_, res_ty :: Type
res_ty) = Type -> (Type, Type)
splitFunTy Type
fun_ty
mkCoreAppTyped d :: SDoc
d (fun :: CoreExpr
fun, fun_ty :: Type
fun_ty) arg :: CoreExpr
arg
  = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
    (CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
mk_val_app CoreExpr
fun CoreExpr
arg Type
arg_ty Type
res_ty, Type
res_ty)
  where
    (arg_ty :: Type
arg_ty, res_ty :: Type
res_ty) = Type -> (Type, Type)
splitFunTy Type
fun_ty

-- | Construct an expression which represents the application of one expression
-- to the other
-- Respects the let/app invariant by building a case expression where necessary
--   See CoreSyn Note [CoreSyn let/app invariant]
mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp s :: SDoc
s fun :: CoreExpr
fun arg :: CoreExpr
arg
  = (CoreExpr, Type) -> CoreExpr
forall a b. (a, b) -> a
fst ((CoreExpr, Type) -> CoreExpr) -> (CoreExpr, Type) -> CoreExpr
forall a b. (a -> b) -> a -> b
$ SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
mkCoreAppTyped SDoc
s (CoreExpr
fun, CoreExpr -> Type
exprType CoreExpr
fun) CoreExpr
arg

-- | Construct an expression which represents the application of a number of
-- expressions to another. The leftmost expression in the list is applied first
-- Respects the let/app invariant by building a case expression where necessary
--   See CoreSyn Note [CoreSyn let/app invariant]
mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps fun :: CoreExpr
fun args :: [CoreExpr]
args
  = (CoreExpr, Type) -> CoreExpr
forall a b. (a, b) -> a
fst ((CoreExpr, Type) -> CoreExpr) -> (CoreExpr, Type) -> CoreExpr
forall a b. (a -> b) -> a -> b
$
    ((CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type))
-> (CoreExpr, Type) -> [CoreExpr] -> (CoreExpr, Type)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
mkCoreAppTyped SDoc
doc_string) (CoreExpr
fun, Type
fun_ty) [CoreExpr]
args
  where
    doc_string :: SDoc
doc_string = Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun_ty SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
fun SDoc -> SDoc -> SDoc
$$ [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args
    fun_ty :: Type
fun_ty = CoreExpr -> Type
exprType CoreExpr
fun

-- | 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 con :: DataCon
con args :: [CoreExpr]
args = CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (Var -> CoreExpr
forall b. Var -> Expr b
Var (DataCon -> Var
dataConWorkId DataCon
con)) [CoreExpr]
args

mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
-- Build an application (e1 e2),
-- or a strict binding  (case e2 of x -> e1 x)
-- using the latter when necessary to respect the let/app invariant
--   See Note [CoreSyn let/app invariant]
mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
mk_val_app fun :: CoreExpr
fun arg :: CoreExpr
arg arg_ty :: Type
arg_ty res_ty :: Type
res_ty
  | Bool -> Bool
not (Type -> CoreExpr -> Bool
needsCaseBinding Type
arg_ty CoreExpr
arg)
  = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun CoreExpr
arg                -- The vastly common case

  | Bool
otherwise
  = CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Var
arg_id Type
res_ty [(AltCon
DEFAULT,[],CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
arg_id))]
  where
    arg_id :: Var
arg_id = Type -> Var
mkWildValBinder Type
arg_ty
        -- Lots of shadowing, but it doesn't matter,
        -- because 'fun ' should not have a free wild-id
        --
        -- This is Dangerous.  But this is the only place we play this
        -- game, mk_val_app returns an expression that does not have
        -- a free wild-id.  So the only thing that can go wrong
        -- is if you take apart this case expression, and pass a
        -- fragment of it as the fun part of a 'mk_val_app'.

-----------
mkWildEvBinder :: PredType -> EvVar
mkWildEvBinder :: Type -> Var
mkWildEvBinder pred :: Type
pred = Type -> Var
mkWildValBinder Type
pred

-- | 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 SimplEnv
mkWildValBinder :: Type -> Id
mkWildValBinder :: Type -> Var
mkWildValBinder ty :: Type
ty = Name -> Type -> Var
mkLocalIdOrCoVar Name
wildCardName Type
ty

mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
-- Make a case expression whose case binder is unused
-- The alts should not have any occurrences of WildId
mkWildCase :: CoreExpr -> Type -> Type -> [Alt Var] -> CoreExpr
mkWildCase scrut :: CoreExpr
scrut scrut_ty :: Type
scrut_ty res_ty :: Type
res_ty alts :: [Alt Var]
alts
  = CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut (Type -> Var
mkWildValBinder Type
scrut_ty) Type
res_ty [Alt Var]
alts

mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse guard :: CoreExpr
guard then_expr :: CoreExpr
then_expr else_expr :: CoreExpr
else_expr
-- Not going to be refining, so okay to take the type of the "then" clause
  = CoreExpr -> Type -> Type -> [Alt Var] -> CoreExpr
mkWildCase CoreExpr
guard Type
boolTy (CoreExpr -> Type
exprType CoreExpr
then_expr)
         [ (DataCon -> AltCon
DataAlt DataCon
falseDataCon, [], CoreExpr
else_expr),       -- Increasing order of tag!
           (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 CoreSyn
castBottomExpr :: CoreExpr -> Type -> CoreExpr
castBottomExpr e :: CoreExpr
e res_ty :: Type
res_ty
  | Type
e_ty Type -> Type -> Bool
`eqType` Type
res_ty = CoreExpr
e
  | Bool
otherwise            = CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
e (Type -> Var
mkWildValBinder Type
e_ty) Type
res_ty []
  where
    e_ty :: Type
e_ty = CoreExpr -> Type
exprType CoreExpr
e

{-
The functions from this point don't really do anything cleverer than
their counterparts in CoreSyn, but they are here for consistency
-}

-- | 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 :: [Var] -> CoreExpr -> CoreExpr
mkCoreLams = [Var] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams

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

-- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExpr :: DynFlags -> Integer -> CoreExpr        -- Result = I# i :: Int
mkIntExpr :: DynFlags -> Integer -> CoreExpr
mkIntExpr dflags :: DynFlags
dflags i :: Integer
i = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
intDataCon  [DynFlags -> Integer -> CoreExpr
forall b. DynFlags -> Integer -> Expr b
mkIntLit DynFlags
dflags Integer
i]

-- | Create a 'CoreExpr' which will evaluate to the given @Int@
mkIntExprInt :: DynFlags -> Int -> CoreExpr         -- Result = I# i :: Int
mkIntExprInt :: DynFlags -> Int -> CoreExpr
mkIntExprInt dflags :: DynFlags
dflags i :: Int
i = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
intDataCon  [DynFlags -> Int -> CoreExpr
forall b. DynFlags -> Int -> Expr b
mkIntLitInt DynFlags
dflags Int
i]

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

-- | Create a 'CoreExpr' which will evaluate to the given @Word@
mkWordExprWord :: DynFlags -> Word -> CoreExpr
mkWordExprWord :: DynFlags -> Word -> CoreExpr
mkWordExprWord dflags :: DynFlags
dflags w :: Word
w = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
wordDataCon [DynFlags -> Word -> CoreExpr
forall b. DynFlags -> Word -> Expr b
mkWordLitWord DynFlags
dflags Word
w]

-- | Create a 'CoreExpr' which will evaluate to the given @Integer@
mkIntegerExpr  :: MonadThings m => Integer -> m CoreExpr  -- Result :: Integer
mkIntegerExpr :: Integer -> m CoreExpr
mkIntegerExpr i :: Integer
i = do TyCon
t <- Name -> m TyCon
forall (m :: * -> *). MonadThings m => Name -> m TyCon
lookupTyCon Name
integerTyConName
                     CoreExpr -> m CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Type -> Literal
mkLitInteger Integer
i (TyCon -> Type
mkTyConTy TyCon
t)))

-- | Create a 'CoreExpr' which will evaluate to the given @Natural@
mkNaturalExpr  :: MonadThings m => Integer -> m CoreExpr
mkNaturalExpr :: Integer -> m CoreExpr
mkNaturalExpr i :: Integer
i = do TyCon
t <- Name -> m TyCon
forall (m :: * -> *). MonadThings m => Name -> m TyCon
lookupTyCon Name
naturalTyConName
                     CoreExpr -> m CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Type -> Literal
mkLitNatural Integer
i (TyCon -> Type
mkTyConTy TyCon
t)))

-- | Create a 'CoreExpr' which will evaluate to the given @Float@
mkFloatExpr :: Float -> CoreExpr
mkFloatExpr :: Float -> CoreExpr
mkFloatExpr f :: 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 d :: 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 c :: 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

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

mkStringExpr :: String -> m CoreExpr
mkStringExpr str :: String
str = FastString -> m CoreExpr
forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS (String -> FastString
mkFastString String
str)

mkStringExprFS :: FastString -> m CoreExpr
mkStringExprFS = (Name -> m Var) -> FastString -> m CoreExpr
forall (m :: * -> *).
Monad m =>
(Name -> m Var) -> FastString -> m CoreExpr
mkStringExprFSWith Name -> m Var
forall (m :: * -> *). MonadThings m => Name -> m Var
lookupId

mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr
mkStringExprFSWith :: (Name -> m Var) -> FastString -> m CoreExpr
mkStringExprFSWith lookupM :: Name -> m Var
lookupM str :: FastString
str
  | FastString -> Bool
nullFS FastString
str
  = CoreExpr -> m CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> CoreExpr
mkNilExpr Type
charTy)

  | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
safeChar String
chars
  = do Var
unpack_id <- Name -> m Var
lookupM Name
unpackCStringName
       CoreExpr -> m CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
unpack_id) CoreExpr
forall b. Expr b
lit)

  | Bool
otherwise
  = do Var
unpack_utf8_id <- Name -> m Var
lookupM Name
unpackCStringUtf8Name
       CoreExpr -> m CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
unpack_utf8_id) CoreExpr
forall b. Expr b
lit)

  where
    chars :: String
chars = FastString -> String
unpackFS FastString
str
    safeChar :: Char -> Bool
safeChar c :: Char
c = Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 1 Bool -> Bool -> Bool
&& Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x7F
    lit :: Expr b
lit = Literal -> Expr b
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString (FastString -> ByteString
fastStringToByteString FastString
str))

{-
************************************************************************
*                                                                      *
\subsection{Tuple constructors}
*                                                                      *
************************************************************************
-}

{-
Creating tuples and their types for Core expressions

@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@.

* If it has only one element, it is the identity function.

* If there are more elements than a big tuple can have, it nests
  the tuples.

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 TysWiredIn)
    mkCoreTup1 [e1] = Unit e1
  We use a suffix "1" to indicate this.

Usually we want the former, but occasionally the latter.
-}

-- | Build a small tuple holding the specified variables
-- One-tuples are flattened; see Note [Flattening one-tuples]
mkCoreVarTup :: [Id] -> CoreExpr
mkCoreVarTup :: [Var] -> CoreExpr
mkCoreVarTup ids :: [Var]
ids = [CoreExpr] -> CoreExpr
mkCoreTup ((Var -> CoreExpr) -> [Var] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Var -> CoreExpr
forall b. Var -> Expr b
Var [Var]
ids)

-- | 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 :: [Var] -> Type
mkCoreVarTupTy ids :: [Var]
ids = [Type] -> Type
mkBoxedTupleTy ((Var -> Type) -> [Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
idType [Var]
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 []  = Var -> CoreExpr
forall b. Var -> Expr b
Var Var
unitDataConId
mkCoreTup [c :: CoreExpr
c] = CoreExpr
c
mkCoreTup cs :: [CoreExpr]
cs  = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed ([CoreExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
cs))
                              ((CoreExpr -> CoreExpr) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> CoreExpr
forall b. Type -> Expr b
Type (Type -> CoreExpr) -> (CoreExpr -> Type) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Type
exprType) [CoreExpr]
cs [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
cs)

-- | Build a small unboxed tuple holding the specified expressions,
-- with the given types. The types must be the types of the expressions.
-- Do not include the RuntimeRep specifiers; this function calculates them
-- for you.
-- Does /not/ flatten one-tuples; see Note [Flattening one-tuples]
mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup tys :: [Type]
tys exps :: [CoreExpr]
exps
  = ASSERT( tys `equalLength` exps)
    DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys))
             ((Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> CoreExpr
forall b. Type -> Expr b
Type (Type -> CoreExpr) -> (Type -> Type) -> Type -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep) [Type]
tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ (Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type [Type]
tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
exps)

-- | Make a core tuple of the given boxity
mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
mkCoreTupBoxity Boxed   exps :: [CoreExpr]
exps = [CoreExpr] -> CoreExpr
mkCoreTup [CoreExpr]
exps
mkCoreTupBoxity Unboxed exps :: [CoreExpr]
exps = [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup ((CoreExpr -> Type) -> [CoreExpr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> Type
exprType [CoreExpr]
exps) [CoreExpr]
exps

-- | Build a big tuple holding the specified variables
-- One-tuples are flattened; see Note [Flattening one-tuples]
mkBigCoreVarTup :: [Id] -> CoreExpr
mkBigCoreVarTup :: [Var] -> CoreExpr
mkBigCoreVarTup ids :: [Var]
ids = [CoreExpr] -> CoreExpr
mkBigCoreTup ((Var -> CoreExpr) -> [Var] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Var -> CoreExpr
forall b. Var -> Expr b
Var [Var]
ids)

mkBigCoreVarTup1 :: [Id] -> CoreExpr
-- Same as mkBigCoreVarTup, but one-tuples are NOT flattened
--                          see Note [Flattening one-tuples]
mkBigCoreVarTup1 :: [Var] -> CoreExpr
mkBigCoreVarTup1 [id :: Var
id] = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed 1)
                                      [Type -> CoreExpr
forall b. Type -> Expr b
Type (Var -> Type
idType Var
id), Var -> CoreExpr
forall b. Var -> Expr b
Var Var
id]
mkBigCoreVarTup1 ids :: [Var]
ids  = [CoreExpr] -> CoreExpr
mkBigCoreTup ((Var -> CoreExpr) -> [Var] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Var -> CoreExpr
forall b. Var -> Expr b
Var [Var]
ids)

-- | 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 :: [Var] -> Type
mkBigCoreVarTupTy ids :: [Var]
ids = [Type] -> Type
mkBigCoreTupTy ((Var -> Type) -> [Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
idType [Var]
ids)

-- | Build a big tuple holding the specified expressions
-- One-tuples are flattened; see Note [Flattening one-tuples]
mkBigCoreTup :: [CoreExpr] -> CoreExpr
mkBigCoreTup :: [CoreExpr] -> CoreExpr
mkBigCoreTup = ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a. ([a] -> a) -> [a] -> a
mkChunkified [CoreExpr] -> CoreExpr
mkCoreTup

-- | 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 :: [Type] -> Type
mkBigCoreTupTy = ([Type] -> Type) -> [Type] -> Type
forall a. ([a] -> a) -> [a] -> a
mkChunkified [Type] -> Type
mkBoxedTupleTy

-- | The unit expression
unitExpr :: CoreExpr
unitExpr :: CoreExpr
unitExpr = Var -> CoreExpr
forall b. Var -> Expr b
Var Var
unitDataConId

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

-- | Builds a selector which scrutises 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.
mkTupleSelector, mkTupleSelector1
    :: [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

-- mkTupleSelector [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
mkTupleSelector :: [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkTupleSelector vars :: [Var]
vars the_var :: Var
the_var scrut_var :: Var
scrut_var scrut :: CoreExpr
scrut
  = [[Var]] -> Var -> CoreExpr
mk_tup_sel ([Var] -> [[Var]]
forall a. [a] -> [[a]]
chunkify [Var]
vars) Var
the_var
  where
    mk_tup_sel :: [[Var]] -> Var -> CoreExpr
mk_tup_sel [vars :: [Var]
vars] the_var :: Var
the_var = [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkSmallTupleSelector [Var]
vars Var
the_var Var
scrut_var CoreExpr
scrut
    mk_tup_sel vars_s :: [[Var]]
vars_s the_var :: Var
the_var = [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkSmallTupleSelector [Var]
group Var
the_var Var
tpl_v (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                                [[Var]] -> Var -> CoreExpr
mk_tup_sel ([Var] -> [[Var]]
forall a. [a] -> [[a]]
chunkify [Var]
tpl_vs) Var
tpl_v
        where
          tpl_tys :: [Type]
tpl_tys = [[Type] -> Type
mkBoxedTupleTy ((Var -> Type) -> [Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
idType [Var]
gp) | [Var]
gp <- [[Var]]
vars_s]
          tpl_vs :: [Var]
tpl_vs  = [Type] -> [Var]
mkTemplateLocals [Type]
tpl_tys
          [(tpl_v :: Var
tpl_v, group :: [Var]
group)] = [(Var
tpl,[Var]
gp) | (tpl :: Var
tpl,gp :: [Var]
gp) <- String -> [Var] -> [[Var]] -> [(Var, [Var])]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual "mkTupleSelector" [Var]
tpl_vs [[Var]]
vars_s,
                                         Var
the_var Var -> [Var] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Var]
gp ]
-- ^ 'mkTupleSelector1' is like 'mkTupleSelector'
-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
mkTupleSelector1 :: [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkTupleSelector1 vars :: [Var]
vars the_var :: Var
the_var scrut_var :: Var
scrut_var scrut :: CoreExpr
scrut
  | [_] <- [Var]
vars
  = [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkSmallTupleSelector1 [Var]
vars Var
the_var Var
scrut_var CoreExpr
scrut
  | Bool
otherwise
  = [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkTupleSelector [Var]
vars Var
the_var Var
scrut_var CoreExpr
scrut

-- | Like 'mkTupleSelector' but for tuples that are guaranteed
-- never to be \"big\".
--
-- > 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] -> Var -> Var -> CoreExpr -> CoreExpr
mkSmallTupleSelector [var :: Var
var] should_be_the_same_var :: Var
should_be_the_same_var _ scrut :: CoreExpr
scrut
  = ASSERT(var == should_be_the_same_var)
    CoreExpr
scrut  -- Special case for 1-tuples
mkSmallTupleSelector vars :: [Var]
vars the_var :: Var
the_var scrut_var :: Var
scrut_var scrut :: CoreExpr
scrut
  = [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkSmallTupleSelector1 [Var]
vars Var
the_var Var
scrut_var CoreExpr
scrut

-- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector'
-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
mkSmallTupleSelector1 :: [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkSmallTupleSelector1 vars :: [Var]
vars the_var :: Var
the_var scrut_var :: Var
scrut_var scrut :: CoreExpr
scrut
  = ASSERT( notNull vars )
    CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Var
scrut_var (Var -> Type
idType Var
the_var)
         [(DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed ([Var] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Var]
vars)), [Var]
vars, Var -> CoreExpr
forall b. Var -> Expr b
Var Var
the_var)]

-- | A generalization of 'mkTupleSelector', 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.
mkTupleCase :: UniqSupply       -- ^ For inventing names of intermediate variables
            -> [Id]             -- ^ The tuple identifiers to pattern match on
            -> CoreExpr         -- ^ Body of the case
            -> Id               -- ^ A variable of the same type as the scrutinee
            -> CoreExpr         -- ^ Scrutinee
            -> CoreExpr
-- ToDo: eliminate cases where none of the variables are needed.
--
--         mkTupleCase 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 }}}
mkTupleCase :: UniqSupply -> [Var] -> CoreExpr -> Var -> CoreExpr -> CoreExpr
mkTupleCase uniqs :: UniqSupply
uniqs vars :: [Var]
vars body :: CoreExpr
body scrut_var :: Var
scrut_var scrut :: CoreExpr
scrut
  = UniqSupply -> [[Var]] -> CoreExpr -> CoreExpr
mk_tuple_case UniqSupply
uniqs ([Var] -> [[Var]]
forall a. [a] -> [[a]]
chunkify [Var]
vars) CoreExpr
body
  where
    -- This is the case where don't need any nesting
    mk_tuple_case :: UniqSupply -> [[Var]] -> CoreExpr -> CoreExpr
mk_tuple_case _ [vars :: [Var]
vars] body :: CoreExpr
body
      = [Var] -> CoreExpr -> Var -> CoreExpr -> CoreExpr
mkSmallTupleCase [Var]
vars CoreExpr
body Var
scrut_var CoreExpr
scrut

    -- This is the case where we must make nest tuples at least once
    mk_tuple_case us :: UniqSupply
us vars_s :: [[Var]]
vars_s body :: CoreExpr
body
      = let (us' :: UniqSupply
us', vars' :: [Var]
vars', body' :: CoreExpr
body') = ([Var]
 -> (UniqSupply, [Var], CoreExpr) -> (UniqSupply, [Var], CoreExpr))
-> (UniqSupply, [Var], CoreExpr)
-> [[Var]]
-> (UniqSupply, [Var], CoreExpr)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Var]
-> (UniqSupply, [Var], CoreExpr) -> (UniqSupply, [Var], CoreExpr)
one_tuple_case (UniqSupply
us, [], CoreExpr
body) [[Var]]
vars_s
            in UniqSupply -> [[Var]] -> CoreExpr -> CoreExpr
mk_tuple_case UniqSupply
us' ([Var] -> [[Var]]
forall a. [a] -> [[a]]
chunkify [Var]
vars') CoreExpr
body'

    one_tuple_case :: [Var]
-> (UniqSupply, [Var], CoreExpr) -> (UniqSupply, [Var], CoreExpr)
one_tuple_case chunk_vars :: [Var]
chunk_vars (us :: UniqSupply
us, vs :: [Var]
vs, body :: CoreExpr
body)
      = let (uniq :: Unique
uniq, us' :: UniqSupply
us') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us
            scrut_var :: Var
scrut_var = FastString -> Unique -> Type -> Var
mkSysLocal (String -> FastString
fsLit "ds") Unique
uniq
              ([Type] -> Type
mkBoxedTupleTy ((Var -> Type) -> [Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
idType [Var]
chunk_vars))
            body' :: CoreExpr
body' = [Var] -> CoreExpr -> Var -> CoreExpr -> CoreExpr
mkSmallTupleCase [Var]
chunk_vars CoreExpr
body Var
scrut_var (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
scrut_var)
        in (UniqSupply
us', Var
scrut_varVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
vs, CoreExpr
body')

-- | As 'mkTupleCase', 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] -> CoreExpr -> Var -> CoreExpr -> CoreExpr
mkSmallTupleCase [var :: Var
var] body :: CoreExpr
body _scrut_var :: Var
_scrut_var scrut :: CoreExpr
scrut
  = Var -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Var
var CoreExpr
scrut CoreExpr
body
mkSmallTupleCase vars :: [Var]
vars body :: CoreExpr
body scrut_var :: Var
scrut_var scrut :: CoreExpr
scrut
-- One branch no refinement?
  = CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Var
scrut_var (CoreExpr -> Type
exprType CoreExpr
body)
         [(DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed ([Var] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Var]
vars)), [Var]
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 SetLevels

instance Outputable FloatBind where
  ppr :: FloatBind -> SDoc
ppr (FloatLet b :: CoreBind
b) = String -> SDoc
text "LET" SDoc -> SDoc -> SDoc
<+> CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
b
  ppr (FloatCase e :: CoreExpr
e b :: Var
b c :: AltCon
c bs :: [Var]
bs) = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "CASE" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit "of") SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
b)
                                2 (AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
c SDoc -> SDoc -> SDoc
<+> [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
bs)

wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
wrapFloat (FloatLet defns :: CoreBind
defns)       body :: CoreExpr
body = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
defns CoreExpr
body
wrapFloat (FloatCase e :: CoreExpr
e b :: Var
b con :: AltCon
con bs :: [Var]
bs) body :: CoreExpr
body = CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
e Var
b (CoreExpr -> Type
exprType CoreExpr
body) [(AltCon
con, [Var]
bs, CoreExpr
body)]

{-
************************************************************************
*                                                                      *
\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 :: Type -> CoreExpr
mkNilExpr ty :: Type
ty = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
nilDataCon [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty]

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

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

    CoreExpr
build_inside <- (Var, Type) -> (Var, Type) -> m CoreExpr
mk_build_inside (Var
c, Type
c_ty) (Var
n, Type
n_ty)

    Var
build_id <- Name -> m Var
forall (m :: * -> *). MonadThings m => Name -> m Var
lookupId Name
buildName
    CoreExpr -> m CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> m CoreExpr) -> CoreExpr -> m CoreExpr
forall a b. (a -> b) -> a -> b
$ Var -> CoreExpr
forall b. Var -> Expr b
Var Var
build_id CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Type -> CoreExpr
forall b. Type -> Expr b
Type Type
elt_ty CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` [Var] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Var
n_tyvar, Var
c, Var
n] CoreExpr
build_inside
  where
    newTyVars :: [Var] -> m [Var]
newTyVars tyvar_tmpls :: [Var]
tyvar_tmpls = do
      [Unique]
uniqs <- m [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
      [Var] -> m [Var]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Var -> Unique -> Var) -> [Var] -> [Unique] -> [Var]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Var -> Unique -> Var
setTyVarUnique [Var]
tyvar_tmpls [Unique]
uniqs)

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


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

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


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

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

mkRuntimeErrorApp :: Var -> Type -> String -> CoreExpr
mkRuntimeErrorApp err_id :: Var
err_id res_ty :: Type
res_ty err_msg :: String
err_msg
  = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
err_id) [ Type -> CoreExpr
forall b. Type -> Expr b
Type (HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
res_ty)
                        , Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty, CoreExpr
forall b. Expr b
err_string ]
  where
    err_string :: Expr b
err_string = Literal -> Expr b
forall b. Literal -> Expr b
Lit (String -> Literal
mkLitString String
err_msg)

mkImpossibleExpr :: Type -> CoreExpr
mkImpossibleExpr :: Type -> CoreExpr
mkImpossibleExpr res_ty :: Type
res_ty
  = Var -> Type -> String -> CoreExpr
mkRuntimeErrorApp Var
rUNTIME_ERROR_ID Type
res_ty "Impossible case alternative"

{-
************************************************************************
*                                                                      *
                     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).

@parError@ is a special version of @error@ which the compiler does
not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
templates, but we don't ever expect to generate code for it.
-}

errorIds :: [Id]
errorIds :: [Var]
errorIds
  = [ Var
rUNTIME_ERROR_ID,
      Var
nON_EXHAUSTIVE_GUARDS_ERROR_ID,
      Var
nO_METHOD_BINDING_ERROR_ID,
      Var
pAT_ERROR_ID,
      Var
rEC_CON_ERROR_ID,
      Var
rEC_SEL_ERROR_ID,
      Var
aBSENT_ERROR_ID,
      Var
tYPE_ERROR_ID   -- Used with Opt_DeferTypeErrors, see #10284
      ]

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

recSelErrorName :: Name
recSelErrorName     = String -> Unique -> Var -> Name
err_nm "recSelError"     Unique
recSelErrorIdKey     Var
rEC_SEL_ERROR_ID
absentErrorName :: Name
absentErrorName     = String -> Unique -> Var -> Name
err_nm "absentError"     Unique
absentErrorIdKey     Var
aBSENT_ERROR_ID
absentSumFieldErrorName :: Name
absentSumFieldErrorName = String -> Unique -> Var -> Name
err_nm "absentSumFieldError"  Unique
absentSumFieldErrorIdKey
                            Var
aBSENT_SUM_FIELD_ERROR_ID
runtimeErrorName :: Name
runtimeErrorName    = String -> Unique -> Var -> Name
err_nm "runtimeError"    Unique
runtimeErrorIdKey    Var
rUNTIME_ERROR_ID
recConErrorName :: Name
recConErrorName     = String -> Unique -> Var -> Name
err_nm "recConError"     Unique
recConErrorIdKey     Var
rEC_CON_ERROR_ID
patErrorName :: Name
patErrorName        = String -> Unique -> Var -> Name
err_nm "patError"        Unique
patErrorIdKey        Var
pAT_ERROR_ID
typeErrorName :: Name
typeErrorName       = String -> Unique -> Var -> Name
err_nm "typeError"       Unique
typeErrorIdKey       Var
tYPE_ERROR_ID

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

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

rEC_SEL_ERROR_ID, rUNTIME_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_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id
rEC_SEL_ERROR_ID :: Var
rEC_SEL_ERROR_ID                = Name -> Var
mkRuntimeErrorId Name
recSelErrorName
rUNTIME_ERROR_ID :: Var
rUNTIME_ERROR_ID                = Name -> Var
mkRuntimeErrorId Name
runtimeErrorName
rEC_CON_ERROR_ID :: Var
rEC_CON_ERROR_ID                = Name -> Var
mkRuntimeErrorId Name
recConErrorName
pAT_ERROR_ID :: Var
pAT_ERROR_ID                    = Name -> Var
mkRuntimeErrorId Name
patErrorName
nO_METHOD_BINDING_ERROR_ID :: Var
nO_METHOD_BINDING_ERROR_ID      = Name -> Var
mkRuntimeErrorId Name
noMethodBindingErrorName
nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Var
nON_EXHAUSTIVE_GUARDS_ERROR_ID  = Name -> Var
mkRuntimeErrorId Name
nonExhaustiveGuardsErrorName
tYPE_ERROR_ID :: Var
tYPE_ERROR_ID                   = Name -> Var
mkRuntimeErrorId Name
typeErrorName

-- Note [aBSENT_SUM_FIELD_ERROR_ID]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Absent argument error for unused unboxed sum fields are different than absent
-- error used in dummy worker functions (see `mkAbsentErrorApp`):
--
-- - `absentSumFieldError` can't take arguments because it's used in unarise for
--   unused pointer fields in unboxed sums, and applying an argument would
--   require allocating a thunk.
--
-- - `absentSumFieldError` can't be CAFFY because that would mean making some
--   non-CAFFY definitions that use unboxed sums CAFFY in unarise.
--
--   To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in
--   RtsStartup.c and mark it as non-CAFFY here.
--
-- Getting this wrong causes hard-to-debug runtime issues, see #15038.
--
-- TODO: Remove stable pointer hack after fixing #9718.
--       However, we should still be careful about not making things CAFFY just
--       because they use unboxed sums. Unboxed objects are supposed to be
--       efficient, and none of the other unboxed literals make things CAFFY.

aBSENT_SUM_FIELD_ERROR_ID :: Var
aBSENT_SUM_FIELD_ERROR_ID
  = Name -> Type -> IdInfo -> Var
mkVanillaGlobalWithInfo Name
absentSumFieldErrorName
      ([Var] -> Type -> Type
mkSpecForAllTys [Var
alphaTyVar] (Var -> Type
mkTyVarTy Var
alphaTyVar)) -- forall a . a
      (IdInfo
vanillaIdInfo IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig [] DmdResult
exnRes
                     IdInfo -> Int -> IdInfo
`setArityInfo` 0
                     IdInfo -> CafInfo -> IdInfo
`setCafInfo` CafInfo
NoCafRefs) -- #15038

mkRuntimeErrorId :: 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 :: Name -> Var
mkRuntimeErrorId name :: Name
name
 = Name -> Type -> IdInfo -> Var
mkVanillaGlobalWithInfo Name
name Type
runtimeErrorTy IdInfo
bottoming_info
 where
    bottoming_info :: IdInfo
bottoming_info = IdInfo
vanillaIdInfo IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo`    StrictSig
strict_sig
                                   IdInfo -> Int -> IdInfo
`setArityInfo`         1
                        -- Make arity and strictness agree

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

    strict_sig :: StrictSig
strict_sig = [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig [Demand
evalDmd] DmdResult
exnRes
              -- exnRes: these throw an exception, not just diverge

runtimeErrorTy :: Type
-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
--   See Note [Error and friends have an "open-tyvar" forall]
runtimeErrorTy :: Type
runtimeErrorTy = [Var] -> Type -> Type
mkSpecForAllTys [Var
runtimeRep1TyVar, Var
openAlphaTyVar]
                                 (Type -> Type -> Type
mkFunTy Type
addrPrimTy Type
openAlphaTy)

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


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

Note [aBSENT_ERROR_ID]
~~~~~~~~~~~~~~~~~~~~~~
We use aBSENT_ERROR_ID to build dummy values in workers.  E.g.

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

The demand analyser figures ot 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 goes away.

------ Tricky wrinkle -------
Trac #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 INLINEABLE functions] in 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 contructor, 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.
-}

aBSENT_ERROR_ID :: Var
aBSENT_ERROR_ID
 = Name -> Type -> IdInfo -> Var
mkVanillaGlobalWithInfo Name
absentErrorName Type
absent_ty IdInfo
arity_info
 where
   absent_ty :: Type
absent_ty = [Var] -> Type -> Type
mkSpecForAllTys [Var
alphaTyVar] (Type -> Type -> Type
mkFunTy Type
addrPrimTy Type
alphaTy)
   -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
   -- lifted-type things; see Note [Absent errors] in WwLib
   arity_info :: IdInfo
arity_info = IdInfo
vanillaIdInfo IdInfo -> Int -> IdInfo
`setArityInfo` 1
   -- NB: no bottoming strictness info, unlike other error-ids.
   -- See Note [aBSENT_ERROR_ID]

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

mkAbsentErrorApp :: Type -> String -> CoreExpr
mkAbsentErrorApp res_ty :: Type
res_ty err_msg :: String
err_msg
  = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
aBSENT_ERROR_ID) [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty, CoreExpr
forall b. Expr b
err_string ]
  where
    err_string :: Expr b
err_string = Literal -> Expr b
forall b. Literal -> Expr b
Lit (String -> Literal
mkLitString String
err_msg)