{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Core.Make (
mkCoreLet, mkCoreLets,
mkCoreApp, mkCoreApps, mkCoreConApps,
mkCoreLams, mkWildCase, mkIfThenElse,
mkWildValBinder, mkWildEvBinder,
mkSingleAltCase,
sortQuantVars, castBottomExpr,
mkWordExpr,
mkIntExpr, mkIntExprInt, mkUncheckedIntExpr,
mkIntegerExpr, mkNaturalExpr,
mkFloatExpr, mkDoubleExpr,
mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,
FloatBind(..), wrapFloat, wrapFloats, floatBindings,
mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, mkCoreUbxSum,
mkCoreTupBoxity, unitExpr,
mkBigCoreVarTup, mkBigCoreVarTup1,
mkBigCoreVarTupTy, mkBigCoreTupTy,
mkBigCoreTup,
mkSmallTupleSelector, mkSmallTupleCase,
mkTupleSelector, mkTupleSelector1, mkTupleCase,
mkNilExpr, mkConsExpr, mkListExpr,
mkFoldrExpr, mkBuildExpr,
mkNonEmptyListExpr,
mkNothingExpr, mkJustExpr,
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 GHC.Prelude
import GHC.Platform
import GHC.Types.Id
import GHC.Types.Var ( EvVar, setTyVarUnique )
import GHC.Types.TyThing
import GHC.Types.Id.Info
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.Name hiding ( varName )
import GHC.Types.Literal
import GHC.Types.Unique.Supply
import GHC.Types.Basic
import GHC.Core
import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec )
import GHC.Core.Type
import GHC.Core.Coercion ( isCoVar )
import GHC.Core.DataCon ( DataCon, dataConWorkId )
import GHC.Core.Multiplicity
import GHC.Hs.Utils ( mkChunkified, chunkify )
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.Data.FastString
import Data.List ( partition )
import Data.Char ( ord )
infixl 4 `mkCoreApp`, `mkCoreApps`
sortQuantVars :: [Var] -> [Var]
sortQuantVars :: [Id] -> [Id]
sortQuantVars [Id]
vs = [Id]
sorted_tcvs forall a. [a] -> [a] -> [a]
++ [Id]
ids
where
([Id]
tcvs, [Id]
ids) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Id -> Bool
isTyVar 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
mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (NonRec Id
bndr CoreExpr
rhs) CoreExpr
body
= Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
bndr CoreExpr
rhs CoreExpr
body
mkCoreLet CoreBind
bind CoreExpr
body
= forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind CoreExpr
body
mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr
mkCoreLams :: [Id] -> CoreExpr -> CoreExpr
mkCoreLams = forall b. [b] -> Expr b -> Expr b
mkLams
mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
binds CoreExpr
body = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreBind -> CoreExpr -> CoreExpr
mkCoreLet CoreExpr
body [CoreBind]
binds
mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
con [CoreExpr]
args = CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
con)) [CoreExpr]
args
mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps CoreExpr
fun [CoreExpr]
args
= forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
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 = forall a. Outputable a => a -> SDoc
ppr Type
fun_ty SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr CoreExpr
fun SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args
fun_ty :: Type
fun_ty = CoreExpr -> Type
exprType CoreExpr
fun
mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp SDoc
s CoreExpr
fun CoreExpr
arg
= forall a b. (a, b) -> a
fst 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
mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
mkCoreAppTyped SDoc
_ (CoreExpr
fun, Type
fun_ty) (Type Type
ty)
= (forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun (forall b. Type -> Expr b
Type Type
ty), HasDebugCallStack => Type -> Type -> Type
piResultTy Type
fun_ty Type
ty)
mkCoreAppTyped SDoc
_ (CoreExpr
fun, Type
fun_ty) (Coercion Coercion
co)
= (forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun (forall b. Coercion -> Expr b
Coercion Coercion
co), Type -> Type
funResultTy Type
fun_ty)
mkCoreAppTyped SDoc
d (CoreExpr
fun, Type
fun_ty) CoreExpr
arg
= ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
(CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr
mkValApp CoreExpr
fun CoreExpr
arg (forall a. Type -> a -> Scaled a
Scaled Type
mult Type
arg_ty) Type
res_ty, Type
res_ty)
where
(Type
mult, Type
arg_ty, Type
res_ty) = Type -> (Type, Type, Type)
splitFunTy Type
fun_ty
mkValApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr
mkValApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr
mkValApp CoreExpr
fun CoreExpr
arg (Scaled Type
w Type
arg_ty) Type
res_ty
| Bool -> Bool
not (Type -> CoreExpr -> Bool
needsCaseBinding Type
arg_ty CoreExpr
arg)
= forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun CoreExpr
arg
| Bool
otherwise
= CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr
mkStrictApp CoreExpr
fun CoreExpr
arg (forall a. Type -> a -> Scaled a
Scaled Type
w Type
arg_ty) Type
res_ty
mkWildEvBinder :: PredType -> EvVar
mkWildEvBinder :: Type -> Id
mkWildEvBinder Type
pred = Type -> Type -> Id
mkWildValBinder Type
Many Type
pred
mkWildValBinder :: Mult -> Type -> Id
mkWildValBinder :: Type -> Type -> Id
mkWildValBinder Type
w Type
ty = Name -> Type -> Type -> Id
mkLocalIdOrCoVar Name
wildCardName Type
w Type
ty
mkWildCase :: CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase :: CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
scrut (Scaled Type
w Type
scrut_ty) Type
res_ty [CoreAlt]
alts
= forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut (Type -> Type -> Id
mkWildValBinder Type
w Type
scrut_ty) Type
res_ty [CoreAlt]
alts
mkStrictApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr
mkStrictApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr
mkStrictApp CoreExpr
fun CoreExpr
arg (Scaled Type
w Type
arg_ty) Type
res_ty
= forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Id
arg_id Type
res_ty [forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] (forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun (forall b. Id -> Expr b
Var Id
arg_id))]
where
arg_id :: Id
arg_id = Type -> Type -> Id
mkWildValBinder Type
w Type
arg_ty
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse CoreExpr
guard CoreExpr
then_expr CoreExpr
else_expr
= CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
guard (forall a. a -> Scaled a
linear Type
boolTy) (CoreExpr -> Type
exprType CoreExpr
then_expr)
[ forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] CoreExpr
else_expr,
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon) [] CoreExpr
then_expr ]
castBottomExpr :: CoreExpr -> Type -> CoreExpr
castBottomExpr :: CoreExpr -> Type -> CoreExpr
castBottomExpr CoreExpr
e Type
res_ty
| Type
e_ty Type -> Type -> Bool
`eqType` Type
res_ty = CoreExpr
e
| Bool
otherwise = forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
e (Type -> Type -> Id
mkWildValBinder Type
One Type
e_ty) Type
res_ty []
where
e_ty :: Type
e_ty = CoreExpr -> Type
exprType CoreExpr
e
mkIntExpr :: Platform -> Integer -> CoreExpr
mkIntExpr :: Platform -> Integer -> CoreExpr
mkIntExpr Platform
platform Integer
i = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
intDataCon [forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform Integer
i]
mkUncheckedIntExpr :: Integer -> CoreExpr
mkUncheckedIntExpr :: Integer -> CoreExpr
mkUncheckedIntExpr Integer
i = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
intDataCon [forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitIntUnchecked Integer
i)]
mkIntExprInt :: Platform -> Int -> CoreExpr
mkIntExprInt :: Platform -> Int -> CoreExpr
mkIntExprInt Platform
platform Int
i = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
intDataCon [forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)]
mkWordExpr :: Platform -> Integer -> CoreExpr
mkWordExpr :: Platform -> Integer -> CoreExpr
mkWordExpr Platform
platform Integer
w = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
wordDataCon [forall b. Platform -> Integer -> Expr b
mkWordLit Platform
platform Integer
w]
mkIntegerExpr :: Integer -> CoreExpr
mkIntegerExpr :: Integer -> CoreExpr
mkIntegerExpr Integer
i = forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitInteger Integer
i)
mkNaturalExpr :: Integer -> CoreExpr
mkNaturalExpr :: Integer -> CoreExpr
mkNaturalExpr Integer
i = forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitNatural Integer
i)
mkFloatExpr :: Float -> CoreExpr
mkFloatExpr :: Float -> CoreExpr
mkFloatExpr Float
f = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
floatDataCon [forall b. Float -> Expr b
mkFloatLitFloat Float
f]
mkDoubleExpr :: Double -> CoreExpr
mkDoubleExpr :: Double -> CoreExpr
mkDoubleExpr Double
d = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
doubleDataCon [forall b. Double -> Expr b
mkDoubleLitDouble Double
d]
mkCharExpr :: Char -> CoreExpr
mkCharExpr :: Char -> CoreExpr
mkCharExpr Char
c = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
charDataCon [forall b. Char -> Expr b
mkCharLit Char
c]
mkStringExpr :: MonadThings m => String -> m CoreExpr
mkStringExprFS :: MonadThings m => FastString -> m CoreExpr
mkStringExpr :: forall (m :: * -> *). MonadThings m => String -> m CoreExpr
mkStringExpr String
str = forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS (String -> FastString
mkFastString String
str)
mkStringExprFS :: forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS = forall (m :: * -> *).
Monad m =>
(Name -> m Id) -> FastString -> m CoreExpr
mkStringExprFSWith forall (m :: * -> *). MonadThings m => Name -> m Id
lookupId
mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr
mkStringExprFSWith :: forall (m :: * -> *).
Monad m =>
(Name -> m Id) -> FastString -> m CoreExpr
mkStringExprFSWith Name -> m Id
lookupM FastString
str
| FastString -> Bool
nullFS FastString
str
= forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> CoreExpr
mkNilExpr Type
charTy)
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
safeChar String
chars
= do Id
unpack_id <- Name -> m Id
lookupM Name
unpackCStringName
forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Expr b -> Expr b -> Expr b
App (forall b. Id -> Expr b
Var Id
unpack_id) CoreExpr
lit)
| Bool
otherwise
= do Id
unpack_utf8_id <- Name -> m Id
lookupM Name
unpackCStringUtf8Name
forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Expr b -> Expr b -> Expr b
App (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 forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Char -> Int
ord Char
c forall a. Ord a => a -> a -> Bool
<= Int
0x7F
lit :: CoreExpr
lit = forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString (FastString -> ByteString
bytesFS FastString
str))
mkCoreVarTupTy :: [Id] -> Type
mkCoreVarTupTy :: [Id] -> Type
mkCoreVarTupTy [Id]
ids = [Type] -> Type
mkBoxedTupleTy (forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
ids)
mkCoreTup :: [CoreExpr] -> CoreExpr
mkCoreTup :: [CoreExpr] -> CoreExpr
mkCoreTup [CoreExpr
c] = CoreExpr
c
mkCoreTup [CoreExpr]
cs = [CoreExpr] -> CoreExpr
mkCoreTup1 [CoreExpr]
cs
mkCoreTup1 :: [CoreExpr] -> CoreExpr
mkCoreTup1 :: [CoreExpr] -> CoreExpr
mkCoreTup1 [CoreExpr]
cs = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed (forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
cs))
(forall a b. (a -> b) -> [a] -> [b]
map (forall b. Type -> Expr b
Type forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Type
exprType) [CoreExpr]
cs forall a. [a] -> [a] -> [a]
++ [CoreExpr]
cs)
mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup [Type]
tys [CoreExpr]
exps
= ASSERT( tys `equalLength` exps)
DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys))
(forall a b. (a -> b) -> [a] -> [b]
map (forall b. Type -> Expr b
Type forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Type
getRuntimeRep) [Type]
tys forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall b. Type -> Expr b
Type [Type]
tys forall a. [a] -> [a] -> [a]
++ [CoreExpr]
exps)
mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
mkCoreTupBoxity Boxity
Boxed [CoreExpr]
exps = [CoreExpr] -> CoreExpr
mkCoreTup1 [CoreExpr]
exps
mkCoreTupBoxity Boxity
Unboxed [CoreExpr]
exps = [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup (forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> Type
exprType [CoreExpr]
exps) [CoreExpr]
exps
mkCoreUbxSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUbxSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUbxSum Int
arity Int
alt [Type]
tys CoreExpr
exp
= ASSERT( length tys == arity )
ASSERT( alt <= arity )
DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Int -> Int -> DataCon
sumDataCon Int
alt Int
arity)
(forall a b. (a -> b) -> [a] -> [b]
map (forall b. Type -> Expr b
Type forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Type
getRuntimeRep) [Type]
tys
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall b. Type -> Expr b
Type [Type]
tys
forall a. [a] -> [a] -> [a]
++ [CoreExpr
exp])
mkBigCoreVarTup :: [Id] -> CoreExpr
mkBigCoreVarTup :: [Id] -> CoreExpr
mkBigCoreVarTup [Id]
ids = [CoreExpr] -> CoreExpr
mkBigCoreTup (forall a b. (a -> b) -> [a] -> [b]
map forall b. Id -> Expr b
Var [Id]
ids)
mkBigCoreVarTup1 :: [Id] -> CoreExpr
mkBigCoreVarTup1 :: [Id] -> CoreExpr
mkBigCoreVarTup1 [Id
id] = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed Int
1)
[forall b. Type -> Expr b
Type (Id -> Type
idType Id
id), forall b. Id -> Expr b
Var Id
id]
mkBigCoreVarTup1 [Id]
ids = [CoreExpr] -> CoreExpr
mkBigCoreTup (forall a b. (a -> b) -> [a] -> [b]
map forall b. Id -> Expr b
Var [Id]
ids)
mkBigCoreVarTupTy :: [Id] -> Type
mkBigCoreVarTupTy :: [Id] -> Type
mkBigCoreVarTupTy [Id]
ids = [Type] -> Type
mkBigCoreTupTy (forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
ids)
mkBigCoreTup :: [CoreExpr] -> CoreExpr
mkBigCoreTup :: [CoreExpr] -> CoreExpr
mkBigCoreTup = forall a. ([a] -> a) -> [a] -> a
mkChunkified [CoreExpr] -> CoreExpr
mkCoreTup
mkBigCoreTupTy :: [Type] -> Type
mkBigCoreTupTy :: [Type] -> Type
mkBigCoreTupTy = forall a. ([a] -> a) -> [a] -> a
mkChunkified [Type] -> Type
mkBoxedTupleTy
unitExpr :: CoreExpr
unitExpr :: CoreExpr
unitExpr = forall b. Id -> Expr b
Var Id
unitDataConId
mkTupleSelector, mkTupleSelector1
:: [Id]
-> Id
-> Id
-> CoreExpr
-> CoreExpr
mkTupleSelector :: [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkTupleSelector [Id]
vars Id
the_var Id
scrut_var CoreExpr
scrut
= [[Id]] -> Id -> CoreExpr
mk_tup_sel (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 forall a b. (a -> b) -> a -> b
$
[[Id]] -> Id -> CoreExpr
mk_tup_sel (forall a. [a] -> [[a]]
chunkify [Id]
tpl_vs) Id
tpl_v
where
tpl_tys :: [Type]
tpl_tys = [[Type] -> Type
mkBoxedTupleTy (forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
gp) | [Id]
gp <- [[Id]]
vars_s]
tpl_vs :: [Id]
tpl_vs = [Type] -> [Id]
mkTemplateLocals [Type]
tpl_tys
[(Id
tpl_v, [Id]
group)] = [(Id
tpl,[Id]
gp) | (Id
tpl,[Id]
gp) <- forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"mkTupleSelector" [Id]
tpl_vs [[Id]]
vars_s,
Id
the_var forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
gp ]
mkTupleSelector1 :: [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkTupleSelector1 [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
mkTupleSelector [Id]
vars Id
the_var Id
scrut_var CoreExpr
scrut
mkSmallTupleSelector, mkSmallTupleSelector1
:: [Id]
-> Id
-> Id
-> CoreExpr
-> CoreExpr
mkSmallTupleSelector :: [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkSmallTupleSelector [Id
var] Id
should_be_the_same_var Id
_ CoreExpr
scrut
= ASSERT(var == should_be_the_same_var)
CoreExpr
scrut
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 :: [Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkSmallTupleSelector1 [Id]
vars Id
the_var Id
scrut_var CoreExpr
scrut
= ASSERT( notNull vars )
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Id
scrut_var (Id -> Type
idType Id
the_var)
[forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
vars))) [Id]
vars (forall b. Id -> Expr b
Var Id
the_var)]
mkTupleCase :: UniqSupply
-> [Id]
-> CoreExpr
-> Id
-> CoreExpr
-> CoreExpr
mkTupleCase :: UniqSupply -> [Id] -> CoreExpr -> Id -> CoreExpr -> CoreExpr
mkTupleCase UniqSupply
uniqs [Id]
vars CoreExpr
body Id
scrut_var CoreExpr
scrut
= UniqSupply -> [[Id]] -> CoreExpr -> CoreExpr
mk_tuple_case UniqSupply
uniqs (forall a. [a] -> [[a]]
chunkify [Id]
vars) CoreExpr
body
where
mk_tuple_case :: UniqSupply -> [[Id]] -> CoreExpr -> CoreExpr
mk_tuple_case UniqSupply
_ [[Id]
vars] CoreExpr
body
= [Id] -> CoreExpr -> Id -> CoreExpr -> CoreExpr
mkSmallTupleCase [Id]
vars CoreExpr
body Id
scrut_var CoreExpr
scrut
mk_tuple_case UniqSupply
us [[Id]]
vars_s CoreExpr
body
= let (UniqSupply
us', [Id]
vars', CoreExpr
body') = 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
in UniqSupply -> [[Id]] -> CoreExpr -> CoreExpr
mk_tuple_case UniqSupply
us' (forall a. [a] -> [[a]]
chunkify [Id]
vars') CoreExpr
body'
one_tuple_case :: [Id]
-> (UniqSupply, [Id], CoreExpr) -> (UniqSupply, [Id], CoreExpr)
one_tuple_case [Id]
chunk_vars (UniqSupply
us, [Id]
vs, CoreExpr
body)
= let (Unique
uniq, UniqSupply
us') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us
scrut_var :: Id
scrut_var = FastString -> Unique -> Type -> Type -> Id
mkSysLocal (String -> FastString
fsLit String
"ds") Unique
uniq Type
Many
([Type] -> Type
mkBoxedTupleTy (forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
chunk_vars))
body' :: CoreExpr
body' = [Id] -> CoreExpr -> Id -> CoreExpr -> CoreExpr
mkSmallTupleCase [Id]
chunk_vars CoreExpr
body Id
scrut_var (forall b. Id -> Expr b
Var Id
scrut_var)
in (UniqSupply
us', Id
scrut_varforall a. a -> [a] -> [a]
:[Id]
vs, CoreExpr
body')
mkSmallTupleCase
:: [Id]
-> CoreExpr
-> Id
-> CoreExpr
-> CoreExpr
mkSmallTupleCase :: [Id] -> CoreExpr -> Id -> CoreExpr -> CoreExpr
mkSmallTupleCase [Id
var] CoreExpr
body Id
_scrut_var CoreExpr
scrut
= Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
var CoreExpr
scrut CoreExpr
body
mkSmallTupleCase [Id]
vars CoreExpr
body Id
scrut_var CoreExpr
scrut
= forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Id
scrut_var (CoreExpr -> Type
exprType CoreExpr
body)
[forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
vars))) [Id]
vars CoreExpr
body]
data FloatBind
= FloatLet CoreBind
| FloatCase CoreExpr Id AltCon [Var]
instance Outputable FloatBind where
ppr :: FloatBind -> SDoc
ppr (FloatLet CoreBind
b) = String -> SDoc
text String
"LET" SDoc -> SDoc -> 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
text String
"CASE" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CoreExpr
e SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"of") SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Id
b)
Int
2 (forall a. Outputable a => a -> SDoc
ppr AltCon
c SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Id]
bs)
wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
wrapFloat (FloatLet CoreBind
defns) CoreExpr
body = 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
wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr
wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr
wrapFloats [FloatBind]
floats CoreExpr
expr = 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) = forall a b. (a -> b) -> [a] -> [b]
map 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
bforall a. a -> [a] -> [a]
:[Id]
bs
mkNilExpr :: Type -> CoreExpr
mkNilExpr :: Type -> CoreExpr
mkNilExpr Type
ty = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
nilDataCon [forall b. Type -> Expr b
Type Type
ty]
mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
mkConsExpr Type
ty CoreExpr
hd CoreExpr
tl = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
consDataCon [forall b. Type -> Expr b
Type Type
ty, CoreExpr
hd, CoreExpr
tl]
mkListExpr :: Type -> [CoreExpr] -> CoreExpr
mkListExpr :: Type -> [CoreExpr] -> CoreExpr
mkListExpr Type
ty [CoreExpr]
xs = 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
mkNonEmptyListExpr :: Type -> CoreExpr -> [CoreExpr] -> CoreExpr
mkNonEmptyListExpr :: Type -> CoreExpr -> [CoreExpr] -> CoreExpr
mkNonEmptyListExpr Type
ty CoreExpr
x [CoreExpr]
xs = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
nonEmptyDataCon [forall b. Type -> Expr b
Type Type
ty, CoreExpr
x, Type -> [CoreExpr] -> CoreExpr
mkListExpr Type
ty [CoreExpr]
xs]
mkFoldrExpr :: MonadThings m
=> Type
-> Type
-> CoreExpr
-> CoreExpr
-> CoreExpr
-> m CoreExpr
mkFoldrExpr :: forall (m :: * -> *).
MonadThings m =>
Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr -> m CoreExpr
mkFoldrExpr Type
elt_ty Type
result_ty CoreExpr
c CoreExpr
n CoreExpr
list = do
Id
foldr_id <- forall (m :: * -> *). MonadThings m => Name -> m Id
lookupId Name
foldrName
forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Id -> Expr b
Var Id
foldr_id forall b. Expr b -> Expr b -> Expr b
`App` forall b. Type -> Expr b
Type Type
elt_ty
forall b. Expr b -> Expr b -> Expr b
`App` forall b. Type -> Expr b
Type Type
result_ty
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
c
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
n
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
list)
mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m)
=> Type
-> ((Id, Type) -> (Id, Type) -> m CoreExpr)
-> m CoreExpr
mkBuildExpr :: forall (m :: * -> *).
(MonadFail m, MonadThings m, MonadUnique m) =>
Type -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -> m CoreExpr
mkBuildExpr Type
elt_ty (Id, Type) -> (Id, Type) -> m CoreExpr
mk_build_inside = do
Id
n_tyvar <- forall {m :: * -> *}. MonadUnique m => Id -> m Id
newTyVar Id
alphaTyVar
let n_ty :: Type
n_ty = Id -> Type
mkTyVarTy Id
n_tyvar
c_ty :: Type
c_ty = [Type] -> Type -> Type
mkVisFunTysMany [Type
elt_ty, Type
n_ty] Type
n_ty
[Id
c, Id
n] <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m Id
mkSysLocalM (String -> FastString
fsLit String
"c") Type
Many Type
c_ty, forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m Id
mkSysLocalM (String -> FastString
fsLit String
"n") Type
Many Type
n_ty]
CoreExpr
build_inside <- (Id, Type) -> (Id, Type) -> m CoreExpr
mk_build_inside (Id
c, Type
c_ty) (Id
n, Type
n_ty)
Id
build_id <- forall (m :: * -> *). MonadThings m => Name -> m Id
lookupId Name
buildName
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. Id -> Expr b
Var Id
build_id forall b. Expr b -> Expr b -> Expr b
`App` forall b. Type -> Expr b
Type Type
elt_ty forall b. Expr b -> Expr b -> Expr b
`App` 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 <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Unique -> Id
setTyVarUnique Id
tyvar_tmpl Unique
uniq)
mkNothingExpr :: Type -> CoreExpr
mkNothingExpr :: Type -> CoreExpr
mkNothingExpr Type
ty = forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
nothingDataCon [forall b. Type -> Expr b
Type Type
ty]
mkJustExpr :: Type -> CoreExpr -> CoreExpr
mkJustExpr :: Type -> CoreExpr -> CoreExpr
mkJustExpr Type
ty CoreExpr
val = forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
justDataCon [forall b. Type -> Expr b
Type Type
ty, CoreExpr
val]
mkRuntimeErrorApp
:: Id
-> Type
-> String
-> CoreExpr
mkRuntimeErrorApp :: Id -> Type -> String -> CoreExpr
mkRuntimeErrorApp Id
err_id Type
res_ty String
err_msg
= forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
err_id) [ forall b. Type -> Expr b
Type (HasDebugCallStack => Type -> Type
getRuntimeRep Type
res_ty)
, forall b. Type -> Expr b
Type Type
res_ty, CoreExpr
err_string ]
where
err_string :: CoreExpr
err_string = forall b. Literal -> Expr b
Lit (String -> Literal
mkLitString String
err_msg)
mkImpossibleExpr :: Type -> CoreExpr
mkImpossibleExpr :: Type -> CoreExpr
mkImpossibleExpr Type
res_ty
= Id -> Type -> String -> CoreExpr
mkRuntimeErrorApp Id
rUNTIME_ERROR_ID Type
res_ty String
"Impossible case alternative"
errorIds :: [Id]
errorIds :: [Id]
errorIds
= [ Id
rUNTIME_ERROR_ID,
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
aBSENT_ERROR_ID,
Id
aBSENT_SUM_FIELD_ERROR_ID,
Id
tYPE_ERROR_ID,
Id
rAISE_OVERFLOW_ID,
Id
rAISE_UNDERFLOW_ID,
Id
rAISE_DIVZERO_ID
]
recSelErrorName, runtimeErrorName, absentErrorName :: Name
recConErrorName, patErrorName :: Name
nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
typeErrorName :: Name
absentSumFieldErrorName :: Name
raiseOverflowName, raiseUnderflowName, raiseDivZeroName :: Name
recSelErrorName :: Name
recSelErrorName = String -> Unique -> Id -> Name
err_nm String
"recSelError" Unique
recSelErrorIdKey Id
rEC_SEL_ERROR_ID
runtimeErrorName :: Name
runtimeErrorName = String -> Unique -> Id -> Name
err_nm String
"runtimeError" Unique
runtimeErrorIdKey Id
rUNTIME_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, 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
rAISE_OVERFLOW_ID, rAISE_UNDERFLOW_ID, rAISE_DIVZERO_ID :: Id
rEC_SEL_ERROR_ID :: Id
rEC_SEL_ERROR_ID = Name -> Id
mkRuntimeErrorId Name
recSelErrorName
rUNTIME_ERROR_ID :: Id
rUNTIME_ERROR_ID = Name -> Id
mkRuntimeErrorId Name
runtimeErrorName
rEC_CON_ERROR_ID :: Id
rEC_CON_ERROR_ID = Name -> Id
mkRuntimeErrorId Name
recConErrorName
pAT_ERROR_ID :: Id
pAT_ERROR_ID = Name -> Id
mkRuntimeErrorId Name
patErrorName
nO_METHOD_BINDING_ERROR_ID :: Id
nO_METHOD_BINDING_ERROR_ID = Name -> Id
mkRuntimeErrorId Name
noMethodBindingErrorName
nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
nON_EXHAUSTIVE_GUARDS_ERROR_ID = Name -> Id
mkRuntimeErrorId Name
nonExhaustiveGuardsErrorName
tYPE_ERROR_ID :: Id
tYPE_ERROR_ID = Name -> Id
mkRuntimeErrorId Name
typeErrorName
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
absentErrorName :: Name
absentErrorName
= Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName
Module
gHC_PRIM_PANIC
(String -> FastString
fsLit String
"absentError")
Unique
absentErrorIdKey
Id
aBSENT_ERROR_ID
raiseOverflowName :: Name
raiseOverflowName
= Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName
Module
gHC_PRIM_EXCEPTION
(String -> FastString
fsLit String
"raiseOverflow")
Unique
raiseOverflowIdKey
Id
rAISE_OVERFLOW_ID
raiseUnderflowName :: Name
raiseUnderflowName
= Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName
Module
gHC_PRIM_EXCEPTION
(String -> FastString
fsLit String
"raiseUnderflow")
Unique
raiseUnderflowIdKey
Id
rAISE_UNDERFLOW_ID
raiseDivZeroName :: Name
raiseDivZeroName
= Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName
Module
gHC_PRIM_EXCEPTION
(String -> FastString
fsLit String
"raiseDivZero")
Unique
raiseDivZeroIdKey
Id
rAISE_DIVZERO_ID
aBSENT_SUM_FIELD_ERROR_ID :: Id
aBSENT_SUM_FIELD_ERROR_ID = Name -> Id
mkExceptionId Name
absentSumFieldErrorName
rAISE_OVERFLOW_ID :: Id
rAISE_OVERFLOW_ID = Name -> Id
mkExceptionId Name
raiseOverflowName
rAISE_UNDERFLOW_ID :: Id
rAISE_UNDERFLOW_ID = Name -> Id
mkExceptionId Name
raiseUnderflowName
rAISE_DIVZERO_ID :: Id
rAISE_DIVZERO_ID = Name -> Id
mkExceptionId Name
raiseDivZeroName
mkExceptionId :: Name -> Id
mkExceptionId :: Name -> Id
mkExceptionId Name
name
= Name -> Type -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
name
([Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (Id -> Type
mkTyVarTy Id
alphaTyVar))
(IdInfo
vanillaIdInfo IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` [Demand] -> Divergence -> StrictSig
mkClosedStrictSig [] Divergence
botDiv
IdInfo -> CprSig -> IdInfo
`setCprInfo` Int -> Cpr -> CprSig
mkCprSig Int
0 Cpr
botCpr
IdInfo -> Int -> IdInfo
`setArityInfo` Int
0
IdInfo -> CafInfo -> IdInfo
`setCafInfo` CafInfo
NoCafRefs)
mkRuntimeErrorId :: Name -> Id
mkRuntimeErrorId :: Name -> Id
mkRuntimeErrorId Name
name
= Name -> Type -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
name Type
runtimeErrorTy IdInfo
bottoming_info
where
bottoming_info :: IdInfo
bottoming_info = IdInfo
vanillaIdInfo IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
strict_sig
IdInfo -> CprSig -> IdInfo
`setCprInfo` Int -> Cpr -> CprSig
mkCprSig Int
1 Cpr
botCpr
IdInfo -> Int -> IdInfo
`setArityInfo` Int
1
strict_sig :: StrictSig
strict_sig = [Demand] -> Divergence -> StrictSig
mkClosedStrictSig [Demand
evalDmd] Divergence
botDiv
runtimeErrorTy :: Type
runtimeErrorTy :: Type
runtimeErrorTy = [Id] -> Type -> Type
mkSpecForAllTys [Id
runtimeRep1TyVar, Id
openAlphaTyVar]
(Type -> Type -> Type
mkVisFunTyMany Type
addrPrimTy Type
openAlphaTy)
aBSENT_ERROR_ID :: Id
aBSENT_ERROR_ID
= Name -> Type -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
absentErrorName Type
absent_ty IdInfo
arity_info
where
absent_ty :: Type
absent_ty = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (Type -> Type -> Type
mkVisFunTyMany Type
addrPrimTy Type
alphaTy)
arity_info :: IdInfo
arity_info = IdInfo
vanillaIdInfo IdInfo -> Int -> IdInfo
`setArityInfo` Int
1
mkAbsentErrorApp :: Type
-> String
-> CoreExpr
mkAbsentErrorApp :: Type -> String -> CoreExpr
mkAbsentErrorApp Type
res_ty String
err_msg
= forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
aBSENT_ERROR_ID) [ forall b. Type -> Expr b
Type Type
res_ty, CoreExpr
err_string ]
where
err_string :: CoreExpr
err_string = forall b. Literal -> Expr b
Lit (String -> Literal
mkLitString String
err_msg)