{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Core.Make (
mkCoreLet, mkCoreLets,
mkCoreApp, mkCoreApps, mkCoreConApps,
mkCoreLams, mkWildCase, mkIfThenElse,
mkWildValBinder, mkWildEvBinder,
mkSingleAltCase,
sortQuantVars, castBottomExpr,
mkLitRubbish,
mkWordExpr,
mkIntExpr, mkIntExprInt, mkUncheckedIntExpr,
mkIntegerExpr, mkNaturalExpr,
mkFloatExpr, mkDoubleExpr,
mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,
MkStringIds (..), getMkStringIds,
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
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.Cpr
import GHC.Types.Demand
import GHC.Types.Name hiding ( varName )
import GHC.Types.Literal
import GHC.Types.Unique.Supply
import GHC.Core
import GHC.Core.Utils ( exprType, 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.Utils.Panic.Plain
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 = HasDebugCallStack => 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, HasDebugCallStack => 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), HasDebugCallStack => Type -> Type
funResultTy Type
fun_ty)
mkCoreAppTyped SDoc
d (CoreExpr
fun, Type
fun_ty) CoreExpr
arg
= forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Type -> Bool
isFunTy Type
fun_ty) (forall a. Outputable a => a -> SDoc
ppr CoreExpr
fun SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr CoreExpr
arg SDoc -> SDoc -> SDoc
$$ SDoc
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) (HasDebugCallStack => 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 = HasDebugCallStack => CoreExpr -> Type
exprType CoreExpr
e
mkLitRubbish :: Type -> Maybe CoreExpr
mkLitRubbish :: Type -> Maybe CoreExpr
mkLitRubbish Type
ty
| Bool -> Bool
not (Type -> Bool
noFreeVarsOfType Type
rep)
= forall a. Maybe a
Nothing
| Type -> Bool
isCoVarType Type
ty
= forall a. Maybe a
Nothing
| Bool
otherwise
= forall a. a -> Maybe a
Just (forall b. Literal -> Expr b
Lit (Type -> Literal
LitRubbish Type
rep) forall b. Expr b -> [Type] -> Expr b
`mkTyApps` [Type
ty])
where
rep :: Type
rep = HasDebugCallStack => Type -> Type
getRuntimeRep Type
ty
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 :: Platform -> Integer -> CoreExpr
mkIntegerExpr :: Platform -> Integer -> CoreExpr
mkIntegerExpr Platform
platform Integer
i
| Platform -> Integer -> Bool
platformInIntRange Platform
platform Integer
i = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
integerISDataCon [forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform Integer
i]
| Integer
i forall a. Ord a => a -> a -> Bool
< Integer
0 = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
integerINDataCon [forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitBigNat (forall a. Num a => a -> a
negate Integer
i))]
| Bool
otherwise = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
integerIPDataCon [forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitBigNat Integer
i)]
mkNaturalExpr :: Platform -> Integer -> CoreExpr
mkNaturalExpr :: Platform -> Integer -> CoreExpr
mkNaturalExpr Platform
platform Integer
w
| Platform -> Integer -> Bool
platformInWordRange Platform
platform Integer
w = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
naturalNSDataCon [forall b. Platform -> Integer -> Expr b
mkWordLit Platform
platform Integer
w]
| Bool
otherwise = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
naturalNBDataCon [forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitBigNat Integer
w)]
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
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 :: MonadThings m => FastString -> m CoreExpr
mkStringExprFS :: forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS = forall (m :: * -> *).
Monad m =>
(Name -> m Id) -> FastString -> m CoreExpr
mkStringExprFSLookup forall (m :: * -> *). MonadThings m => Name -> m Id
lookupId
mkStringExprFSLookup :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr
mkStringExprFSLookup :: forall (m :: * -> *).
Monad m =>
(Name -> m Id) -> FastString -> m CoreExpr
mkStringExprFSLookup Name -> m Id
lookupM FastString
str = do
MkStringIds
mk <- forall (m :: * -> *).
Applicative m =>
(Name -> m Id) -> m MkStringIds
getMkStringIds Name -> m Id
lookupM
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MkStringIds -> FastString -> CoreExpr
mkStringExprFSWith MkStringIds
mk FastString
str)
getMkStringIds :: Applicative m => (Name -> m Id) -> m MkStringIds
getMkStringIds :: forall (m :: * -> *).
Applicative m =>
(Name -> m Id) -> m MkStringIds
getMkStringIds Name -> m Id
lookupM = Id -> Id -> MkStringIds
MkStringIds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m Id
lookupM Name
unpackCStringName forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> m Id
lookupM Name
unpackCStringUtf8Name
data MkStringIds = MkStringIds
{ MkStringIds -> Id
unpackCStringId :: !Id
, MkStringIds -> Id
unpackCStringUtf8Id :: !Id
}
mkStringExprFSWith :: MkStringIds -> FastString -> CoreExpr
mkStringExprFSWith :: MkStringIds -> FastString -> CoreExpr
mkStringExprFSWith MkStringIds
ids FastString
str
| FastString -> Bool
nullFS FastString
str
= Type -> CoreExpr
mkNilExpr Type
charTy
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
safeChar String
chars
= let !unpack_id :: Id
unpack_id = MkStringIds -> Id
unpackCStringId MkStringIds
ids
in forall b. Expr b -> Expr b -> Expr b
App (forall b. Id -> Expr b
Var Id
unpack_id) CoreExpr
lit
| Bool
otherwise
= let !unpack_utf8_id :: Id
unpack_utf8_id = MkStringIds -> Id
unpackCStringUtf8Id MkStringIds
ids
in 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
. HasDebugCallStack => 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
= forall a. HasCallStack => Bool -> a -> a
assert ([Type]
tys forall a b. [a] -> [b] -> Bool
`equalLength` [CoreExpr]
exps) forall a b. (a -> b) -> a -> b
$
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 HasDebugCallStack => 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
= forall a. HasCallStack => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys forall a. Eq a => a -> a -> Bool
== Int
arity) forall a b. (a -> b) -> a -> b
$
forall a. HasCallStack => Bool -> a -> a
assert (Int
alt forall a. Ord a => a -> a -> Bool
<= Int
arity) forall a b. (a -> b) -> a -> b
$
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
= forall a. HasCallStack => Bool -> a -> a
assert (Id
var forall a. Eq a => a -> a -> Bool
== Id
should_be_the_same_var) forall a b. (a -> b) -> a -> b
$
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
= forall a. HasCallStack => Bool -> a -> a
assert (forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Id]
vars) forall a b. (a -> b) -> a -> b
$
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 (HasDebugCallStack => 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
<+> String -> SDoc
text 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))
([Demand] -> IdInfo
divergingIdInfo [] IdInfo -> CafInfo -> IdInfo
`setCafInfo` CafInfo
NoCafRefs)
mkRuntimeErrorId :: Name -> Id
mkRuntimeErrorId :: Name -> Id
mkRuntimeErrorId Name
name
= Name -> Type -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
name Type
runtimeErrorTy ([Demand] -> IdInfo
divergingIdInfo [Demand
evalDmd])
runtimeErrorTy :: Type
runtimeErrorTy :: Type
runtimeErrorTy = [Id] -> Type -> Type
mkSpecForAllTys [Id
runtimeRep1TyVar, Id
openAlphaTyVar]
(Type -> Type -> Type
mkVisFunTyMany Type
addrPrimTy Type
openAlphaTy)
divergingIdInfo :: [Demand] -> IdInfo
divergingIdInfo :: [Demand] -> IdInfo
divergingIdInfo [Demand]
arg_dmds
= IdInfo
vanillaIdInfo IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` [Demand] -> Divergence -> DmdSig
mkClosedDmdSig [Demand]
arg_dmds Divergence
botDiv
IdInfo -> CprSig -> IdInfo
`setCprSigInfo` Int -> Cpr -> CprSig
mkCprSig Int
arity Cpr
botCpr
where
arity :: Int
arity = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Demand]
arg_dmds
aBSENT_ERROR_ID :: Id
aBSENT_ERROR_ID
= Name -> Type -> IdInfo -> Id
mkVanillaGlobalWithInfo Name
absentErrorName Type
absent_ty IdInfo
id_info
where
absent_ty :: Type
absent_ty = [Id] -> Type -> Type
mkSpecForAllTys [Id
alphaTyVar] (Type -> Type -> Type
mkVisFunTyMany Type
addrPrimTy Type
alphaTy)
id_info :: IdInfo
id_info = [Demand] -> IdInfo
divergingIdInfo [Demand
evalDmd]
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)