{-# LANGUAGE ViewPatterns #-}
module GHC.Core.Opt.WorkWrap.Utils
( WwOpts(..), mkWwBodies, mkWWstr, mkWWstr_one
, needsVoidWorkerArg
, DataConPatContext(..)
, UnboxingDecision(..), canUnboxArg
, findTypeShape, IsRecDataConResult(..), isRecDataCon
, mkAbsentFiller
, isWorkerSmallEnough, dubiousDataConInstArgTys
, boringSplit , usefulSplit
)
where
import GHC.Prelude
import GHC.Core
import GHC.Core.Utils
import GHC.Core.DataCon
import GHC.Core.Make
import GHC.Core.Subst
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.Core.FamInstEnv
import GHC.Core.TyCon
import GHC.Core.TyCon.Set
import GHC.Core.TyCon.RecWalk
import GHC.Core.SimpleOpt( SimpleOpts )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
import GHC.Types.Var.Env
import GHC.Types.Basic
import GHC.Types.Unique.Supply
import GHC.Types.Name ( getOccFS )
import GHC.Data.FastString
import GHC.Data.OrdList
import GHC.Data.List.SetOps
import GHC.Builtin.Types ( tupleDataCon )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Control.Applicative ( (<|>) )
import Control.Monad ( zipWithM )
import Data.List ( unzip4 )
import GHC.Types.RepType
import GHC.Unit.Types
data WwOpts
= MkWwOpts
{
WwOpts -> FamInstEnvs
wo_fam_envs :: !FamInstEnvs
,
WwOpts -> SimpleOpts
wo_simple_opts :: !SimpleOpts
,
WwOpts -> Bool
wo_cpr_anal :: !Bool
,
WwOpts -> Module
wo_module :: !Module
,
WwOpts -> Bool
wo_unlift_strict :: !Bool }
type WwResult
= ([Demand],
JoinArity,
Id -> CoreExpr,
CoreExpr -> CoreExpr)
nop_fn :: CoreExpr -> CoreExpr
nop_fn :: CoreExpr -> CoreExpr
nop_fn CoreExpr
body = CoreExpr
body
mkWwBodies :: WwOpts
-> Id
-> [Var]
-> Type
-> [Demand]
-> Cpr
-> UniqSM (Maybe WwResult)
mkWwBodies :: WwOpts
-> Id -> [Id] -> Kind -> [Demand] -> Cpr -> UniqSM (Maybe WwResult)
mkWwBodies WwOpts
opts Id
fun_id [Id]
arg_vars Kind
res_ty [Demand]
demands Cpr
res_cpr
= do { Bool -> SDoc -> UniqSM ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr ((Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isId [Id]
arg_vars [Id] -> [Demand] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Demand]
demands)
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"wrong wrapper arity" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fun_id SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
arg_vars SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
res_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Demand] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Demand]
demands)
; UniqSupply
uniq_supply <- UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
; let args_free_tcvs :: TyCoVarSet
args_free_tcvs = [Kind] -> TyCoVarSet
tyCoVarsOfTypes (Kind
res_ty Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
: (Id -> Kind) -> [Id] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
varType [Id]
arg_vars)
empty_subst :: Subst
empty_subst = InScopeSet -> Subst
mkEmptySubst (TyCoVarSet -> InScopeSet
mkInScopeSet TyCoVarSet
args_free_tcvs)
zapped_arg_vars :: [Id]
zapped_arg_vars = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
zap_var [Id]
arg_vars
(Subst
subst, [Id]
cloned_arg_vars) = Subst -> UniqSupply -> [Id] -> (Subst, [Id])
cloneBndrs Subst
empty_subst UniqSupply
uniq_supply [Id]
zapped_arg_vars
res_ty' :: Kind
res_ty' = Subst -> Kind -> Kind
substTyUnchecked Subst
subst Kind
res_ty
init_str_marks :: [StrictnessMark]
init_str_marks = (Id -> StrictnessMark) -> [Id] -> [StrictnessMark]
forall a b. (a -> b) -> [a] -> [b]
map (StrictnessMark -> Id -> StrictnessMark
forall a b. a -> b -> a
const StrictnessMark
NotMarkedStrict) [Id]
cloned_arg_vars
; (Bool
useful1, [(Id, StrictnessMark)]
work_args_str, CoreExpr -> CoreExpr
wrap_fn_str, [CoreExpr]
fn_args)
<-
WwOpts
-> [Id]
-> [StrictnessMark]
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
mkWWstr WwOpts
opts [Id]
cloned_arg_vars [StrictnessMark]
init_str_marks
; let ([Id]
work_args, [StrictnessMark]
work_marks) = [(Id, StrictnessMark)] -> ([Id], [StrictnessMark])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, StrictnessMark)]
work_args_str
; (Bool
useful2, CoreExpr -> CoreExpr
wrap_fn_cpr, CoreExpr -> CoreExpr
work_fn_cpr)
<- WwOpts
-> Kind
-> Cpr
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWcpr_entry WwOpts
opts Kind
res_ty' Cpr
res_cpr
; let ([Id]
work_lam_args, [Id]
work_call_args, [StrictnessMark]
work_call_str)
| Id -> [Id] -> [Id] -> Bool
needsVoidWorkerArg Id
fun_id [Id]
arg_vars [Id]
work_args
= [Id] -> [StrictnessMark] -> ([Id], [Id], [StrictnessMark])
addVoidWorkerArg [Id]
work_args [StrictnessMark]
work_marks
| Bool
otherwise
= ([Id]
work_args, [Id]
work_args, [StrictnessMark]
work_marks)
call_work :: Id -> CoreExpr
call_work Id
work_fn = CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
work_fn) [Id]
work_call_args
call_rhs :: CoreExpr -> CoreExpr
call_rhs CoreExpr
fn_rhs = CoreExpr -> [CoreExpr] -> CoreExpr
mkAppsBeta CoreExpr
fn_rhs [CoreExpr]
fn_args
wrapper_body :: Id -> CoreExpr
wrapper_body = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
cloned_arg_vars (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
call_work
work_seq_str_flds :: CoreExpr -> CoreExpr
work_seq_str_flds = [(Id, StrictnessMark)] -> CoreExpr -> CoreExpr
mkStrictFieldSeqs ([Id] -> [StrictnessMark] -> [(Id, StrictnessMark)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
work_lam_args [StrictnessMark]
work_call_str)
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_seq_str_flds (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
call_rhs
worker_args_dmds :: [Demand]
worker_args_dmds= [ Id -> Demand
idDemandInfo Id
v | Id
v <- [Id]
work_call_args, Id -> Bool
isId Id
v]
; if ((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 a. a -> UniqSM a
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 a. [a] -> 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 a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe WwResult
forall a. Maybe a
Nothing
}
where
zap_var :: Id -> Id
zap_var Id
v | Id -> Bool
isTyVar Id
v = Id
v
| Bool
otherwise = (() :: Constraint) => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo IdInfo -> IdInfo
zap_info Id
v
zap_info :: IdInfo -> IdInfo
zap_info IdInfo
info
= IdInfo
info IdInfo -> OccInfo -> IdInfo
`setOccInfo` OccInfo
noOccInfo
only_one_void_argument :: Bool
only_one_void_argument
| [Demand
d] <- [Demand]
demands
, [Id
v] <- (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isId [Id]
arg_vars
, Demand -> Bool
isAbsDmd Demand
d Bool -> Bool -> Bool
&& (() :: Constraint) => Kind -> Bool
Kind -> Bool
isZeroBitTy (Id -> Kind
idType Id
v)
= Bool
True
| Bool
otherwise
= Bool
False
mkAppsBeta :: CoreExpr -> [CoreArg] -> CoreExpr
mkAppsBeta :: CoreExpr -> [CoreExpr] -> CoreExpr
mkAppsBeta (Lam Id
b CoreExpr
body) (CoreExpr
a:[CoreExpr]
as) = (() :: Constraint) => Id -> CoreExpr -> CoreExpr -> CoreExpr
Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
b CoreExpr
a (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$! CoreExpr -> [CoreExpr] -> CoreExpr
mkAppsBeta CoreExpr
body [CoreExpr]
as
mkAppsBeta CoreExpr
f [CoreExpr]
as = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
f [CoreExpr]
as
isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool
isWorkerSmallEnough :: Int -> Int -> [Id] -> Bool
isWorkerSmallEnough Int
max_worker_args Int
old_n_args [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
<= Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
old_n_args Int
max_worker_args
needsVoidWorkerArg :: Id -> [Var] -> [Var] -> Bool
needsVoidWorkerArg :: Id -> [Id] -> [Id] -> Bool
needsVoidWorkerArg Id
fn_id [Id]
wrap_args [Id]
work_args
= Bool
thunk_problem
Bool -> Bool -> Bool
|| Bool
needs_float_barrier
where
thunk_problem :: Bool
thunk_problem | Id -> Bool
isJoinId Id
fn_id = Bool
no_value_arg Bool -> Bool -> Bool
&& Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
work_args)
| Bool
otherwise = Bool
no_value_arg
no_value_arg :: Bool
no_value_arg = Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
isId [Id]
work_args)
needs_float_barrier :: Bool
needs_float_barrier = Bool
wrap_had_barrier Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
work_has_barrier
is_float_barrier :: Id -> Bool
is_float_barrier Id
v = Id -> Bool
isId Id
v Bool -> Bool -> Bool
&& OneShotInfo -> Bool
hasNoOneShotInfo (Id -> OneShotInfo
idOneShotInfo Id
v)
wrap_had_barrier :: Bool
wrap_had_barrier = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
is_float_barrier [Id]
wrap_args
work_has_barrier :: Bool
work_has_barrier = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
is_float_barrier [Id]
work_args
addVoidWorkerArg :: [Var] -> [StrictnessMark]
-> ( [Var]
, [Var]
, [StrictnessMark])
addVoidWorkerArg :: [Id] -> [StrictnessMark] -> ([Id], [Id], [StrictnessMark])
addVoidWorkerArg [Id]
work_args [StrictnessMark]
str_marks
= ( [Id]
work_args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidArgId]
, [Id]
work_args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidPrimId]
, [StrictnessMark]
str_marks [StrictnessMark] -> [StrictnessMark] -> [StrictnessMark]
forall a. [a] -> [a] -> [a]
++ [StrictnessMark
NotMarkedStrict] )
data DataConPatContext s
= DataConPatContext
{ forall s. DataConPatContext s -> DataCon
dcpc_dc :: !DataCon
, forall s. DataConPatContext s -> [Kind]
dcpc_tc_args :: ![Type]
, forall s. DataConPatContext s -> Coercion
dcpc_co :: !Coercion
, forall s. DataConPatContext s -> [s]
dcpc_args :: ![s]
}
data UnboxingDecision unboxing_info
= DontUnbox
| DoUnbox !unboxing_info
| DropAbsent
instance Outputable i => Outputable (UnboxingDecision i) where
ppr :: UnboxingDecision i -> SDoc
ppr UnboxingDecision i
DontUnbox = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DontUnbox"
ppr UnboxingDecision i
DropAbsent = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DropAbsent"
ppr (DoUnbox i
i) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DoUnbox" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (i -> SDoc
forall a. Outputable a => a -> SDoc
ppr i
i)
wwUseForUnlifting :: WwOpts -> WwUse
wwUseForUnlifting :: WwOpts -> Bool
wwUseForUnlifting !WwOpts
opts
| WwOpts -> Bool
wo_unlift_strict WwOpts
opts = Bool
usefulSplit
| Bool
otherwise = Bool
boringSplit
type WwUse = Bool
boringSplit :: WwUse
boringSplit :: Bool
boringSplit = Bool
False
usefulSplit :: WwUse
usefulSplit :: Bool
usefulSplit = Bool
True
canUnboxArg
:: FamInstEnvs
-> Type
-> Demand
-> UnboxingDecision (DataConPatContext Demand)
canUnboxArg :: FamInstEnvs
-> Kind -> Demand -> UnboxingDecision (DataConPatContext Demand)
canUnboxArg FamInstEnvs
fam_envs Kind
ty (Card
n :* SubDemand
sd)
| Card -> Bool
isAbs Card
n
= UnboxingDecision (DataConPatContext Demand)
forall unboxing_info. UnboxingDecision unboxing_info
DropAbsent
| Just (TyCon
tc, [Kind]
tc_args, Coercion
co) <- FamInstEnvs -> Kind -> Maybe (TyCon, [Kind], Coercion)
normSplitTyConApp_maybe FamInstEnvs
fam_envs Kind
ty
, Just DataCon
dc <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tc
, let arity :: Int
arity = DataCon -> Int
dataConRepArity DataCon
dc
, Just (Boxity
Unboxed, [Demand]
dmds) <- Int -> SubDemand -> Maybe (Boxity, [Demand])
viewProd Int
arity SubDemand
sd
, [Demand]
dmds [Demand] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` DataCon -> Int
dataConRepArity DataCon
dc
= DataConPatContext Demand
-> UnboxingDecision (DataConPatContext Demand)
forall unboxing_info.
unboxing_info -> UnboxingDecision unboxing_info
DoUnbox (DataConPatContext { dcpc_dc :: DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: [Kind]
dcpc_tc_args = [Kind]
tc_args
, dcpc_co :: Coercion
dcpc_co = Coercion
co, dcpc_args :: [Demand]
dcpc_args = [Demand]
dmds })
| Bool
otherwise
= UnboxingDecision (DataConPatContext Demand)
forall unboxing_info. UnboxingDecision unboxing_info
DontUnbox
canUnboxResult :: FamInstEnvs -> Type -> Cpr
-> UnboxingDecision (DataConPatContext Cpr)
canUnboxResult :: FamInstEnvs
-> Kind -> Cpr -> UnboxingDecision (DataConPatContext Cpr)
canUnboxResult FamInstEnvs
fam_envs Kind
ty Cpr
cpr
| Just (Int
con_tag, [Cpr]
arg_cprs) <- Cpr -> Maybe (Int, [Cpr])
asConCpr Cpr
cpr
, Just (TyCon
tc, [Kind]
tc_args, Coercion
co) <- FamInstEnvs -> Kind -> Maybe (TyCon, [Kind], Coercion)
normSplitTyConApp_maybe FamInstEnvs
fam_envs Kind
ty
, Just [DataCon]
dcs <- TyCon -> Maybe [DataCon]
tyConAlgDataCons_maybe TyCon
tc Maybe [DataCon] -> Maybe [DataCon] -> Maybe [DataCon]
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe [DataCon]
open_body_ty_warning
, [DataCon]
dcs [DataCon] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Int
con_tag
, let dc :: DataCon
dc = [DataCon]
dcs [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)
, [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Id]
dataConExTyCoVars DataCon
dc)
, (Scaled Kind -> Bool) -> [Scaled Kind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Scaled Kind -> Bool
forall a. Scaled a -> Bool
isLinear (DataCon -> [Kind] -> [Scaled Kind]
dataConInstArgTys DataCon
dc [Kind]
tc_args)
= DataConPatContext Cpr -> UnboxingDecision (DataConPatContext Cpr)
forall unboxing_info.
unboxing_info -> UnboxingDecision unboxing_info
DoUnbox (DataConPatContext { dcpc_dc :: DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: [Kind]
dcpc_tc_args = [Kind]
tc_args
, dcpc_co :: Coercion
dcpc_co = Coercion
co, dcpc_args :: [Cpr]
dcpc_args = [Cpr]
arg_cprs })
| Bool
otherwise
= UnboxingDecision (DataConPatContext Cpr)
forall unboxing_info. UnboxingDecision unboxing_info
DontUnbox
where
open_body_ty_warning :: Maybe [DataCon]
open_body_ty_warning = Bool -> String -> SDoc -> Maybe [DataCon] -> Maybe [DataCon]
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True String
"canUnboxResult: non-algebraic or open body type" (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
ty) Maybe [DataCon]
forall a. Maybe a
Nothing
isLinear :: Scaled a -> Bool
isLinear :: forall a. Scaled a -> Bool
isLinear (Scaled Kind
w a
_ ) =
case Kind
w of
Kind
OneTy -> Bool
True
Kind
_ -> Bool
False
mkWWstr :: WwOpts
-> [Var]
-> [StrictnessMark]
-> UniqSM (WwUse,
[(Var,StrictnessMark)],
CoreExpr -> CoreExpr,
[CoreExpr])
mkWWstr :: WwOpts
-> [Id]
-> [StrictnessMark]
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
mkWWstr WwOpts
opts [Id]
args [StrictnessMark]
str_marks
=
[Id]
-> [StrictnessMark]
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
go [Id]
args [StrictnessMark]
str_marks
where
go :: [Id]
-> [StrictnessMark]
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
go [] [StrictnessMark]
_ = (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
boringSplit, [], CoreExpr -> CoreExpr
nop_fn, [])
go (Id
arg : [Id]
args) (StrictnessMark
str:[StrictnessMark]
strs)
= do { (Bool
useful1, [(Id, StrictnessMark)]
args1, CoreExpr -> CoreExpr
wrap_fn1, CoreExpr
wrap_arg) <- WwOpts
-> Id
-> StrictnessMark
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
mkWWstr_one WwOpts
opts Id
arg StrictnessMark
str
; (Bool
useful2, [(Id, StrictnessMark)]
args2, CoreExpr -> CoreExpr
wrap_fn2, [CoreExpr]
wrap_args) <- [Id]
-> [StrictnessMark]
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
go [Id]
args [StrictnessMark]
strs
; (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( Bool
useful1 Bool -> Bool -> Bool
|| Bool
useful2
, [(Id, StrictnessMark)]
args1 [(Id, StrictnessMark)]
-> [(Id, StrictnessMark)] -> [(Id, StrictnessMark)]
forall a. [a] -> [a] -> [a]
++ [(Id, StrictnessMark)]
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
wrap_argCoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr]
wrap_args ) }
go [Id]
_ [StrictnessMark]
_ = String
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
forall a. HasCallStack => String -> a
panic String
"mkWWstr: Impossible - str/arg length mismatch"
mkWWstr_one :: WwOpts
-> Var
-> StrictnessMark
-> UniqSM (WwUse, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
mkWWstr_one :: WwOpts
-> Id
-> StrictnessMark
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
mkWWstr_one WwOpts
opts Id
arg StrictnessMark
str_mark =
case FamInstEnvs
-> Kind -> Demand -> UnboxingDecision (DataConPatContext Demand)
canUnboxArg FamInstEnvs
fam_envs Kind
arg_ty Demand
arg_dmd of
UnboxingDecision (DataConPatContext Demand)
_ | Id -> Bool
isTyVar Id
arg -> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
do_nothing
UnboxingDecision (DataConPatContext Demand)
DropAbsent
| Just CoreExpr
absent_filler <- WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr
mkAbsentFiller WwOpts
opts Id
arg StrictnessMark
str_mark
-> (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
usefulSplit, [], CoreExpr -> CoreExpr
nop_fn, CoreExpr
absent_filler)
| Bool
otherwise -> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
do_nothing
DoUnbox DataConPatContext Demand
dcpc ->
WwOpts
-> Id
-> DataConPatContext Demand
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
unbox_one_arg WwOpts
opts Id
arg DataConPatContext Demand
dcpc
UnboxingDecision (DataConPatContext Demand)
DontUnbox
| Demand -> Bool
isStrictDmd Demand
arg_dmd Bool -> Bool -> Bool
|| StrictnessMark -> Bool
isMarkedStrict StrictnessMark
str_mark
, WwOpts -> Bool
wwUseForUnlifting WwOpts
opts
, Bool -> Bool
not (Kind -> Bool
isFunTy Kind
arg_ty)
, Bool -> Bool
not ((() :: Constraint) => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
arg_ty)
-> (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
usefulSplit, [(Id
arg, StrictnessMark
MarkedStrict)], CoreExpr -> CoreExpr
nop_fn, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
arg )
| Bool
otherwise -> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
do_nothing
where
fam_envs :: FamInstEnvs
fam_envs = WwOpts -> FamInstEnvs
wo_fam_envs WwOpts
opts
arg_ty :: Kind
arg_ty = Id -> Kind
idType Id
arg
arg_dmd :: Demand
arg_dmd = Id -> Demand
idDemandInfo Id
arg
arg_str :: StrictnessMark
arg_str | Id -> Bool
isTyVar Id
arg = StrictnessMark
NotMarkedStrict
| Bool
otherwise = StrictnessMark
str_mark
do_nothing :: UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
do_nothing = (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
boringSplit, [(Id
arg,StrictnessMark
arg_str)], CoreExpr -> CoreExpr
nop_fn, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
arg)
unbox_one_arg :: WwOpts
-> Var -> DataConPatContext Demand
-> UniqSM (WwUse, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
unbox_one_arg :: WwOpts
-> Id
-> DataConPatContext Demand
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
unbox_one_arg WwOpts
opts Id
arg_var
DataConPatContext { dcpc_dc :: forall s. DataConPatContext s -> DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: forall s. DataConPatContext s -> [Kind]
dcpc_tc_args = [Kind]
tc_args
, dcpc_co :: forall s. DataConPatContext s -> Coercion
dcpc_co = Coercion
co, dcpc_args :: forall s. DataConPatContext s -> [s]
dcpc_args = [Demand]
ds }
= do { [Unique]
pat_bndrs_uniqs <- UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; let ex_name_fss :: [FastString]
ex_name_fss = (Id -> FastString) -> [Id] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map Id -> FastString
forall a. NamedThing a => a -> FastString
getOccFS ([Id] -> [FastString]) -> [Id] -> [FastString]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Id]
dataConExTyCoVars DataCon
dc
([Id]
ex_tvs', [Id]
arg_ids) = [FastString]
-> [Unique] -> Kind -> DataCon -> [Kind] -> ([Id], [Id])
dataConRepFSInstPat ([FastString]
ex_name_fss [FastString] -> [FastString] -> [FastString]
forall a. [a] -> [a] -> [a]
++ FastString -> [FastString]
forall a. a -> [a]
repeat FastString
ww_prefix)
[Unique]
pat_bndrs_uniqs (Id -> Kind
idMult Id
arg_var) DataCon
dc [Kind]
tc_args
con_str_marks :: [StrictnessMark]
con_str_marks = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
dc
arg_ids' :: [Id]
arg_ids' = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
zapIdUnfolding ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$
String -> (Id -> Demand -> Id) -> [Id] -> [Demand] -> [Id]
forall a b c.
(() :: Constraint) =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"unbox_one_arg" Id -> Demand -> Id
setIdDemandInfo [Id]
arg_ids [Demand]
ds
unbox_fn :: CoreExpr -> CoreExpr
unbox_fn = CoreExpr
-> Coercion -> Kind -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arg_var) Coercion
co (Id -> Kind
idMult Id
arg_var)
DataCon
dc ([Id]
ex_tvs' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
arg_ids')
all_str_marks :: [StrictnessMark]
all_str_marks = ((Id -> StrictnessMark) -> [Id] -> [StrictnessMark]
forall a b. (a -> b) -> [a] -> [b]
map (StrictnessMark -> Id -> StrictnessMark
forall a b. a -> b -> a
const StrictnessMark
NotMarkedStrict) [Id]
ex_tvs') [StrictnessMark] -> [StrictnessMark] -> [StrictnessMark]
forall a. [a] -> [a] -> [a]
++ [StrictnessMark]
con_str_marks
; (Bool
nested_useful, [(Id, StrictnessMark)]
worker_args, CoreExpr -> CoreExpr
wrap_fn, [CoreExpr]
wrap_args)
<- WwOpts
-> [Id]
-> [StrictnessMark]
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
mkWWstr WwOpts
opts ([Id]
ex_tvs' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
arg_ids') [StrictnessMark]
all_str_marks
; let wrap_arg :: CoreExpr
wrap_arg = DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
dc ((Kind -> CoreExpr) -> [Kind] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> CoreExpr
forall b. Kind -> Expr b
Type [Kind]
tc_args [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
wrap_args) (() :: Constraint) => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co
; (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr))
-> (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-> UniqSM
(Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
forall a b. (a -> b) -> a -> b
$ if DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
nested_useful
then (Bool
boringSplit, [(Id
arg_var,StrictnessMark
NotMarkedStrict)], CoreExpr -> CoreExpr
nop_fn, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
arg_var)
else (Bool
usefulSplit, [(Id, StrictnessMark)]
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
wrap_arg) }
mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr
mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr
mkAbsentFiller WwOpts
opts Id
arg StrictnessMark
str
| Kind -> Bool
mightBeLiftedType Kind
arg_ty
, Bool -> Bool
not Bool
is_strict
, Bool -> Bool
not (StrictnessMark -> Bool
isMarkedStrict StrictnessMark
str)
= CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Kind -> String -> CoreExpr
mkAbsentErrorApp Kind
arg_ty String
msg)
| Bool
otherwise
= Kind -> Maybe CoreExpr
mkLitRubbish Kind
arg_ty
where
arg_ty :: Kind
arg_ty = Id -> Kind
idType Id
arg
is_strict :: Bool
is_strict = Demand -> Bool
isStrictDmd (Id -> Demand
idDemandInfo Id
arg)
msg :: String
msg = SDocContext -> SDoc -> String
renderWithContext
(SDocContext
defaultSDocContext { sdocSuppressUniques = True })
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Arg:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
arg
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Type:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
arg_ty
, SDoc
file_msg ])
file_msg :: SDoc
file_msg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> SDoc) -> Module -> SDoc
forall a b. (a -> b) -> a -> b
$ WwOpts -> Module
wo_module WwOpts
opts)
dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]
dubiousDataConInstArgTys :: DataCon -> [Kind] -> [Kind]
dubiousDataConInstArgTys DataCon
dc [Kind]
tc_args = [Kind]
arg_tys
where
univ_tvs :: [Id]
univ_tvs = DataCon -> [Id]
dataConUnivTyVars DataCon
dc
ex_tvs :: [Id]
ex_tvs = DataCon -> [Id]
dataConExTyCoVars DataCon
dc
univ_subst :: Subst
univ_subst = [Id] -> [Kind] -> Subst
(() :: Constraint) => [Id] -> [Kind] -> Subst
zipTvSubst [Id]
univ_tvs [Kind]
tc_args
(Subst
full_subst, [Id]
_) = (() :: Constraint) => Subst -> [Id] -> (Subst, [Id])
Subst -> [Id] -> (Subst, [Id])
substTyVarBndrs Subst
univ_subst [Id]
ex_tvs
arg_tys :: [Kind]
arg_tys = (Scaled Kind -> Kind) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map ((() :: Constraint) => Subst -> Kind -> Kind
Subst -> Kind -> Kind
substTy Subst
full_subst (Kind -> Kind) -> (Scaled Kind -> Kind) -> Scaled Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scaled Kind -> Kind
forall a. Scaled a -> a
scaledThing) ([Scaled Kind] -> [Kind]) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> a -> b
$
DataCon -> [Scaled Kind]
dataConRepArgTys DataCon
dc
findTypeShape :: FamInstEnvs -> Type -> TypeShape
findTypeShape :: FamInstEnvs -> Kind -> TypeShape
findTypeShape FamInstEnvs
fam_envs Kind
ty
= RecTcChecker -> Kind -> TypeShape
go (Int -> RecTcChecker -> RecTcChecker
setRecTcMaxBound Int
2 RecTcChecker
initRecTc) Kind
ty
where
go :: RecTcChecker -> Kind -> TypeShape
go RecTcChecker
rec_tc Kind
ty
| Just (FunTyFlag
_, Kind
_, Kind
_, Kind
res) <- Kind -> Maybe (FunTyFlag, Kind, Kind, Kind)
splitFunTy_maybe Kind
ty
= TypeShape -> TypeShape
TsFun (RecTcChecker -> Kind -> TypeShape
go RecTcChecker
rec_tc Kind
res)
| Just (TyCon
tc, [Kind]
tc_args) <- (() :: Constraint) => Kind -> Maybe (TyCon, [Kind])
Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe Kind
ty
= RecTcChecker -> TyCon -> [Kind] -> TypeShape
go_tc RecTcChecker
rec_tc TyCon
tc [Kind]
tc_args
| Just (Id
_, Kind
ty') <- Kind -> Maybe (Id, Kind)
splitForAllTyCoVar_maybe Kind
ty
= RecTcChecker -> Kind -> TypeShape
go RecTcChecker
rec_tc Kind
ty'
| Bool
otherwise
= TypeShape
TsUnk
go_tc :: RecTcChecker -> TyCon -> [Kind] -> TypeShape
go_tc RecTcChecker
rec_tc TyCon
tc [Kind]
tc_args
| Just (HetReduction (Reduction Coercion
_ Kind
rhs) MCoercionN
_) <- FamInstEnvs -> TyCon -> [Kind] -> Maybe HetReduction
topReduceTyFamApp_maybe FamInstEnvs
fam_envs TyCon
tc [Kind]
tc_args
= RecTcChecker -> Kind -> TypeShape
go RecTcChecker
rec_tc Kind
rhs
| Just DataCon
con <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tc
, Just RecTcChecker
rec_tc <- if TyCon -> Bool
isTupleTyCon TyCon
tc
then RecTcChecker -> Maybe RecTcChecker
forall a. a -> Maybe a
Just RecTcChecker
rec_tc
else RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec_tc TyCon
tc
= [TypeShape] -> TypeShape
TsProd ((Kind -> TypeShape) -> [Kind] -> [TypeShape]
forall a b. (a -> b) -> [a] -> [b]
map (RecTcChecker -> Kind -> TypeShape
go RecTcChecker
rec_tc) (DataCon -> [Kind] -> [Kind]
dubiousDataConInstArgTys DataCon
con [Kind]
tc_args))
| Just (Kind
ty', Coercion
_) <- TyCon -> [Kind] -> Maybe (Kind, Coercion)
instNewTyCon_maybe TyCon
tc [Kind]
tc_args
, Just RecTcChecker
rec_tc <- RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec_tc TyCon
tc
= RecTcChecker -> Kind -> TypeShape
go RecTcChecker
rec_tc Kind
ty'
| Bool
otherwise
= TypeShape
TsUnk
data IsRecDataConResult
= DefinitelyRecursive
| NonRecursiveOrUnsure
deriving (IsRecDataConResult -> IsRecDataConResult -> Bool
(IsRecDataConResult -> IsRecDataConResult -> Bool)
-> (IsRecDataConResult -> IsRecDataConResult -> Bool)
-> Eq IsRecDataConResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IsRecDataConResult -> IsRecDataConResult -> Bool
== :: IsRecDataConResult -> IsRecDataConResult -> Bool
$c/= :: IsRecDataConResult -> IsRecDataConResult -> Bool
/= :: IsRecDataConResult -> IsRecDataConResult -> Bool
Eq, Int -> IsRecDataConResult -> ShowS
[IsRecDataConResult] -> ShowS
IsRecDataConResult -> String
(Int -> IsRecDataConResult -> ShowS)
-> (IsRecDataConResult -> String)
-> ([IsRecDataConResult] -> ShowS)
-> Show IsRecDataConResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IsRecDataConResult -> ShowS
showsPrec :: Int -> IsRecDataConResult -> ShowS
$cshow :: IsRecDataConResult -> String
show :: IsRecDataConResult -> String
$cshowList :: [IsRecDataConResult] -> ShowS
showList :: [IsRecDataConResult] -> ShowS
Show)
instance Outputable IsRecDataConResult where
ppr :: IsRecDataConResult -> SDoc
ppr = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc)
-> (IsRecDataConResult -> String) -> IsRecDataConResult -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsRecDataConResult -> String
forall a. Show a => a -> String
show
combineIRDCR :: IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult
combineIRDCR :: IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult
combineIRDCR IsRecDataConResult
DefinitelyRecursive IsRecDataConResult
_ = IsRecDataConResult
DefinitelyRecursive
combineIRDCR IsRecDataConResult
_ IsRecDataConResult
DefinitelyRecursive = IsRecDataConResult
DefinitelyRecursive
combineIRDCR IsRecDataConResult
_ IsRecDataConResult
_ = IsRecDataConResult
NonRecursiveOrUnsure
combineIRDCRs :: [IsRecDataConResult] -> IsRecDataConResult
combineIRDCRs :: [IsRecDataConResult] -> IsRecDataConResult
combineIRDCRs = (IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult)
-> IsRecDataConResult -> [IsRecDataConResult] -> IsRecDataConResult
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult
combineIRDCR IsRecDataConResult
NonRecursiveOrUnsure
{-# INLINE combineIRDCRs #-}
isRecDataCon :: FamInstEnvs -> IntWithInf -> DataCon -> IsRecDataConResult
isRecDataCon :: FamInstEnvs -> IntWithInf -> DataCon -> IsRecDataConResult
isRecDataCon FamInstEnvs
fam_envs IntWithInf
fuel DataCon
orig_dc
| DataCon -> Bool
isTupleDataCon DataCon
orig_dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
orig_dc
= IsRecDataConResult
NonRecursiveOrUnsure
| Bool
otherwise
=
IntWithInf -> TyConSet -> DataCon -> IsRecDataConResult
go_dc IntWithInf
fuel TyConSet
emptyTyConSet DataCon
orig_dc
where
go_dc :: IntWithInf -> TyConSet -> DataCon -> IsRecDataConResult
go_dc :: IntWithInf -> TyConSet -> DataCon -> IsRecDataConResult
go_dc IntWithInf
fuel TyConSet
visited_tcs DataCon
dc =
[IsRecDataConResult] -> IsRecDataConResult
combineIRDCRs [ IntWithInf -> TyConSet -> Kind -> IsRecDataConResult
go_arg_ty IntWithInf
fuel TyConSet
visited_tcs Kind
arg_ty
| Kind
arg_ty <- (Scaled Kind -> Kind) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Kind -> Kind
forall a. Scaled a -> a
scaledThing (DataCon -> [Scaled Kind]
dataConRepArgTys DataCon
dc) ]
go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult
go_arg_ty :: IntWithInf -> TyConSet -> Kind -> IsRecDataConResult
go_arg_ty IntWithInf
fuel TyConSet
visited_tcs Kind
ty
| Just (Id
_tcv, Kind
ty') <- Kind -> Maybe (Id, Kind)
splitForAllTyCoVar_maybe Kind
ty
= IntWithInf -> TyConSet -> Kind -> IsRecDataConResult
go_arg_ty IntWithInf
fuel TyConSet
visited_tcs Kind
ty'
| Just (TyCon
tc, [Kind]
tc_args) <- (() :: Constraint) => Kind -> Maybe (TyCon, [Kind])
Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe Kind
ty
= IntWithInf -> TyConSet -> TyCon -> [Kind] -> IsRecDataConResult
go_tc_app IntWithInf
fuel TyConSet
visited_tcs TyCon
tc [Kind]
tc_args
| Bool
otherwise
= IsRecDataConResult
NonRecursiveOrUnsure
go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult
go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Kind] -> IsRecDataConResult
go_tc_app IntWithInf
fuel TyConSet
visited_tcs TyCon
tc [Kind]
tc_args =
case TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tc of
Maybe [DataCon]
_ | Just (HetReduction (Reduction Coercion
_ Kind
rhs) MCoercionN
_) <- FamInstEnvs -> TyCon -> [Kind] -> Maybe HetReduction
topReduceTyFamApp_maybe FamInstEnvs
fam_envs TyCon
tc [Kind]
tc_args
-> IntWithInf -> TyConSet -> Kind -> IsRecDataConResult
go_arg_ty IntWithInf
fuel TyConSet
visited_tcs Kind
rhs
Maybe [DataCon]
_ | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> TyCon
dataConTyCon DataCon
orig_dc
-> IsRecDataConResult
DefinitelyRecursive
Just [DataCon]
dcs
| IsRecDataConResult
DefinitelyRecursive <- [IsRecDataConResult] -> IsRecDataConResult
combineIRDCRs [ IntWithInf -> TyConSet -> Kind -> IsRecDataConResult
go_arg_ty IntWithInf
fuel TyConSet
visited_tcs' Kind
ty | Kind
ty <- [Kind]
tc_args ]
-> IsRecDataConResult
DefinitelyRecursive
| IntWithInf
fuel IntWithInf -> IntWithInf -> Bool
forall a. Ord a => a -> a -> Bool
>= IntWithInf
0
, Bool -> Bool
not (TyCon
tc TyCon -> TyConSet -> Bool
`elemTyConSet` TyConSet
visited_tcs)
-> [IsRecDataConResult] -> IsRecDataConResult
combineIRDCRs [ IntWithInf -> TyConSet -> DataCon -> IsRecDataConResult
go_dc (IntWithInf -> Int -> IntWithInf
subWithInf IntWithInf
fuel Int
1) TyConSet
visited_tcs' DataCon
dc | DataCon
dc <- [DataCon]
dcs ]
Maybe [DataCon]
_ -> IsRecDataConResult
NonRecursiveOrUnsure
where
visited_tcs' :: TyConSet
visited_tcs' = TyConSet -> TyCon -> TyConSet
extendTyConSet TyConSet
visited_tcs TyCon
tc
mkWWcpr_entry
:: WwOpts
-> Type
-> Cpr
-> UniqSM (WwUse,
CoreExpr -> CoreExpr,
CoreExpr -> CoreExpr)
mkWWcpr_entry :: WwOpts
-> Kind
-> Cpr
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWcpr_entry WwOpts
opts Kind
body_ty Cpr
body_cpr
| Bool -> Bool
not (WwOpts -> Bool
wo_cpr_anal WwOpts
opts) = (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
boringSplit, CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn)
| Bool
otherwise = do
Id
res_bndr <- Kind -> UniqSM Id
mk_res_bndr Kind
body_ty
let bind_res_bndr :: CoreExpr -> CoreExpr -> CoreExpr
bind_res_bndr CoreExpr
body CoreExpr
scope = CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase CoreExpr
body Id
res_bndr CoreExpr
scope
(Bool
useful, OrdList Id -> [Id]
forall a. OrdList a -> [a]
fromOL -> [Id]
transit_vars, CoreExpr
rebuilt_result, CoreExpr -> CoreExpr
work_unpack_res) <-
WwOpts
-> Id
-> Cpr
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
mkWWcpr_one WwOpts
opts Id
res_bndr Cpr
body_cpr
let (CoreExpr -> CoreExpr -> CoreExpr
unbox_transit_tup, CoreExpr
transit_tup) = [Id] -> (CoreExpr -> CoreExpr -> CoreExpr, CoreExpr)
move_transit_vars [Id]
transit_vars
let wrap_fn :: CoreExpr -> CoreExpr
wrap_fn = CoreExpr -> CoreExpr -> CoreExpr
unbox_transit_tup CoreExpr
rebuilt_result
work_fn :: CoreExpr -> CoreExpr
work_fn CoreExpr
body = CoreExpr -> CoreExpr -> CoreExpr
bind_res_bndr CoreExpr
body (CoreExpr -> CoreExpr
work_unpack_res CoreExpr
transit_tup)
(Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr))
-> (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$ if Bool -> Bool
not Bool
useful
then (Bool
boringSplit, CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn)
else (Bool
usefulSplit, CoreExpr -> CoreExpr
wrap_fn, CoreExpr -> CoreExpr
work_fn)
mk_res_bndr :: Type -> UniqSM Id
mk_res_bndr :: Kind -> UniqSM Id
mk_res_bndr Kind
body_ty = do
Id
bndr <- FastString -> Kind -> Kind -> UniqSM Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> Kind -> Kind -> m Id
mkSysLocalOrCoVarM FastString
ww_prefix Kind
cprCaseBndrMult Kind
body_ty
Id -> UniqSM Id
forall a. a -> UniqSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StrictnessMark -> Id -> Id
setCaseBndrEvald StrictnessMark
MarkedStrict Id
bndr)
type CprWwResultOne = (WwUse, OrdList Var, CoreExpr , CoreExpr -> CoreExpr)
type CprWwResultMany = (WwUse, OrdList Var, [CoreExpr], CoreExpr -> CoreExpr)
mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResultMany
mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResultMany
mkWWcpr WwOpts
_opts [Id]
vars [] =
CprWwResultMany -> UniqSM CprWwResultMany
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
boringSplit, [Id] -> OrdList Id
forall a. [a] -> OrdList a
toOL [Id]
vars, (Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr [Id]
vars, CoreExpr -> CoreExpr
nop_fn)
mkWWcpr WwOpts
opts [Id]
vars [Cpr]
cprs = do
Bool -> SDoc -> UniqSM ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
isTyVar [Id]
vars)) ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
vars SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Cpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Cpr]
cprs)
Bool -> SDoc -> UniqSM ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr ([Id] -> [Cpr] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Id]
vars [Cpr]
cprs) ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
vars SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Cpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Cpr]
cprs)
([Bool]
usefuls, [OrdList Id]
varss, [CoreExpr]
rebuilt_results, [CoreExpr -> CoreExpr]
work_unpack_ress) <-
[(Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)]
-> ([Bool], [OrdList Id], [CoreExpr], [CoreExpr -> CoreExpr])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([(Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)]
-> ([Bool], [OrdList Id], [CoreExpr], [CoreExpr -> CoreExpr]))
-> UniqSM [(Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)]
-> UniqSM
([Bool], [OrdList Id], [CoreExpr], [CoreExpr -> CoreExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id
-> Cpr
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr))
-> [Id]
-> [Cpr]
-> UniqSM [(Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (WwOpts
-> Id
-> Cpr
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
mkWWcpr_one WwOpts
opts) [Id]
vars [Cpr]
cprs
CprWwResultMany -> UniqSM CprWwResultMany
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
usefuls
, [OrdList Id] -> OrdList Id
forall a. [OrdList a] -> OrdList a
concatOL [OrdList Id]
varss
, [CoreExpr]
rebuilt_results
, ((CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr)
-> [CoreExpr -> CoreExpr]
-> CoreExpr
-> CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) CoreExpr -> CoreExpr
nop_fn [CoreExpr -> CoreExpr]
work_unpack_ress )
mkWWcpr_one :: WwOpts -> Id -> Cpr -> UniqSM CprWwResultOne
mkWWcpr_one :: WwOpts
-> Id
-> Cpr
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
mkWWcpr_one WwOpts
opts Id
res_bndr Cpr
cpr
| Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Id -> Bool
isTyVar Id
res_bndr) ) Bool
True
, DoUnbox DataConPatContext Cpr
dcpc <- FamInstEnvs
-> Kind -> Cpr -> UnboxingDecision (DataConPatContext Cpr)
canUnboxResult (WwOpts -> FamInstEnvs
wo_fam_envs WwOpts
opts) (Id -> Kind
idType Id
res_bndr) Cpr
cpr
= WwOpts
-> Id
-> DataConPatContext Cpr
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
unbox_one_result WwOpts
opts Id
res_bndr DataConPatContext Cpr
dcpc
| Bool
otherwise
= (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
boringSplit, Id -> OrdList Id
forall a. a -> OrdList a
unitOL Id
res_bndr, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
res_bndr, CoreExpr -> CoreExpr
nop_fn)
unbox_one_result
:: WwOpts -> Id -> DataConPatContext Cpr -> UniqSM CprWwResultOne
unbox_one_result :: WwOpts
-> Id
-> DataConPatContext Cpr
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
unbox_one_result WwOpts
opts Id
res_bndr
DataConPatContext { dcpc_dc :: forall s. DataConPatContext s -> DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: forall s. DataConPatContext s -> [Kind]
dcpc_tc_args = [Kind]
tc_args
, dcpc_co :: forall s. DataConPatContext s -> Coercion
dcpc_co = Coercion
co, dcpc_args :: forall s. DataConPatContext s -> [s]
dcpc_args = [Cpr]
arg_cprs } = do
[Unique]
pat_bndrs_uniqs <- UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
let ([Id]
_exs, [Id]
arg_ids) =
[FastString]
-> [Unique] -> Kind -> DataCon -> [Kind] -> ([Id], [Id])
dataConRepFSInstPat (FastString -> [FastString]
forall a. a -> [a]
repeat FastString
ww_prefix) [Unique]
pat_bndrs_uniqs Kind
cprCaseBndrMult DataCon
dc [Kind]
tc_args
Bool -> UniqSM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
_exs)
(Bool
nested_useful, OrdList Id
transit_vars, [CoreExpr]
con_args, CoreExpr -> CoreExpr
work_unbox_res) <-
WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResultMany
mkWWcpr WwOpts
opts [Id]
arg_ids [Cpr]
arg_cprs
let
rebuilt_result :: CoreExpr
rebuilt_result = DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
dc ((Kind -> CoreExpr) -> [Kind] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> CoreExpr
forall b. Kind -> Expr b
Type [Kind]
tc_args [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
con_args) (() :: Constraint) => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co
this_work_unbox_res :: CoreExpr -> CoreExpr
this_work_unbox_res = CoreExpr
-> Coercion -> Kind -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
res_bndr) Coercion
co Kind
cprCaseBndrMult DataCon
dc [Id]
arg_ids
(Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr))
-> (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$ if DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
nested_useful
then ( Bool
boringSplit, Id -> OrdList Id
forall a. a -> OrdList a
unitOL Id
res_bndr, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
res_bndr, CoreExpr -> CoreExpr
nop_fn )
else ( Bool
usefulSplit
, OrdList Id
transit_vars
, CoreExpr
rebuilt_result
, CoreExpr -> CoreExpr
this_work_unbox_res (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
work_unbox_res
)
move_transit_vars :: [Id] -> (CoreExpr -> CoreExpr -> CoreExpr, CoreExpr)
move_transit_vars :: [Id] -> (CoreExpr -> CoreExpr -> CoreExpr, CoreExpr)
move_transit_vars [Id]
vars
| [Id
var] <- [Id]
vars
, let var_ty :: Kind
var_ty = Id -> Kind
idType Id
var
, (() :: Constraint) => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
var_ty Bool -> Bool -> Bool
|| CoreExpr -> Bool
exprIsHNF (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var)
= ( \CoreExpr
build_res CoreExpr
wkr_call -> CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase CoreExpr
wkr_call Id
var CoreExpr
build_res
, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
var )
| Bool
otherwise
= ( \CoreExpr
build_res CoreExpr
wkr_call -> CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
wkr_call Id
case_bndr
(DataCon -> AltCon
DataAlt DataCon
tup_con) [Id]
vars CoreExpr
build_res
, CoreExpr
ubx_tup_app )
where
ubx_tup_app :: CoreExpr
ubx_tup_app = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr [Id]
vars)
tup_con :: DataCon
tup_con = Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
vars)
case_bndr :: Id
case_bndr = Kind -> Kind -> Id
mkWildValBinder Kind
cprCaseBndrMult ((() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
ubx_tup_app)
mkUnpackCase :: CoreExpr -> Coercion -> Mult -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase :: CoreExpr
-> Coercion -> Kind -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase (Tick CoreTickish
tickish CoreExpr
e) Coercion
co Kind
mult DataCon
con [Id]
args CoreExpr
body
= CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish (CoreExpr
-> Coercion -> Kind -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase CoreExpr
e Coercion
co Kind
mult DataCon
con [Id]
args CoreExpr
body)
mkUnpackCase CoreExpr
scrut Coercion
co Kind
mult 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 (() :: Constraint) => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion
co
bndr :: Id
bndr = Kind -> Kind -> Id
mkWildValBinder Kind
mult ((() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
casted_scrut)
cprCaseBndrMult :: Mult
cprCaseBndrMult :: Kind
cprCaseBndrMult = Kind
OneTy
ww_prefix :: FastString
ww_prefix :: FastString
ww_prefix = String -> FastString
fsLit String
"ww"