{-# LANGUAGE CPP #-}
module MkCore (
mkCoreLet, mkCoreLets,
mkCoreApp, mkCoreApps, mkCoreConApps,
mkCoreLams, mkWildCase, mkIfThenElse,
mkWildValBinder, mkWildEvBinder,
mkSingleAltCase,
sortQuantVars, castBottomExpr,
mkWordExpr, mkWordExprWord,
mkIntExpr, mkIntExprInt,
mkIntegerExpr, mkNaturalExpr,
mkFloatExpr, mkDoubleExpr,
mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,
FloatBind(..), wrapFloat, wrapFloats, floatBindings,
mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup,
mkCoreTupBoxity, unitExpr,
mkBigCoreVarTup, mkBigCoreVarTup1,
mkBigCoreVarTupTy, mkBigCoreTupTy,
mkBigCoreTup,
mkSmallTupleSelector, mkSmallTupleCase,
mkTupleSelector, mkTupleSelector1, mkTupleCase,
mkNilExpr, mkConsExpr, mkListExpr,
mkFoldrExpr, mkBuildExpr,
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 GhcPrelude
import Id
import Var ( EvVar, setTyVarUnique )
import CoreSyn
import CoreUtils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec )
import Literal
import HscTypes
import TysWiredIn
import PrelNames
import GHC.Hs.Utils ( 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`
sortQuantVars :: [Var] -> [Var]
sortQuantVars :: [Var] -> [Var]
sortQuantVars [Var]
vs = [Var]
sorted_tcvs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
ids
where
([Var]
tcvs, [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
mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (NonRec Var
bndr CoreExpr
rhs) CoreExpr
body
= Var -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Var
bndr CoreExpr
rhs CoreExpr
body
mkCoreLet CoreBind
bind CoreExpr
body
= CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind CoreExpr
body
mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr
mkCoreLams :: [Var] -> CoreExpr -> CoreExpr
mkCoreLams = [Var] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams
mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
binds 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
mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
con [CoreExpr]
args = CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (Var -> CoreExpr
forall b. Var -> Expr b
Var (DataCon -> Var
dataConWorkId DataCon
con)) [CoreExpr]
args
mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps CoreExpr
fun [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
mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp SDoc
s CoreExpr
fun 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
mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)
mkCoreAppTyped SDoc
_ (CoreExpr
fun, Type
fun_ty) (Type 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 SDoc
_ (CoreExpr
fun, Type
fun_ty) (Coercion Coercion
co)
= (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun (Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
co), 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 -> Type -> Type -> CoreExpr
mkValApp CoreExpr
fun CoreExpr
arg Type
arg_ty Type
res_ty, Type
res_ty)
where
(Type
arg_ty, Type
res_ty) = Type -> (Type, Type)
splitFunTy Type
fun_ty
mkValApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
mkValApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
mkValApp CoreExpr
fun CoreExpr
arg Type
arg_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
| Bool
otherwise
= CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
mkStrictApp CoreExpr
fun CoreExpr
arg Type
arg_ty Type
res_ty
mkWildEvBinder :: PredType -> EvVar
mkWildEvBinder :: Type -> Var
mkWildEvBinder Type
pred = Type -> Var
mkWildValBinder Type
pred
mkWildValBinder :: Type -> Id
mkWildValBinder :: Type -> Var
mkWildValBinder Type
ty = Name -> Type -> Var
mkLocalIdOrCoVar Name
wildCardName Type
ty
mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
scrut Type
scrut_ty Type
res_ty [CoreAlt]
alts
= CoreExpr -> Var -> Type -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut (Type -> Var
mkWildValBinder Type
scrut_ty) Type
res_ty [CoreAlt]
alts
mkStrictApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
mkStrictApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
mkStrictApp CoreExpr
fun CoreExpr
arg Type
arg_ty Type
res_ty
= CoreExpr -> Var -> Type -> [CoreAlt] -> 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
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse CoreExpr
guard CoreExpr
then_expr CoreExpr
else_expr
= CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
guard Type
boolTy (CoreExpr -> Type
exprType CoreExpr
then_expr)
[ (DataCon -> AltCon
DataAlt DataCon
falseDataCon, [], CoreExpr
else_expr),
(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 = CoreExpr -> Var -> Type -> [CoreAlt] -> 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
mkIntExpr :: DynFlags -> Integer -> CoreExpr
mkIntExpr :: DynFlags -> Integer -> CoreExpr
mkIntExpr DynFlags
dflags Integer
i = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
intDataCon [DynFlags -> Integer -> CoreExpr
forall b. DynFlags -> Integer -> Expr b
mkIntLit DynFlags
dflags Integer
i]
mkIntExprInt :: DynFlags -> Int -> CoreExpr
mkIntExprInt :: DynFlags -> Int -> CoreExpr
mkIntExprInt DynFlags
dflags Int
i = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
intDataCon [DynFlags -> Int -> CoreExpr
forall b. DynFlags -> Int -> Expr b
mkIntLitInt DynFlags
dflags Int
i]
mkWordExpr :: DynFlags -> Integer -> CoreExpr
mkWordExpr :: DynFlags -> Integer -> CoreExpr
mkWordExpr DynFlags
dflags Integer
w = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
wordDataCon [DynFlags -> Integer -> CoreExpr
forall b. DynFlags -> Integer -> Expr b
mkWordLit DynFlags
dflags Integer
w]
mkWordExprWord :: DynFlags -> Word -> CoreExpr
mkWordExprWord :: DynFlags -> Word -> CoreExpr
mkWordExprWord DynFlags
dflags Word
w = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
wordDataCon [DynFlags -> Word -> CoreExpr
forall b. DynFlags -> Word -> Expr b
mkWordLitWord DynFlags
dflags Word
w]
mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr
mkIntegerExpr :: Integer -> m CoreExpr
mkIntegerExpr 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)))
mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr
mkNaturalExpr :: Integer -> m CoreExpr
mkNaturalExpr 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)))
mkFloatExpr :: Float -> CoreExpr
mkFloatExpr :: Float -> CoreExpr
mkFloatExpr Float
f = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
floatDataCon [Float -> CoreExpr
forall b. Float -> Expr b
mkFloatLitFloat Float
f]
mkDoubleExpr :: Double -> CoreExpr
mkDoubleExpr :: Double -> CoreExpr
mkDoubleExpr Double
d = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
doubleDataCon [Double -> CoreExpr
forall b. Double -> Expr b
mkDoubleLitDouble Double
d]
mkCharExpr :: Char -> CoreExpr
mkCharExpr :: Char -> CoreExpr
mkCharExpr Char
c = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
charDataCon [Char -> CoreExpr
forall b. Char -> Expr b
mkCharLit Char
c]
mkStringExpr :: MonadThings m => String -> m CoreExpr
mkStringExprFS :: MonadThings m => FastString -> m CoreExpr
mkStringExpr :: String -> m CoreExpr
mkStringExpr 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 Name -> m Var
lookupM 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 Char
c = Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x7F
lit :: Expr b
lit = Literal -> Expr b
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString (FastString -> ByteString
bytesFS FastString
str))
mkCoreVarTupTy :: [Id] -> Type
mkCoreVarTupTy :: [Var] -> Type
mkCoreVarTupTy [Var]
ids = [Type] -> Type
mkBoxedTupleTy ((Var -> Type) -> [Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
idType [Var]
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 ([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)
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 ([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)
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 ((CoreExpr -> Type) -> [CoreExpr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> Type
exprType [CoreExpr]
exps) [CoreExpr]
exps
mkBigCoreVarTup :: [Id] -> CoreExpr
mkBigCoreVarTup :: [Var] -> CoreExpr
mkBigCoreVarTup [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
mkBigCoreVarTup1 :: [Var] -> CoreExpr
mkBigCoreVarTup1 [Var
id] = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed Int
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 [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)
mkBigCoreVarTupTy :: [Id] -> Type
mkBigCoreVarTupTy :: [Var] -> Type
mkBigCoreVarTupTy [Var]
ids = [Type] -> Type
mkBigCoreTupTy ((Var -> Type) -> [Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
idType [Var]
ids)
mkBigCoreTup :: [CoreExpr] -> CoreExpr
mkBigCoreTup :: [CoreExpr] -> CoreExpr
mkBigCoreTup = ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a. ([a] -> a) -> [a] -> a
mkChunkified [CoreExpr] -> CoreExpr
mkCoreTup
mkBigCoreTupTy :: [Type] -> Type
mkBigCoreTupTy :: [Type] -> Type
mkBigCoreTupTy = ([Type] -> Type) -> [Type] -> Type
forall a. ([a] -> a) -> [a] -> a
mkChunkified [Type] -> Type
mkBoxedTupleTy
unitExpr :: CoreExpr
unitExpr :: CoreExpr
unitExpr = Var -> CoreExpr
forall b. Var -> Expr b
Var Var
unitDataConId
mkTupleSelector, mkTupleSelector1
:: [Id]
-> Id
-> Id
-> CoreExpr
-> CoreExpr
mkTupleSelector :: [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkTupleSelector [Var]
vars Var
the_var Var
scrut_var 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 [[Var]
vars] Var
the_var = [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkSmallTupleSelector [Var]
vars Var
the_var Var
scrut_var CoreExpr
scrut
mk_tup_sel [[Var]]
vars_s 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
[(Var
tpl_v, [Var]
group)] = [(Var
tpl,[Var]
gp) | (Var
tpl,[Var]
gp) <- String -> [Var] -> [[Var]] -> [(Var, [Var])]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"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 :: [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkTupleSelector1 [Var]
vars Var
the_var Var
scrut_var CoreExpr
scrut
| [Var
_] <- [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
mkSmallTupleSelector, mkSmallTupleSelector1
:: [Id]
-> Id
-> Id
-> CoreExpr
-> CoreExpr
mkSmallTupleSelector :: [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkSmallTupleSelector [Var
var] Var
should_be_the_same_var Var
_ CoreExpr
scrut
= ASSERT(var == should_be_the_same_var)
CoreExpr
scrut
mkSmallTupleSelector [Var]
vars Var
the_var Var
scrut_var CoreExpr
scrut
= [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkSmallTupleSelector1 [Var]
vars Var
the_var Var
scrut_var CoreExpr
scrut
mkSmallTupleSelector1 :: [Var] -> Var -> Var -> CoreExpr -> CoreExpr
mkSmallTupleSelector1 [Var]
vars Var
the_var Var
scrut_var CoreExpr
scrut
= ASSERT( notNull vars )
CoreExpr -> Var -> Type -> [CoreAlt] -> 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)]
mkTupleCase :: UniqSupply
-> [Id]
-> CoreExpr
-> Id
-> CoreExpr
-> CoreExpr
mkTupleCase :: UniqSupply -> [Var] -> CoreExpr -> Var -> CoreExpr -> CoreExpr
mkTupleCase UniqSupply
uniqs [Var]
vars CoreExpr
body Var
scrut_var CoreExpr
scrut
= UniqSupply -> [[Var]] -> CoreExpr -> CoreExpr
mk_tuple_case UniqSupply
uniqs ([Var] -> [[Var]]
forall a. [a] -> [[a]]
chunkify [Var]
vars) CoreExpr
body
where
mk_tuple_case :: UniqSupply -> [[Var]] -> CoreExpr -> CoreExpr
mk_tuple_case UniqSupply
_ [[Var]
vars] CoreExpr
body
= [Var] -> CoreExpr -> Var -> CoreExpr -> CoreExpr
mkSmallTupleCase [Var]
vars CoreExpr
body Var
scrut_var CoreExpr
scrut
mk_tuple_case UniqSupply
us [[Var]]
vars_s CoreExpr
body
= let (UniqSupply
us', [Var]
vars', 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 [Var]
chunk_vars (UniqSupply
us, [Var]
vs, CoreExpr
body)
= let (Unique
uniq, UniqSupply
us') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply UniqSupply
us
scrut_var :: Var
scrut_var = FastString -> Unique -> Type -> Var
mkSysLocal (String -> FastString
fsLit String
"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')
mkSmallTupleCase
:: [Id]
-> CoreExpr
-> Id
-> CoreExpr
-> CoreExpr
mkSmallTupleCase :: [Var] -> CoreExpr -> Var -> CoreExpr -> CoreExpr
mkSmallTupleCase [Var
var] CoreExpr
body Var
_scrut_var CoreExpr
scrut
= Var -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Var
var CoreExpr
scrut CoreExpr
body
mkSmallTupleCase [Var]
vars CoreExpr
body Var
scrut_var CoreExpr
scrut
= CoreExpr -> Var -> Type -> [CoreAlt] -> 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)]
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
<+> CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
b
ppr (FloatCase CoreExpr
e Var
b AltCon
c [Var]
bs) = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"CASE" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"of") SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
b)
Int
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 CoreBind
defns) CoreExpr
body = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
defns CoreExpr
body
wrapFloat (FloatCase CoreExpr
e Var
b AltCon
con [Var]
bs) CoreExpr
body = CoreExpr -> Var -> AltCon -> [Var] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
e Var
b AltCon
con [Var]
bs CoreExpr
body
wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr
wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr
wrapFloats [FloatBind]
floats CoreExpr
expr = (FloatBind -> CoreExpr -> CoreExpr)
-> CoreExpr -> [FloatBind] -> CoreExpr
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 -> [Var]
bindBindings (NonRec Var
b CoreExpr
_) = [Var
b]
bindBindings (Rec [(Var, CoreExpr)]
bnds) = ((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
bnds
floatBindings :: FloatBind -> [Var]
floatBindings :: FloatBind -> [Var]
floatBindings (FloatLet CoreBind
bnd) = CoreBind -> [Var]
bindBindings CoreBind
bnd
floatBindings (FloatCase CoreExpr
_ Var
b AltCon
_ [Var]
bs) = Var
bVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
bs
mkNilExpr :: Type -> CoreExpr
mkNilExpr :: Type -> CoreExpr
mkNilExpr Type
ty = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
nilDataCon [Type -> CoreExpr
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 [Type -> CoreExpr
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 = (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
mkFoldrExpr :: MonadThings m
=> Type
-> Type
-> CoreExpr
-> CoreExpr
-> CoreExpr
-> m CoreExpr
mkFoldrExpr :: Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr -> m CoreExpr
mkFoldrExpr Type
elt_ty Type
result_ty CoreExpr
c CoreExpr
n 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)
mkBuildExpr :: (MonadFail.MonadFail m, MonadThings m, MonadUnique m)
=> Type
-> ((Id, Type) -> (Id, Type) -> m CoreExpr)
-> m CoreExpr
mkBuildExpr :: Type -> ((Var, Type) -> (Var, Type) -> m CoreExpr) -> m CoreExpr
mkBuildExpr Type
elt_ty (Var, Type) -> (Var, Type) -> m CoreExpr
mk_build_inside = do
[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
mkVisFunTys [Type
elt_ty, Type
n_ty] Type
n_ty
[Var
c, 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 String
"c") Type
c_ty, FastString -> Type -> m Var
forall (m :: * -> *). MonadUnique m => FastString -> Type -> m Var
mkSysLocalM (String -> FastString
fsLit String
"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 [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)
mkNothingExpr :: Type -> CoreExpr
mkNothingExpr :: Type -> CoreExpr
mkNothingExpr 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]
mkJustExpr :: Type -> CoreExpr -> CoreExpr
mkJustExpr :: Type -> CoreExpr -> CoreExpr
mkJustExpr Type
ty 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]
mkRuntimeErrorApp
:: Id
-> Type
-> String
-> CoreExpr
mkRuntimeErrorApp :: Var -> Type -> String -> CoreExpr
mkRuntimeErrorApp Var
err_id Type
res_ty 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 Type
res_ty
= Var -> Type -> String -> CoreExpr
mkRuntimeErrorApp Var
rUNTIME_ERROR_ID Type
res_ty String
"Impossible case alternative"
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
]
recSelErrorName, runtimeErrorName, absentErrorName :: Name
recConErrorName, patErrorName :: Name
nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
typeErrorName :: Name
absentSumFieldErrorName :: Name
recSelErrorName :: Name
recSelErrorName = String -> Unique -> Var -> Name
err_nm String
"recSelError" Unique
recSelErrorIdKey Var
rEC_SEL_ERROR_ID
absentErrorName :: Name
absentErrorName = String -> Unique -> Var -> Name
err_nm String
"absentError" Unique
absentErrorIdKey Var
aBSENT_ERROR_ID
absentSumFieldErrorName :: Name
absentSumFieldErrorName = String -> Unique -> Var -> Name
err_nm String
"absentSumFieldError" Unique
absentSumFieldErrorIdKey
Var
aBSENT_SUM_FIELD_ERROR_ID
runtimeErrorName :: Name
runtimeErrorName = String -> Unique -> Var -> Name
err_nm String
"runtimeError" Unique
runtimeErrorIdKey Var
rUNTIME_ERROR_ID
recConErrorName :: Name
recConErrorName = String -> Unique -> Var -> Name
err_nm String
"recConError" Unique
recConErrorIdKey Var
rEC_CON_ERROR_ID
patErrorName :: Name
patErrorName = String -> Unique -> Var -> Name
err_nm String
"patError" Unique
patErrorIdKey Var
pAT_ERROR_ID
typeErrorName :: Name
typeErrorName = String -> Unique -> Var -> Name
err_nm String
"typeError" Unique
typeErrorIdKey Var
tYPE_ERROR_ID
noMethodBindingErrorName :: Name
noMethodBindingErrorName = String -> Unique -> Var -> Name
err_nm String
"noMethodBindingError"
Unique
noMethodBindingErrorIdKey Var
nO_METHOD_BINDING_ERROR_ID
nonExhaustiveGuardsErrorName :: Name
nonExhaustiveGuardsErrorName = String -> Unique -> Var -> Name
err_nm String
"nonExhaustiveGuardsError"
Unique
nonExhaustiveGuardsErrorIdKey Var
nON_EXHAUSTIVE_GUARDS_ERROR_ID
err_nm :: String -> Unique -> Id -> Name
err_nm :: String -> Unique -> Var -> Name
err_nm String
str Unique
uniq 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
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))
(IdInfo
vanillaIdInfo IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig [] DmdResult
botRes
IdInfo -> Int -> IdInfo
`setArityInfo` Int
0
IdInfo -> CafInfo -> IdInfo
`setCafInfo` CafInfo
NoCafRefs)
mkRuntimeErrorId :: Name -> Id
mkRuntimeErrorId :: Name -> Var
mkRuntimeErrorId 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` Int
1
strict_sig :: StrictSig
strict_sig = [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig [Demand
evalDmd] DmdResult
botRes
runtimeErrorTy :: Type
runtimeErrorTy :: Type
runtimeErrorTy = [Var] -> Type -> Type
mkSpecForAllTys [Var
runtimeRep1TyVar, Var
openAlphaTyVar]
(Type -> Type -> Type
mkVisFunTy Type
addrPrimTy Type
openAlphaTy)
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
mkVisFunTy 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
= 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)