{-# LANGUAGE ViewPatterns #-}
module GHC.Core.Opt.WorkWrap.Utils
( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWorkerArgs
, DataConPatContext(..)
, UnboxingDecision(..), ArgOfInlineableFun(..), wantToUnboxArg
, findTypeShape
, isWorkerSmallEnough
)
where
import GHC.Prelude
import GHC.Core
import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase
, bindNonRec, dataConRepFSInstPat
, normSplitTyConApp_maybe, exprIsHNF )
import GHC.Types.Id
import GHC.Types.Id.Info ( JoinArity )
import GHC.Core.DataCon
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup, mkCoreApp, mkCoreLet
, mkWildValBinder )
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
import GHC.Builtin.Types ( tupleDataCon )
import GHC.Types.Literal ( mkLitRubbish )
import GHC.Types.Var.Env ( mkInScopeSet )
import GHC.Types.Var.Set ( VarSet )
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.Predicate ( isClassPred )
import GHC.Types.RepType ( isVoidTy, typeMonoPrimRep_maybe )
import GHC.Core.Coercion
import GHC.Core.FamInstEnv
import GHC.Types.Basic ( Boxity(..) )
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Types.Unique.Supply
import GHC.Types.Unique
import GHC.Types.Name ( getOccFS )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Data.FastString
import GHC.Data.OrdList
import GHC.Data.List.SetOps
import Control.Applicative ( (<|>) )
import Control.Monad ( zipWithM )
import Data.List ( unzip4 )
data WwOpts
= MkWwOpts
{ WwOpts -> FamInstEnvs
wo_fam_envs :: !FamInstEnvs
, WwOpts -> Bool
wo_cpr_anal :: !Bool
, WwOpts -> Bool
wo_fun_to_thunk :: !Bool
, WwOpts -> Int
wo_max_worker_args :: !Int
, WwOpts -> Maybe String
wo_output_file :: Maybe String
}
initWwOpts :: DynFlags -> FamInstEnvs -> WwOpts
initWwOpts :: DynFlags -> FamInstEnvs -> WwOpts
initWwOpts DynFlags
dflags FamInstEnvs
fam_envs = MkWwOpts :: FamInstEnvs -> Bool -> Bool -> Int -> Maybe String -> WwOpts
MkWwOpts
{ wo_fam_envs :: FamInstEnvs
wo_fam_envs = FamInstEnvs
fam_envs
, wo_cpr_anal :: Bool
wo_cpr_anal = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CprAnal DynFlags
dflags
, wo_fun_to_thunk :: Bool
wo_fun_to_thunk = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_FunToThunk DynFlags
dflags
, wo_max_worker_args :: Int
wo_max_worker_args = DynFlags -> Int
maxWorkerArgs DynFlags
dflags
, wo_output_file :: Maybe String
wo_output_file = DynFlags -> Maybe String
outputFile DynFlags
dflags
}
type WwResult
= ([Demand],
JoinArity,
Id -> CoreExpr,
CoreExpr -> CoreExpr)
nop_fn :: CoreExpr -> CoreExpr
nop_fn :: CoreExpr -> CoreExpr
nop_fn CoreExpr
body = CoreExpr
body
mkWwBodies :: WwOpts
-> VarSet
-> Id
-> [Demand]
-> Cpr
-> UniqSM (Maybe WwResult)
mkWwBodies :: WwOpts
-> VarSet -> Id -> [Demand] -> Cpr -> UniqSM (Maybe WwResult)
mkWwBodies WwOpts
opts VarSet
rhs_fvs Id
fun_id [Demand]
demands Cpr
cpr_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)
<- WwOpts
-> ArgOfInlineableFun
-> [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr WwOpts
opts ArgOfInlineableFun
inlineable_flag [Id]
wrap_args
; (Bool
useful2, CoreExpr -> CoreExpr
wrap_fn_cpr, CoreExpr -> CoreExpr
work_fn_cpr, Type
cpr_res_ty)
<- WwOpts
-> Type
-> Cpr
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWcpr_entry WwOpts
opts Type
res_ty Cpr
cpr_info
; let ([Id]
work_lam_args, [Id]
work_call_args) = Id -> Bool -> [Id] -> Type -> ([Id], [Id])
mkWorkerArgs Id
fun_id (WwOpts -> Bool
wo_fun_to_thunk WwOpts
opts)
[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 Int -> Int -> [Id] -> Bool
isWorkerSmallEnough (WwOpts -> Int
wo_max_worker_args WwOpts
opts) ([Demand] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Demand]
demands) [Id]
work_args
Bool -> Bool -> Bool
&& Bool -> Bool
not ([Id] -> 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
inlineable_flag :: ArgOfInlineableFun
inlineable_flag
| Unfolding -> Bool
isStableUnfolding (Id -> Unfolding
realIdUnfolding Id
fun_id) = ArgOfInlineableFun
MaybeArgOfInlineableFun
| Bool
otherwise = ArgOfInlineableFun
NotArgOfInlineableFun
only_one_void_argument :: Bool
only_one_void_argument
| [Demand
d] <- [Demand]
demands
, Just (Type
_, Type
arg_ty1, Type
_) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
fun_ty
, Demand -> 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 :: [Id] -> Bool
too_many_args_for_join_point [Id]
wrap_args
| Just Int
join_arity <- Maybe Int
mb_join_arity
, [Id]
wrap_args [Id] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
join_arity
= Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
warnPprTrace Bool
True (String -> SDoc
text String
"Unable to worker/wrapper join point with arity " SDoc -> SDoc -> SDoc
<+>
Int -> SDoc
int Int
join_arity SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"but" SDoc -> SDoc -> SDoc
<+>
Int -> SDoc
int ([Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
wrap_args) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"args") (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
Bool
True
| Bool
otherwise
= Bool
False
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
mkWorkerArgs :: Id
-> Bool
-> [Var]
-> Type
-> ([Var],
[Var])
mkWorkerArgs :: Id -> Bool -> [Id] -> Type -> ([Id], [Id])
mkWorkerArgs Id
wrap_id Bool
fun_to_thunk [Id]
args Type
res_ty
| Bool -> Bool
not (Id -> Bool
isJoinId Id
wrap_id)
, Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
isId [Id]
args)
, Bool
needs_a_value_lambda
= ([Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidArgId], [Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidPrimId])
| Bool
otherwise
= ([Id]
args, [Id]
args)
where
needs_a_value_lambda :: Bool
needs_a_value_lambda
= Bool -> Bool
not Bool
fun_to_thunk
Bool -> Bool -> Bool
|| Bool
might_be_unlifted
might_be_unlifted :: Bool
might_be_unlifted = case HasDebugCallStack => Type -> Maybe Bool
Type -> Maybe Bool
isLiftedType_maybe Type
res_ty of
Just Bool
lifted -> Bool -> Bool
not 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
nop_fn, CoreExpr -> CoreExpr
nop_fn, HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
fun_ty)
| (Demand
dmd:[Demand]
demands') <- [Demand]
demands
, Just (Type
mult, Type
arg_ty, Type
fun_ty') <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
fun_ty
= do { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let arg_ty' :: Scaled Type
arg_ty' = HasCallStack => TCvSubst -> Scaled Type -> Scaled Type
TCvSubst -> Scaled Type -> Scaled Type
substScaledTy TCvSubst
subst (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
mult Type
arg_ty)
id :: Id
id = Unique -> Scaled Type -> Demand -> Id
mk_wrap_arg Unique
uniq Scaled 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)
splitForAllTyCoVar_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
= Bool
-> SDoc
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall a. HasCallStack => Bool -> SDoc -> a -> a
warnPprTrace Bool
True (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun_ty) (UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type))
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall a b. (a -> b) -> a -> b
$
([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn, 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 -> Scaled Type -> Demand -> Id
mk_wrap_arg :: Unique -> Scaled Type -> Demand -> Id
mk_wrap_arg Unique
uniq (Scaled Type
w Type
ty) Demand
dmd
= FastString -> Unique -> Type -> Type -> Id
mkSysLocalOrCoVar (String -> FastString
fsLit String
"w") Unique
uniq Type
w Type
ty
Id -> Demand -> Id
`setIdDemandInfo` Demand
dmd
data DataConPatContext
= DataConPatContext
{ DataConPatContext -> DataCon
dcpc_dc :: !DataCon
, DataConPatContext -> [Type]
dcpc_tc_args :: ![Type]
, DataConPatContext -> Coercion
dcpc_co :: !Coercion
}
data UnboxingDecision s
= StopUnboxing
| DropAbsent
| Unbox !DataConPatContext [s]
data ArgOfInlineableFun
= NotArgOfInlineableFun
| MaybeArgOfInlineableFun
deriving ArgOfInlineableFun -> ArgOfInlineableFun -> Bool
(ArgOfInlineableFun -> ArgOfInlineableFun -> Bool)
-> (ArgOfInlineableFun -> ArgOfInlineableFun -> Bool)
-> Eq ArgOfInlineableFun
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArgOfInlineableFun -> ArgOfInlineableFun -> Bool
$c/= :: ArgOfInlineableFun -> ArgOfInlineableFun -> Bool
== :: ArgOfInlineableFun -> ArgOfInlineableFun -> Bool
$c== :: ArgOfInlineableFun -> ArgOfInlineableFun -> Bool
Eq
wantToUnboxArg :: FamInstEnvs -> ArgOfInlineableFun -> Type -> Demand -> UnboxingDecision Demand
wantToUnboxArg :: FamInstEnvs
-> ArgOfInlineableFun -> Type -> Demand -> UnboxingDecision Demand
wantToUnboxArg FamInstEnvs
fam_envs ArgOfInlineableFun
inlineable_flag Type
ty Demand
dmd
| Demand -> Bool
isAbsDmd Demand
dmd
= UnboxingDecision Demand
forall s. UnboxingDecision s
DropAbsent
| Demand -> Bool
isStrUsedDmd Demand
dmd
, Just (TyCon
tc, [Type]
tc_args, Coercion
co) <- FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)
normSplitTyConApp_maybe FamInstEnvs
fam_envs Type
ty
, Just DataCon
dc <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tc
, let arity :: Int
arity = DataCon -> Int
dataConRepArity DataCon
dc
, Just [Demand]
cs <- Demand -> Int -> Maybe [Demand]
split_prod_dmd_arity Demand
dmd Int
arity
, ArgOfInlineableFun
inlineable_flag ArgOfInlineableFun -> ArgOfInlineableFun -> Bool
forall a. Eq a => a -> a -> Bool
== ArgOfInlineableFun
NotArgOfInlineableFun Bool -> Bool -> Bool
|| Bool -> Bool
not (Type -> Bool
isClassPred Type
ty)
, [Demand]
cs [Demand] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
arity
, let cs' :: [Demand]
cs' = DataCon -> [Demand] -> [Demand]
addDataConStrictness DataCon
dc [Demand]
cs
= DataConPatContext -> [Demand] -> UnboxingDecision Demand
forall s. DataConPatContext -> [s] -> UnboxingDecision s
Unbox (DataCon -> [Type] -> Coercion -> DataConPatContext
DataConPatContext DataCon
dc [Type]
tc_args Coercion
co) [Demand]
cs'
| Bool
otherwise
= UnboxingDecision Demand
forall s. UnboxingDecision s
StopUnboxing
where
split_prod_dmd_arity :: Demand -> Int -> Maybe [Demand]
split_prod_dmd_arity Demand
dmd Int
arity
| Demand -> Bool
isSeqDmd Demand
dmd = [Demand] -> Maybe [Demand]
forall a. a -> Maybe a
Just (Int -> Demand -> [Demand]
forall a. Int -> a -> [a]
replicate Int
arity Demand
absDmd)
| Card
_ :* Prod [Demand]
ds <- Demand
dmd = [Demand] -> Maybe [Demand]
forall a. a -> Maybe a
Just [Demand]
ds
| Bool
otherwise = Maybe [Demand]
forall a. Maybe a
Nothing
addDataConStrictness :: DataCon -> [Demand] -> [Demand]
addDataConStrictness :: DataCon -> [Demand] -> [Demand]
addDataConStrictness DataCon
con [Demand]
ds
| Maybe Id
Nothing <- DataCon -> Maybe Id
dataConWrapId_maybe DataCon
con
= [Demand]
ds
addDataConStrictness DataCon
con [Demand]
ds
= String
-> (Demand -> StrictnessMark -> Demand)
-> [Demand]
-> [StrictnessMark]
-> [Demand]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"addDataConStrictness" 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
wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr
wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr
wantToUnboxResult FamInstEnvs
fam_envs Type
ty Cpr
cpr
| Just (Int
con_tag, [Cpr]
_cprs) <- Cpr -> Maybe (Int, [Cpr])
asConCpr Cpr
cpr
, Just (TyCon
tc, [Type]
tc_args, Coercion
co) <- FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)
normSplitTyConApp_maybe FamInstEnvs
fam_envs Type
ty
, TyCon -> Bool
isDataTyCon TyCon
tc
, Just [DataCon]
dcs <- TyCon -> Maybe [DataCon]
tyConAlgDataCons_maybe TyCon
tc Maybe [DataCon] -> Maybe [DataCon] -> Maybe [DataCon]
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 (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Id]
dataConExTyCoVars DataCon
dc)
, (Scaled Type -> Bool) -> [Scaled Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Scaled Type -> Bool
forall a. Scaled a -> Bool
isLinear (DataCon -> [Type] -> [Scaled Type]
dataConInstArgTys DataCon
dc [Type]
tc_args)
= DataConPatContext -> [Cpr] -> UnboxingDecision Cpr
forall s. DataConPatContext -> [s] -> UnboxingDecision s
Unbox (DataCon -> [Type] -> Coercion -> DataConPatContext
DataConPatContext DataCon
dc [Type]
tc_args Coercion
co) []
| Bool
otherwise
= UnboxingDecision Cpr
forall s. UnboxingDecision s
StopUnboxing
where
open_body_ty_warning :: Maybe [DataCon]
open_body_ty_warning = Bool -> SDoc -> Maybe [DataCon] -> Maybe [DataCon]
forall a. HasCallStack => Bool -> SDoc -> a -> a
warnPprTrace Bool
True (String -> SDoc
text String
"wantToUnboxResult: non-algebraic or open body type" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty) Maybe [DataCon]
forall a. Maybe a
Nothing
isLinear :: Scaled a -> Bool
isLinear :: Scaled a -> Bool
isLinear (Scaled Type
w a
_ ) =
case Type
w of
Type
One -> Bool
True
Type
_ -> Bool
False
mkWWstr :: WwOpts
-> ArgOfInlineableFun
-> [Var]
-> UniqSM (Bool,
[Var],
CoreExpr -> CoreExpr,
CoreExpr -> CoreExpr)
mkWWstr :: WwOpts
-> ArgOfInlineableFun
-> [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr WwOpts
opts ArgOfInlineableFun
inlineable_flag [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 = WwOpts
-> ArgOfInlineableFun
-> Id
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one WwOpts
opts ArgOfInlineableFun
inlineable_flag 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 :: WwOpts
-> ArgOfInlineableFun
-> Var
-> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one :: WwOpts
-> ArgOfInlineableFun
-> Id
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one WwOpts
opts ArgOfInlineableFun
inlineable_flag Id
arg =
case FamInstEnvs
-> ArgOfInlineableFun -> Type -> Demand -> UnboxingDecision Demand
wantToUnboxArg FamInstEnvs
fam_envs ArgOfInlineableFun
inlineable_flag Type
arg_ty Demand
arg_dmd of
UnboxingDecision Demand
_ | Id -> Bool
isTyVar Id
arg -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
do_nothing
UnboxingDecision Demand
DropAbsent
| Just CoreExpr -> CoreExpr
work_fn <- WwOpts -> Id -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let WwOpts
opts 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)
Unbox DataConPatContext
dcpc [Demand]
cs -> WwOpts
-> Id
-> [Demand]
-> DataConPatContext
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
unbox_one_arg WwOpts
opts Id
arg [Demand]
cs DataConPatContext
dcpc
UnboxingDecision Demand
_ -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
do_nothing
where
fam_envs :: FamInstEnvs
fam_envs = WwOpts -> FamInstEnvs
wo_fam_envs WwOpts
opts
arg_ty :: Type
arg_ty = Id -> Type
idType Id
arg
arg_dmd :: Demand
arg_dmd = Id -> Demand
idDemandInfo Id
arg
do_nothing :: UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
do_nothing = (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)
unbox_one_arg :: WwOpts
-> Var
-> [Demand]
-> DataConPatContext
-> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
unbox_one_arg :: WwOpts
-> Id
-> [Demand]
-> DataConPatContext
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
unbox_one_arg WwOpts
opts Id
arg [Demand]
cs
DataConPatContext { dcpc_dc :: DataConPatContext -> DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: DataConPatContext -> [Type]
dcpc_tc_args = [Type]
tc_args
, dcpc_co :: DataConPatContext -> Coercion
dcpc_co = Coercion
co }
= 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] -> Type -> DataCon -> [Type] -> ([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 -> Type
idMult Id
arg) DataCon
dc [Type]
tc_args
arg_ids' :: [Id]
arg_ids' = String -> (Id -> Demand -> Id) -> [Id] -> [Demand] -> [Id]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"unbox_one_arg" Id -> Demand -> Id
setIdDemandInfo [Id]
arg_ids [Demand]
cs
unbox_fn :: CoreExpr -> CoreExpr
unbox_fn = CoreExpr
-> Coercion -> Type -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arg) Coercion
co (Id -> Type
idMult Id
arg)
DataCon
dc ([Id]
ex_tvs' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
arg_ids')
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
dc [Type]
tc_args ([Id]
ex_tvs' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
arg_ids') CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co
; (Bool
_, [Id]
worker_args, CoreExpr -> CoreExpr
wrap_fn, CoreExpr -> CoreExpr
work_fn) <- WwOpts
-> ArgOfInlineableFun
-> [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr WwOpts
opts ArgOfInlineableFun
NotArgOfInlineableFun ([Id]
ex_tvs' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
arg_ids')
; (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) }
mk_absent_let :: WwOpts -> Id -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let :: WwOpts -> Id -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let WwOpts
opts Id
arg
| Just [PrimRep
LiftedRep] <- Maybe [PrimRep]
mb_mono_prim_reps
, Bool -> Bool
not (Demand -> Bool
isStrictDmd (Id -> Demand
idDemandInfo Id
arg))
= (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
panic_rhs))
| Just [PrimRep]
prim_reps <- Maybe [PrimRep]
mb_mono_prim_reps
= (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
forall a. a -> Maybe a
Just (Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
arg (CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
mkTyApps (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit ([PrimRep] -> Literal
mkLitRubbish [PrimRep]
prim_reps)) [Type
arg_ty]))
| Maybe [PrimRep]
Nothing <- Maybe [PrimRep]
mb_mono_prim_reps
= Bool
-> SDoc
-> Maybe (CoreExpr -> CoreExpr)
-> Maybe (CoreExpr -> CoreExpr)
forall a. HasCallStack => Bool -> SDoc -> a -> a
warnPprTrace Bool
True (String -> SDoc
text String
"No absent value for" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty) (Maybe (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr))
-> Maybe (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$
Maybe (CoreExpr -> CoreExpr)
forall a. Maybe a
Nothing
where
arg_ty :: Type
arg_ty = Id -> Type
idType Id
arg
mb_mono_prim_reps :: Maybe [PrimRep]
mb_mono_prim_reps = Type -> Maybe [PrimRep]
typeMonoPrimRep_maybe Type
arg_ty
panic_rhs :: CoreExpr
panic_rhs = Type -> String -> CoreExpr
mkAbsentErrorApp Type
arg_ty String
msg
msg :: String
msg = SDocContext -> SDoc -> String
renderWithContext
(SDocContext
defaultSDocContext { sdocSuppressUniques :: Bool
sdocSuppressUniques = Bool
True })
([SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"Arg:" SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
arg
, String -> SDoc
text String
"Type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty
, SDoc
file_msg ])
file_msg :: SDoc
file_msg = case WwOpts -> Maybe String
wo_output_file WwOpts
opts of
Maybe String
Nothing -> SDoc
empty
Just String
f -> String -> SDoc
text String
"In output file " SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
f)
findTypeShape :: FamInstEnvs -> Type -> TypeShape
findTypeShape :: FamInstEnvs -> Type -> TypeShape
findTypeShape FamInstEnvs
fam_envs Type
ty
= RecTcChecker -> Type -> TypeShape
go (Int -> RecTcChecker -> RecTcChecker
setRecTcMaxBound Int
2 RecTcChecker
initRecTc) Type
ty
where
go :: RecTcChecker -> Type -> TypeShape
go RecTcChecker
rec_tc Type
ty
| Just (Type
_, Type
_, Type
res) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
ty
= TypeShape -> TypeShape
TsFun (RecTcChecker -> Type -> TypeShape
go RecTcChecker
rec_tc Type
res)
| Just (TyCon
tc, [Type]
tc_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
= RecTcChecker -> TyCon -> [Type] -> TypeShape
go_tc RecTcChecker
rec_tc TyCon
tc [Type]
tc_args
| Just (Id
_, Type
ty') <- Type -> Maybe (Id, Type)
splitForAllTyCoVar_maybe Type
ty
= RecTcChecker -> Type -> TypeShape
go RecTcChecker
rec_tc Type
ty'
| Bool
otherwise
= TypeShape
TsUnk
go_tc :: RecTcChecker -> TyCon -> [Type] -> TypeShape
go_tc RecTcChecker
rec_tc TyCon
tc [Type]
tc_args
| Just (Coercion
_, Type
rhs, MCoercion
_) <- FamInstEnvs -> TyCon -> [Type] -> Maybe (Coercion, Type, MCoercion)
topReduceTyFamApp_maybe FamInstEnvs
fam_envs TyCon
tc [Type]
tc_args
= RecTcChecker -> Type -> TypeShape
go RecTcChecker
rec_tc Type
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 ((Type -> TypeShape) -> [Type] -> [TypeShape]
forall a b. (a -> b) -> [a] -> [b]
map (RecTcChecker -> Type -> TypeShape
go RecTcChecker
rec_tc) (DataCon -> [Type] -> [Type]
dubiousDataConInstArgTys DataCon
con [Type]
tc_args))
| Just (Type
ty', Coercion
_) <- TyCon -> [Type] -> Maybe (Type, Coercion)
instNewTyCon_maybe TyCon
tc [Type]
tc_args
, Just RecTcChecker
rec_tc <- RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec_tc TyCon
tc
= RecTcChecker -> Type -> TypeShape
go RecTcChecker
rec_tc Type
ty'
| Bool
otherwise
= TypeShape
TsUnk
dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]
dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]
dubiousDataConInstArgTys DataCon
dc [Type]
tc_args = [Type]
arg_tys
where
univ_tvs :: [Id]
univ_tvs = DataCon -> [Id]
dataConUnivTyVars DataCon
dc
ex_tvs :: [Id]
ex_tvs = DataCon -> [Id]
dataConExTyCoVars DataCon
dc
subst :: TCvSubst
subst = TCvSubst -> [Id] -> TCvSubst
extendTCvInScopeList ([Id] -> [Type] -> TCvSubst
HasDebugCallStack => [Id] -> [Type] -> TCvSubst
zipTvSubst [Id]
univ_tvs [Type]
tc_args) [Id]
ex_tvs
arg_tys :: [Type]
arg_tys = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst (Type -> Type) -> (Scaled Type -> Type) -> Scaled Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scaled Type -> Type
forall a. Scaled a -> a
scaledThing) (DataCon -> [Scaled Type]
dataConRepArgTys DataCon
dc)
mkWWcpr_entry
:: WwOpts
-> Type
-> Cpr
-> UniqSM (Bool,
CoreExpr -> CoreExpr,
CoreExpr -> CoreExpr,
Type)
mkWWcpr_entry :: WwOpts
-> Type
-> Cpr
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
mkWWcpr_entry WwOpts
opts Type
body_ty Cpr
body_cpr
| Bool -> Bool
not (WwOpts -> Bool
wo_cpr_anal WwOpts
opts) = (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
nop_fn, CoreExpr -> CoreExpr
nop_fn, Type
body_ty)
| Bool
otherwise = do
Id
res_bndr <- Type -> UniqSM Id
mk_res_bndr Type
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
deref_res_bndr :: CoreExpr
deref_res_bndr = Id -> CoreExpr
forall b. Id -> Expr b
Var Id
res_bndr
(Bool
useful, OrdList Id -> [Id]
forall a. OrdList a -> [a]
fromOL -> [Id]
transit_vars, CoreExpr -> CoreExpr
wrap_build_res, CoreExpr -> CoreExpr
work_unpack_res) <-
WwOpts
-> Id
-> Cpr
-> UniqSM
(Bool, OrdList Id, CoreExpr -> 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 -> CoreExpr
wrap_build_res CoreExpr
deref_res_bndr)
work_fn :: CoreExpr -> CoreExpr
work_fn CoreExpr
body = CoreExpr -> CoreExpr -> CoreExpr
bind_res_bndr CoreExpr
body (CoreExpr -> CoreExpr
work_unpack_res CoreExpr
transit_tup)
work_body_ty :: Type
work_body_ty = CoreExpr -> Type
exprType CoreExpr
transit_tup
(Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type))
-> (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
forall a b. (a -> b) -> a -> b
$ if Bool -> Bool
not Bool
useful
then (Bool
False, CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn, Type
body_ty)
else (Bool
True, CoreExpr -> CoreExpr
wrap_fn, CoreExpr -> CoreExpr
work_fn, Type
work_body_ty)
mk_res_bndr :: Type -> UniqSM Id
mk_res_bndr :: Type -> UniqSM Id
mk_res_bndr Type
body_ty = do
Id
bndr <- FastString -> Type -> Type -> UniqSM Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m Id
mkSysLocalOrCoVarM FastString
ww_prefix Type
cprCaseBndrMult Type
body_ty
Id -> UniqSM Id
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StrictnessMark -> Id -> Id
setCaseBndrEvald StrictnessMark
MarkedStrict Id
bndr)
type CprWwResult = (Bool, OrdList Var, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResult
mkWWcpr :: WwOpts
-> [Id]
-> [Cpr]
-> UniqSM
(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWcpr WwOpts
_opts [Id]
vars [] =
(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM
(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [Id] -> OrdList Id
forall a. [a] -> OrdList a
toOL [Id]
vars, CoreExpr -> CoreExpr
nop_fn, 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
$$ [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
$$ [Cpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Cpr]
cprs)
([Bool]
usefuls, [OrdList Id]
varss, [CoreExpr -> CoreExpr]
wrap_build_ress, [CoreExpr -> CoreExpr]
work_unpack_ress) <-
[(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)]
-> ([Bool], [OrdList Id], [CoreExpr -> CoreExpr],
[CoreExpr -> CoreExpr])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)]
-> ([Bool], [OrdList Id], [CoreExpr -> CoreExpr],
[CoreExpr -> CoreExpr]))
-> UniqSM
[(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)]
-> UniqSM
([Bool], [OrdList Id], [CoreExpr -> CoreExpr],
[CoreExpr -> CoreExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id
-> Cpr
-> UniqSM
(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr))
-> [Id]
-> [Cpr]
-> UniqSM
[(Bool, OrdList Id, CoreExpr -> 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 -> CoreExpr)
mkWWcpr_one WwOpts
opts) [Id]
vars [Cpr]
cprs
(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM
(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
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 -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr)
-> [CoreExpr -> CoreExpr]
-> CoreExpr
-> CoreExpr
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]
wrap_build_ress
, ((CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr)
-> [CoreExpr -> CoreExpr]
-> CoreExpr
-> CoreExpr
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 CprWwResult
mkWWcpr_one :: WwOpts
-> Id
-> Cpr
-> UniqSM
(Bool, OrdList Id, CoreExpr -> 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
, Unbox DataConPatContext
dcpc [Cpr]
arg_cprs <- FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr
wantToUnboxResult (WwOpts -> FamInstEnvs
wo_fam_envs WwOpts
opts) (Id -> Type
idType Id
res_bndr) Cpr
cpr
= WwOpts
-> Id
-> [Cpr]
-> DataConPatContext
-> UniqSM
(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
unbox_one_result WwOpts
opts Id
res_bndr [Cpr]
arg_cprs DataConPatContext
dcpc
| Bool
otherwise
= (Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM
(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Id -> OrdList Id
forall a. a -> OrdList a
unitOL Id
res_bndr, CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn)
unbox_one_result
:: WwOpts -> Id -> [Cpr] -> DataConPatContext -> UniqSM CprWwResult
unbox_one_result :: WwOpts
-> Id
-> [Cpr]
-> DataConPatContext
-> UniqSM
(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
unbox_one_result WwOpts
opts Id
res_bndr [Cpr]
arg_cprs
DataConPatContext { dcpc_dc :: DataConPatContext -> DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: DataConPatContext -> [Type]
dcpc_tc_args = [Type]
tc_args
, dcpc_co :: DataConPatContext -> Coercion
dcpc_co = Coercion
co } = do
[Unique]
pat_bndrs_uniqs <- UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
let ([Id]
_exs, [Id]
arg_ids) =
[FastString]
-> [Unique] -> Type -> DataCon -> [Type] -> ([Id], [Id])
dataConRepFSInstPat (FastString -> [FastString]
forall a. a -> [a]
repeat FastString
ww_prefix) [Unique]
pat_bndrs_uniqs Type
cprCaseBndrMult DataCon
dc [Type]
tc_args
Bool -> UniqSM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
_exs)
let
con_app :: CoreExpr
con_app = DataCon -> [Type] -> [Id] -> CoreExpr
forall b. DataCon -> [Type] -> [Id] -> Expr b
mkConApp2 DataCon
dc [Type]
tc_args [Id]
arg_ids CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co
this_wrap_build_res :: CoreExpr -> CoreExpr
this_wrap_build_res = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
res_bndr CoreExpr
con_app)
this_work_unbox_res :: CoreExpr -> CoreExpr
this_work_unbox_res = CoreExpr
-> Coercion -> Type -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
res_bndr) Coercion
co Type
cprCaseBndrMult DataCon
dc [Id]
arg_ids
(Bool
nested_useful, OrdList Id
transit_vars, CoreExpr -> CoreExpr
wrap_build_res, CoreExpr -> CoreExpr
work_unbox_res) <-
WwOpts
-> [Id]
-> [Cpr]
-> UniqSM
(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWcpr WwOpts
opts [Id]
arg_ids [Cpr]
arg_cprs
(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM
(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM
(Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr))
-> (Bool, OrdList Id, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM
(Bool, OrdList Id, CoreExpr -> 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
False, Id -> OrdList Id
forall a. a -> OrdList a
unitOL Id
res_bndr, CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn )
else ( Bool
True
, OrdList Id
transit_vars
, CoreExpr -> CoreExpr
wrap_build_res (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
this_wrap_build_res
, 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 :: Type
var_ty = Id -> Type
idType Id
var
, HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
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 = [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup ((Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
vars) ((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 (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
vars)
case_bndr :: Id
case_bndr = Type -> Type -> Id
mkWildValBinder Type
cprCaseBndrMult (CoreExpr -> Type
exprType CoreExpr
ubx_tup_app)
mkUnpackCase :: CoreExpr -> Coercion -> Mult -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase :: CoreExpr
-> Coercion -> Type -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase (Tick CoreTickish
tickish CoreExpr
e) Coercion
co Type
mult DataCon
con [Id]
args CoreExpr
body
= CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish (CoreExpr
-> Coercion -> Type -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase CoreExpr
e Coercion
co Type
mult DataCon
con [Id]
args CoreExpr
body)
mkUnpackCase CoreExpr
scrut Coercion
co Type
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 CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion
co
bndr :: Id
bndr = Type -> Type -> Id
mkWildValBinder Type
mult (CoreExpr -> Type
exprType CoreExpr
casted_scrut)
cprCaseBndrMult :: Mult
cprCaseBndrMult :: Type
cprCaseBndrMult = Type
One
ww_prefix :: FastString
ww_prefix :: FastString
ww_prefix = String -> FastString
fsLit String
"ww"