{-# LANGUAGE CPP #-}
module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs
, deepSplitProductType_maybe, findTypeShape
, isWorkerSmallEnough
) where
#include "HsVersions.h"
import GhcPrelude
import CoreSyn
import CoreUtils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase )
import Id
import IdInfo ( JoinArity )
import DataCon
import Demand
import MkCore ( mkAbsentErrorApp, mkCoreUbxTup
, mkCoreApp, mkCoreLet )
import MkId ( voidArgId, voidPrimId )
import TysWiredIn ( tupleDataCon )
import TysPrim ( voidPrimTy )
import Literal ( absentLiteralOf, rubbishLit )
import VarEnv ( mkInScopeSet )
import VarSet ( VarSet )
import Type
import Predicate ( isClassPred )
import RepType ( isVoidTy, typePrimRep )
import Coercion
import FamInstEnv
import BasicTypes ( Boxity(..) )
import TyCon
import UniqSupply
import Unique
import Maybes
import Util
import Outputable
import DynFlags
import FastString
import ListSetOps
type WwResult
= ([Demand],
JoinArity,
Id -> CoreExpr,
CoreExpr -> CoreExpr)
mkWwBodies :: DynFlags
-> FamInstEnvs
-> VarSet
-> Id
-> [Demand]
-> DmdResult
-> UniqSM (Maybe WwResult)
mkWwBodies :: DynFlags
-> FamInstEnvs
-> VarSet
-> Id
-> [Demand]
-> DmdResult
-> UniqSM (Maybe WwResult)
mkWwBodies DynFlags
dflags FamInstEnvs
fam_envs VarSet
rhs_fvs Id
fun_id [Demand]
demands DmdResult
res_info
= do { let empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet VarSet
rhs_fvs)
; ([Id]
wrap_args, CoreExpr -> CoreExpr
wrap_fn_args, CoreExpr -> CoreExpr
work_fn_args, Type
res_ty)
<- TCvSubst
-> Type
-> [Demand]
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWargs TCvSubst
empty_subst Type
fun_ty [Demand]
demands
; (Bool
useful1, [Id]
work_args, CoreExpr -> CoreExpr
wrap_fn_str, CoreExpr -> CoreExpr
work_fn_str)
<- DynFlags
-> FamInstEnvs
-> Bool
-> [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr DynFlags
dflags FamInstEnvs
fam_envs Bool
has_inlineable_prag [Id]
wrap_args
; (Bool
useful2, CoreExpr -> CoreExpr
wrap_fn_cpr, CoreExpr -> CoreExpr
work_fn_cpr, Type
cpr_res_ty)
<- Bool
-> FamInstEnvs
-> Type
-> DmdResult
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWcpr (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CprAnal DynFlags
dflags) FamInstEnvs
fam_envs Type
res_ty DmdResult
res_info
; let ([Id]
work_lam_args, [Id]
work_call_args) = DynFlags -> [Id] -> Type -> ([Id], [Id])
mkWorkerArgs DynFlags
dflags [Id]
work_args Type
cpr_res_ty
worker_args_dmds :: [Demand]
worker_args_dmds = [Id -> Demand
idDemandInfo Id
v | Id
v <- [Id]
work_call_args, Id -> Bool
isId Id
v]
wrapper_body :: Id -> CoreExpr
wrapper_body = CoreExpr -> CoreExpr
wrap_fn_args (CoreExpr -> CoreExpr) -> (Id -> CoreExpr) -> Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap_fn_cpr (CoreExpr -> CoreExpr) -> (Id -> CoreExpr) -> Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap_fn_str (CoreExpr -> CoreExpr) -> (Id -> CoreExpr) -> Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Id] -> CoreExpr -> CoreExpr
applyToVars [Id]
work_call_args (CoreExpr -> CoreExpr) -> (Id -> CoreExpr) -> Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> CoreExpr
forall b. Id -> Expr b
Var
worker_body :: CoreExpr -> CoreExpr
worker_body = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
work_lam_args(CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
work_fn_str (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
work_fn_cpr (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
work_fn_args
; if DynFlags -> [Id] -> Bool
isWorkerSmallEnough DynFlags
dflags [Id]
work_args
Bool -> Bool -> Bool
&& Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
too_many_args_for_join_point [Id]
wrap_args)
Bool -> Bool -> Bool
&& ((Bool
useful1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
only_one_void_argument) Bool -> Bool -> Bool
|| Bool
useful2)
then Maybe WwResult -> UniqSM (Maybe WwResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (WwResult -> Maybe WwResult
forall a. a -> Maybe a
Just ([Demand]
worker_args_dmds, [Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
work_call_args,
Id -> CoreExpr
wrapper_body, CoreExpr -> CoreExpr
worker_body))
else Maybe WwResult -> UniqSM (Maybe WwResult)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe WwResult
forall a. Maybe a
Nothing
}
where
fun_ty :: Type
fun_ty = Id -> Type
idType Id
fun_id
mb_join_arity :: Maybe Int
mb_join_arity = Id -> Maybe Int
isJoinId_maybe Id
fun_id
has_inlineable_prag :: Bool
has_inlineable_prag = Unfolding -> Bool
isStableUnfolding (Id -> Unfolding
realIdUnfolding Id
fun_id)
only_one_void_argument :: Bool
only_one_void_argument
| [Demand
d] <- [Demand]
demands
, Just (Type
arg_ty1, Type
_) <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
fun_ty
, Demand -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isAbsDmd Demand
d Bool -> Bool -> Bool
&& Type -> Bool
isVoidTy Type
arg_ty1
= Bool
True
| Bool
otherwise
= Bool
False
too_many_args_for_join_point :: [a] -> Bool
too_many_args_for_join_point [a]
wrap_args
| Just Int
join_arity <- Maybe Int
mb_join_arity
, [a]
wrap_args [a] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
join_arity
= WARN(True, text "Unable to worker/wrapper join point with arity " <+>
int join_arity <+> text "but" <+>
int (length wrap_args) <+> text "args")
Bool
True
| Bool
otherwise
= Bool
False
isWorkerSmallEnough :: DynFlags -> [Var] -> Bool
isWorkerSmallEnough :: DynFlags -> [Id] -> Bool
isWorkerSmallEnough DynFlags
dflags [Id]
vars = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
vars Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= DynFlags -> Int
maxWorkerArgs DynFlags
dflags
mkWorkerArgs :: DynFlags -> [Var]
-> Type
-> ([Var],
[Var])
mkWorkerArgs :: DynFlags -> [Id] -> Type -> ([Id], [Id])
mkWorkerArgs DynFlags
dflags [Id]
args Type
res_ty
| (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
isId [Id]
args Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
needsAValueLambda
= ([Id]
args, [Id]
args)
| Bool
otherwise
= ([Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidArgId], [Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidPrimId])
where
needsAValueLambda :: Bool
needsAValueLambda =
Bool
lifted
Bool -> Bool -> Bool
|| Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_FunToThunk DynFlags
dflags)
lifted :: Bool
lifted =
case HasDebugCallStack => Type -> Maybe Bool
Type -> Maybe Bool
isLiftedType_maybe Type
res_ty of
Just Bool
lifted -> Bool
lifted
Maybe Bool
Nothing -> Bool
True
mkWWargs :: TCvSubst
-> Type
-> [Demand]
-> UniqSM ([Var],
CoreExpr -> CoreExpr,
CoreExpr -> CoreExpr,
Type)
mkWWargs :: TCvSubst
-> Type
-> [Demand]
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWargs TCvSubst
subst Type
fun_ty [Demand]
demands
| [Demand] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Demand]
demands
= ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], CoreExpr -> CoreExpr
forall a. a -> a
id, CoreExpr -> CoreExpr
forall a. a -> a
id, HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
fun_ty)
| (Demand
dmd:[Demand]
demands') <- [Demand]
demands
, Just (Type
arg_ty, Type
fun_ty') <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
fun_ty
= do { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let arg_ty' :: Type
arg_ty' = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
arg_ty
id :: Id
id = Unique -> Type -> Demand -> Id
mk_wrap_arg Unique
uniq Type
arg_ty' Demand
dmd
; ([Id]
wrap_args, CoreExpr -> CoreExpr
wrap_fn_args, CoreExpr -> CoreExpr
work_fn_args, Type
res_ty)
<- TCvSubst
-> Type
-> [Demand]
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWargs TCvSubst
subst Type
fun_ty' [Demand]
demands'
; ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
id Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
wrap_args,
Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
id (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap_fn_args,
(CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr
apply_or_bind_then CoreExpr -> CoreExpr
work_fn_args (Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
id),
Type
res_ty) }
| Just (Id
tv, Type
fun_ty') <- Type -> Maybe (Id, Type)
splitForAllTy_maybe Type
fun_ty
= do { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let (TCvSubst
subst', Id
tv') = TCvSubst -> Id -> Unique -> (TCvSubst, Id)
cloneTyVarBndr TCvSubst
subst Id
tv Unique
uniq
; ([Id]
wrap_args, CoreExpr -> CoreExpr
wrap_fn_args, CoreExpr -> CoreExpr
work_fn_args, Type
res_ty)
<- TCvSubst
-> Type
-> [Demand]
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWargs TCvSubst
subst' Type
fun_ty' [Demand]
demands
; ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
tv' Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
wrap_args,
Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
tv' (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap_fn_args,
(CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr
apply_or_bind_then CoreExpr -> CoreExpr
work_fn_args (Type -> CoreExpr
forall b. Type -> Expr b
mkTyArg (Id -> Type
mkTyVarTy Id
tv')),
Type
res_ty) }
| Just (Coercion
co, Type
rep_ty) <- Type -> Maybe (Coercion, Type)
topNormaliseNewType_maybe Type
fun_ty
= do { ([Id]
wrap_args, CoreExpr -> CoreExpr
wrap_fn_args, CoreExpr -> CoreExpr
work_fn_args, Type
res_ty)
<- TCvSubst
-> Type
-> [Demand]
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWargs TCvSubst
subst Type
rep_ty [Demand]
demands
; let co' :: Coercion
co' = HasCallStack => TCvSubst -> Coercion -> Coercion
TCvSubst -> Coercion -> Coercion
substCo TCvSubst
subst Coercion
co
; ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
wrap_args,
\CoreExpr
e -> CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (CoreExpr -> CoreExpr
wrap_fn_args CoreExpr
e) (Coercion -> Coercion
mkSymCo Coercion
co'),
\CoreExpr
e -> CoreExpr -> CoreExpr
work_fn_args (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
e Coercion
co'),
Type
res_ty) }
| Bool
otherwise
= WARN( True, ppr fun_ty )
([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], CoreExpr -> CoreExpr
forall a. a -> a
id, CoreExpr -> CoreExpr
forall a. a -> a
id, HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
fun_ty)
where
apply_or_bind_then :: (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr
apply_or_bind_then CoreExpr -> CoreExpr
k CoreExpr
arg (Lam Id
bndr CoreExpr
body)
= CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr CoreExpr
arg) (CoreExpr -> CoreExpr
k CoreExpr
body)
apply_or_bind_then CoreExpr -> CoreExpr
k CoreExpr
arg CoreExpr
fun
= CoreExpr -> CoreExpr
k (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp (String -> SDoc
text String
"mkWWargs") CoreExpr
fun CoreExpr
arg
applyToVars :: [Var] -> CoreExpr -> CoreExpr
applyToVars :: [Id] -> CoreExpr -> CoreExpr
applyToVars [Id]
vars CoreExpr
fn = CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps CoreExpr
fn [Id]
vars
mk_wrap_arg :: Unique -> Type -> Demand -> Id
mk_wrap_arg :: Unique -> Type -> Demand -> Id
mk_wrap_arg Unique
uniq Type
ty Demand
dmd
= FastString -> Unique -> Type -> Id
mkSysLocalOrCoVar (String -> FastString
fsLit String
"w") Unique
uniq Type
ty
Id -> Demand -> Id
`setIdDemandInfo` Demand
dmd
mkWWstr :: DynFlags
-> FamInstEnvs
-> Bool
-> [Var]
-> UniqSM (Bool,
[Var],
CoreExpr -> CoreExpr,
CoreExpr -> CoreExpr)
mkWWstr :: DynFlags
-> FamInstEnvs
-> Bool
-> [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr DynFlags
dflags FamInstEnvs
fam_envs Bool
has_inlineable_prag [Id]
args
= [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
go [Id]
args
where
go_one :: Id
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
go_one Id
arg = DynFlags
-> FamInstEnvs
-> Bool
-> Id
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one DynFlags
dflags FamInstEnvs
fam_envs Bool
has_inlineable_prag Id
arg
go :: [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
go [] = (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [], CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn)
go (Id
arg : [Id]
args) = do { (Bool
useful1, [Id]
args1, CoreExpr -> CoreExpr
wrap_fn1, CoreExpr -> CoreExpr
work_fn1) <- Id
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
go_one Id
arg
; (Bool
useful2, [Id]
args2, CoreExpr -> CoreExpr
wrap_fn2, CoreExpr -> CoreExpr
work_fn2) <- [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
go [Id]
args
; (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Bool
useful1 Bool -> Bool -> Bool
|| Bool
useful2
, [Id]
args1 [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
args2
, CoreExpr -> CoreExpr
wrap_fn1 (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap_fn2
, CoreExpr -> CoreExpr
work_fn1 (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
work_fn2) }
mkWWstr_one :: DynFlags -> FamInstEnvs
-> Bool
-> Var
-> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one :: DynFlags
-> FamInstEnvs
-> Bool
-> Id
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one DynFlags
dflags FamInstEnvs
fam_envs Bool
has_inlineable_prag Id
arg
| Id -> Bool
isTyVar Id
arg
= (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [Id
arg], CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn)
| Demand -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isAbsDmd Demand
dmd
, Just CoreExpr -> CoreExpr
work_fn <- DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let DynFlags
dflags Id
arg
= (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [], CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
work_fn)
| Demand -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isStrictDmd Demand
dmd
, Just [Demand]
cs <- Demand -> Maybe [Demand]
splitProdDmd_maybe Demand
dmd
, Bool -> Bool
not (Bool
has_inlineable_prag Bool -> Bool -> Bool
&& Type -> Bool
isClassPred Type
arg_ty)
, Just stuff :: (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
stuff@(DataCon
_, [Type]
_, [(Type, StrictnessMark)]
inst_con_arg_tys, Coercion
_) <- FamInstEnvs
-> Type
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
deepSplitProductType_maybe FamInstEnvs
fam_envs Type
arg_ty
, [Demand]
cs [Demand] -> [(Type, StrictnessMark)] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [(Type, StrictnessMark)]
inst_con_arg_tys
= DynFlags
-> FamInstEnvs
-> Id
-> [Demand]
-> (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
unbox_one DynFlags
dflags FamInstEnvs
fam_envs Id
arg [Demand]
cs (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
stuff
| Demand -> Bool
isSeqDmd Demand
dmd
, Just stuff :: (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
stuff@(DataCon
_, [Type]
_, [(Type, StrictnessMark)]
inst_con_arg_tys, Coercion
_) <- FamInstEnvs
-> Type
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
deepSplitProductType_maybe FamInstEnvs
fam_envs Type
arg_ty
, let abs_dmds :: [Demand]
abs_dmds = ((Type, StrictnessMark) -> Demand)
-> [(Type, StrictnessMark)] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
map (Demand -> (Type, StrictnessMark) -> Demand
forall a b. a -> b -> a
const Demand
absDmd) [(Type, StrictnessMark)]
inst_con_arg_tys
= DynFlags
-> FamInstEnvs
-> Id
-> [Demand]
-> (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
unbox_one DynFlags
dflags FamInstEnvs
fam_envs Id
arg [Demand]
abs_dmds (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
stuff
| Bool
otherwise
= (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [Id
arg], CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn)
where
arg_ty :: Type
arg_ty = Id -> Type
idType Id
arg
dmd :: Demand
dmd = Id -> Demand
idDemandInfo Id
arg
unbox_one :: DynFlags -> FamInstEnvs -> Var
-> [Demand]
-> (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
-> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
unbox_one :: DynFlags
-> FamInstEnvs
-> Id
-> [Demand]
-> (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
unbox_one DynFlags
dflags FamInstEnvs
fam_envs Id
arg [Demand]
cs
(DataCon
data_con, [Type]
inst_tys, [(Type, StrictnessMark)]
inst_con_arg_tys, Coercion
co)
= do { (Unique
uniq1:[Unique]
uniqs) <- UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; let
cs' :: [Demand]
cs' = DataCon -> [Demand] -> [Demand]
addDataConStrictness DataCon
data_con [Demand]
cs
unpk_args :: [Id]
unpk_args = (Unique -> (Type, StrictnessMark) -> Demand -> Id)
-> [Unique] -> [(Type, StrictnessMark)] -> [Demand] -> [Id]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Unique -> (Type, StrictnessMark) -> Demand -> Id
mk_ww_arg [Unique]
uniqs [(Type, StrictnessMark)]
inst_con_arg_tys [Demand]
cs'
unbox_fn :: CoreExpr -> CoreExpr
unbox_fn = CoreExpr
-> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arg) Coercion
co Unique
uniq1
DataCon
data_con [Id]
unpk_args
arg_no_unf :: Id
arg_no_unf = Id -> Id
zapStableUnfolding Id
arg
rebox_fn :: CoreExpr -> CoreExpr
rebox_fn = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
arg_no_unf CoreExpr
con_app)
con_app :: CoreExpr
con_app = DataCon -> [Type] -> [Id] -> CoreExpr
forall b. DataCon -> [Type] -> [Id] -> Expr b
mkConApp2 DataCon
data_con [Type]
inst_tys [Id]
unpk_args CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co
; (Bool
_, [Id]
worker_args, CoreExpr -> CoreExpr
wrap_fn, CoreExpr -> CoreExpr
work_fn) <- DynFlags
-> FamInstEnvs
-> Bool
-> [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr DynFlags
dflags FamInstEnvs
fam_envs Bool
False [Id]
unpk_args
; (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [Id]
worker_args, CoreExpr -> CoreExpr
unbox_fn (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap_fn, CoreExpr -> CoreExpr
work_fn (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
rebox_fn) }
where
mk_ww_arg :: Unique -> (Type, StrictnessMark) -> Demand -> Id
mk_ww_arg Unique
uniq (Type, StrictnessMark)
ty Demand
sub_dmd = Id -> Demand -> Id
setIdDemandInfo (Unique -> (Type, StrictnessMark) -> Id
mk_ww_local Unique
uniq (Type, StrictnessMark)
ty) Demand
sub_dmd
nop_fn :: CoreExpr -> CoreExpr
nop_fn :: CoreExpr -> CoreExpr
nop_fn CoreExpr
body = CoreExpr
body
addDataConStrictness :: DataCon -> [Demand] -> [Demand]
addDataConStrictness :: DataCon -> [Demand] -> [Demand]
addDataConStrictness DataCon
con [Demand]
ds
= ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds )
(Demand -> StrictnessMark -> Demand)
-> [Demand] -> [StrictnessMark] -> [Demand]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Demand -> StrictnessMark -> Demand
add [Demand]
ds [StrictnessMark]
strs
where
strs :: [StrictnessMark]
strs = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con
add :: Demand -> StrictnessMark -> Demand
add Demand
dmd StrictnessMark
str | StrictnessMark -> Bool
isMarkedStrict StrictnessMark
str = Demand -> Demand
strictifyDmd Demand
dmd
| Bool
otherwise = Demand
dmd
deepSplitProductType_maybe
:: FamInstEnvs -> Type
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
deepSplitProductType_maybe :: FamInstEnvs
-> Type
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
deepSplitProductType_maybe FamInstEnvs
fam_envs Type
ty
| let (Coercion
co, Type
ty1) = FamInstEnvs -> Type -> Maybe (Coercion, Type)
topNormaliseType_maybe FamInstEnvs
fam_envs Type
ty
Maybe (Coercion, Type) -> (Coercion, Type) -> (Coercion, Type)
forall a. Maybe a -> a -> a
`orElse` (Type -> Coercion
mkRepReflCo Type
ty, Type
ty)
, Just (TyCon
tc, [Type]
tc_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty1
, Just DataCon
con <- TyCon -> Maybe DataCon
isDataProductTyCon_maybe TyCon
tc
, let arg_tys :: [Type]
arg_tys = DataCon -> [Type] -> [Type]
dataConInstArgTys DataCon
con [Type]
tc_args
strict_marks :: [StrictnessMark]
strict_marks = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con
= (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
forall a. a -> Maybe a
Just (DataCon
con, [Type]
tc_args, String -> [Type] -> [StrictnessMark] -> [(Type, StrictnessMark)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"dspt" [Type]
arg_tys [StrictnessMark]
strict_marks, Coercion
co)
deepSplitProductType_maybe FamInstEnvs
_ Type
_ = Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
forall a. Maybe a
Nothing
deepSplitCprType_maybe
:: FamInstEnvs -> ConTag -> Type
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
deepSplitCprType_maybe :: FamInstEnvs
-> Int
-> Type
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
deepSplitCprType_maybe FamInstEnvs
fam_envs Int
con_tag Type
ty
| let (Coercion
co, Type
ty1) = FamInstEnvs -> Type -> Maybe (Coercion, Type)
topNormaliseType_maybe FamInstEnvs
fam_envs Type
ty
Maybe (Coercion, Type) -> (Coercion, Type) -> (Coercion, Type)
forall a. Maybe a -> a -> a
`orElse` (Type -> Coercion
mkRepReflCo Type
ty, Type
ty)
, Just (TyCon
tc, [Type]
tc_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty1
, TyCon -> Bool
isDataTyCon TyCon
tc
, let cons :: [DataCon]
cons = TyCon -> [DataCon]
tyConDataCons TyCon
tc
, [DataCon]
cons [DataCon] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Int
con_tag
, let con :: DataCon
con = [DataCon]
cons [DataCon] -> Int -> DataCon
forall a. Outputable a => [a] -> Int -> a
`getNth` (Int
con_tag Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fIRST_TAG)
arg_tys :: [Type]
arg_tys = DataCon -> [Type] -> [Type]
dataConInstArgTys DataCon
con [Type]
tc_args
strict_marks :: [StrictnessMark]
strict_marks = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con
= (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
forall a. a -> Maybe a
Just (DataCon
con, [Type]
tc_args, String -> [Type] -> [StrictnessMark] -> [(Type, StrictnessMark)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"dsct" [Type]
arg_tys [StrictnessMark]
strict_marks, Coercion
co)
deepSplitCprType_maybe FamInstEnvs
_ Int
_ Type
_ = Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
forall a. Maybe a
Nothing
findTypeShape :: FamInstEnvs -> Type -> TypeShape
findTypeShape :: FamInstEnvs -> Type -> TypeShape
findTypeShape FamInstEnvs
fam_envs Type
ty
| Just (TyCon
tc, [Type]
tc_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, Just DataCon
con <- TyCon -> Maybe DataCon
isDataProductTyCon_maybe TyCon
tc
= [TypeShape] -> TypeShape
TsProd ((Type -> TypeShape) -> [Type] -> [TypeShape]
forall a b. (a -> b) -> [a] -> [b]
map (FamInstEnvs -> Type -> TypeShape
findTypeShape FamInstEnvs
fam_envs) ([Type] -> [TypeShape]) -> [Type] -> [TypeShape]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Type] -> [Type]
dataConInstArgTys DataCon
con [Type]
tc_args)
| Just (Type
_, Type
res) <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
ty
= TypeShape -> TypeShape
TsFun (FamInstEnvs -> Type -> TypeShape
findTypeShape FamInstEnvs
fam_envs Type
res)
| Just (Id
_, Type
ty') <- Type -> Maybe (Id, Type)
splitForAllTy_maybe Type
ty
= FamInstEnvs -> Type -> TypeShape
findTypeShape FamInstEnvs
fam_envs Type
ty'
| Just (Coercion
_, Type
ty') <- FamInstEnvs -> Type -> Maybe (Coercion, Type)
topNormaliseType_maybe FamInstEnvs
fam_envs Type
ty
= FamInstEnvs -> Type -> TypeShape
findTypeShape FamInstEnvs
fam_envs Type
ty'
| Bool
otherwise
= TypeShape
TsUnk
mkWWcpr :: Bool
-> FamInstEnvs
-> Type
-> DmdResult
-> UniqSM (Bool,
CoreExpr -> CoreExpr,
CoreExpr -> CoreExpr,
Type)
mkWWcpr :: Bool
-> FamInstEnvs
-> Type
-> DmdResult
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWcpr Bool
opt_CprAnal FamInstEnvs
fam_envs Type
body_ty DmdResult
res
| Bool -> Bool
not Bool
opt_CprAnal = (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, CoreExpr -> CoreExpr
forall a. a -> a
id, CoreExpr -> CoreExpr
forall a. a -> a
id, Type
body_ty)
| Bool
otherwise
= case DmdResult -> Maybe Int
returnsCPR_maybe DmdResult
res of
Maybe Int
Nothing -> (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, CoreExpr -> CoreExpr
forall a. a -> a
id, CoreExpr -> CoreExpr
forall a. a -> a
id, Type
body_ty)
Just Int
con_tag | Just (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
stuff <- FamInstEnvs
-> Int
-> Type
-> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
deepSplitCprType_maybe FamInstEnvs
fam_envs Int
con_tag Type
body_ty
-> (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWcpr_help (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
stuff
| Bool
otherwise
-> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
(Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, CoreExpr -> CoreExpr
forall a. a -> a
id, CoreExpr -> CoreExpr
forall a. a -> a
id, Type
body_ty)
mkWWcpr_help :: (DataCon, [Type], [(Type,StrictnessMark)], Coercion)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWcpr_help :: (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWcpr_help (DataCon
data_con, [Type]
inst_tys, [(Type, StrictnessMark)]
arg_tys, Coercion
co)
| [arg1 :: (Type, StrictnessMark)
arg1@(Type
arg_ty1, StrictnessMark
_)] <- [(Type, StrictnessMark)]
arg_tys
, HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
arg_ty1
= do { (Unique
work_uniq : Unique
arg_uniq : [Unique]
_) <- UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; let arg :: Id
arg = Unique -> (Type, StrictnessMark) -> Id
mk_ww_local Unique
arg_uniq (Type, StrictnessMark)
arg1
con_app :: CoreExpr
con_app = DataCon -> [Type] -> [Id] -> CoreExpr
forall b. DataCon -> [Type] -> [Id] -> Expr b
mkConApp2 DataCon
data_con [Type]
inst_tys [Id
arg] CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co
; (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Bool
True
, \ CoreExpr
wkr_call -> CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase CoreExpr
wkr_call Id
arg CoreExpr
con_app
, \ CoreExpr
body -> CoreExpr
-> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase CoreExpr
body Coercion
co Unique
work_uniq DataCon
data_con [Id
arg] (Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
arg)
, Type
arg_ty1 ) }
| Bool
otherwise
= do { (Unique
work_uniq : Unique
wild_uniq : [Unique]
uniqs) <- UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; let wrap_wild :: Id
wrap_wild = Unique -> (Type, StrictnessMark) -> Id
mk_ww_local Unique
wild_uniq (Type
ubx_tup_ty,StrictnessMark
MarkedStrict)
args :: [Id]
args = (Unique -> (Type, StrictnessMark) -> Id)
-> [Unique] -> [(Type, StrictnessMark)] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Unique -> (Type, StrictnessMark) -> Id
mk_ww_local [Unique]
uniqs [(Type, StrictnessMark)]
arg_tys
ubx_tup_ty :: Type
ubx_tup_ty = CoreExpr -> Type
exprType CoreExpr
ubx_tup_app
ubx_tup_app :: CoreExpr
ubx_tup_app = [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup (((Type, StrictnessMark) -> Type)
-> [(Type, StrictnessMark)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type, StrictnessMark) -> Type
forall a b. (a, b) -> a
fst [(Type, StrictnessMark)]
arg_tys) ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr [Id]
args)
con_app :: CoreExpr
con_app = DataCon -> [Type] -> [Id] -> CoreExpr
forall b. DataCon -> [Type] -> [Id] -> Expr b
mkConApp2 DataCon
data_con [Type]
inst_tys [Id]
args CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co
tup_con :: DataCon
tup_con = Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([(Type, StrictnessMark)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, StrictnessMark)]
arg_tys)
; (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True
, \ CoreExpr
wkr_call -> CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
wkr_call Id
wrap_wild
(DataCon -> AltCon
DataAlt DataCon
tup_con) [Id]
args CoreExpr
con_app
, \ CoreExpr
body -> CoreExpr
-> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase CoreExpr
body Coercion
co Unique
work_uniq DataCon
data_con [Id]
args CoreExpr
ubx_tup_app
, Type
ubx_tup_ty ) }
mkUnpackCase :: CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase :: CoreExpr
-> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase (Tick Tickish Id
tickish CoreExpr
e) Coercion
co Unique
uniq DataCon
con [Id]
args CoreExpr
body
= Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
tickish (CoreExpr
-> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase CoreExpr
e Coercion
co Unique
uniq DataCon
con [Id]
args CoreExpr
body)
mkUnpackCase CoreExpr
scrut Coercion
co Unique
uniq DataCon
boxing_con [Id]
unpk_args CoreExpr
body
= CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
casted_scrut Id
bndr
(DataCon -> AltCon
DataAlt DataCon
boxing_con) [Id]
unpk_args CoreExpr
body
where
casted_scrut :: CoreExpr
casted_scrut = CoreExpr
scrut CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion
co
bndr :: Id
bndr = Unique -> (Type, StrictnessMark) -> Id
mk_ww_local Unique
uniq (CoreExpr -> Type
exprType CoreExpr
casted_scrut, StrictnessMark
MarkedStrict)
mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let DynFlags
dflags Id
arg
| Bool -> Bool
not (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
arg_ty)
= (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
forall a. a -> Maybe a
Just (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
lifted_arg CoreExpr
abs_rhs))
| [PrimRep
UnliftedRep] <- HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
arg_ty
= (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
forall a. a -> Maybe a
Just (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
arg CoreExpr
forall b. Expr b
unlifted_rhs))
| Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
arg_ty
, Just Literal
lit <- TyCon -> Maybe Literal
absentLiteralOf TyCon
tc
= (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
forall a. a -> Maybe a
Just (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
arg (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit)))
| Type
arg_ty Type -> Type -> Bool
`eqType` Type
voidPrimTy
= (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
forall a. a -> Maybe a
Just (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
arg (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
voidPrimId)))
| Bool
otherwise
= WARN( True, text "No absent value for" <+> ppr arg_ty )
Maybe (CoreExpr -> CoreExpr)
forall a. Maybe a
Nothing
where
lifted_arg :: Id
lifted_arg = Id
arg Id -> StrictSig -> Id
`setIdStrictness` StrictSig
botSig
arg_ty :: Type
arg_ty = Id -> Type
idType Id
arg
abs_rhs :: CoreExpr
abs_rhs = Type -> String -> CoreExpr
mkAbsentErrorApp Type
arg_ty String
msg
msg :: String
msg = DynFlags -> SDoc -> String
showSDoc (DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags GeneralFlag
Opt_SuppressUniques)
(Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
arg SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
arg))
unlifted_rhs :: Expr b
unlifted_rhs = Expr b -> [Type] -> Expr b
forall b. Expr b -> [Type] -> Expr b
mkTyApps (Literal -> Expr b
forall b. Literal -> Expr b
Lit Literal
rubbishLit) [Type
arg_ty]
mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id
mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id
mk_ww_local Unique
uniq (Type
ty,StrictnessMark
str)
= StrictnessMark -> Id -> Id
setCaseBndrEvald StrictnessMark
str (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
FastString -> Unique -> Type -> Id
mkSysLocalOrCoVar (String -> FastString
fsLit String
"ww") Unique
uniq Type
ty