{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
module GHC.Stg.Unarise (unarise) where
import GHC.Prelude
import GHC.Types.Basic
import GHC.Core
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Data.FastString (FastString, mkFastString, fsLit)
import GHC.Types.Id
import GHC.Types.Literal
import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID)
import GHC.Types.Id.Make (voidPrimId, voidArgId)
import GHC.Utils.Monad (mapAccumLM)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Types.RepType
import GHC.Stg.Syntax
import GHC.Stg.Utils
import GHC.Core.Type
import GHC.Builtin.Types.Prim (intPrimTy)
import GHC.Builtin.Types
import GHC.Types.Unique.Supply
import GHC.Types.Unique
import GHC.Utils.Misc
import GHC.Types.Var.Env
import Data.Bifunctor (second)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (mapMaybe)
import qualified Data.IntMap as IM
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Casts
import Data.List (mapAccumL)
newtype UnariseEnv = UnariseEnv { UnariseEnv -> VarEnv UnariseVal
ue_rho :: (VarEnv UnariseVal) }
initUnariseEnv :: VarEnv UnariseVal -> UnariseEnv
initUnariseEnv :: VarEnv UnariseVal -> UnariseEnv
initUnariseEnv = VarEnv UnariseVal -> UnariseEnv
UnariseEnv
data UnariseVal
= MultiVal [OutStgArg]
| UnaryVal OutStgArg
instance Outputable UnariseVal where
ppr :: UnariseVal -> SDoc
ppr (MultiVal [StgArg]
args) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MultiVal" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args
ppr (UnaryVal StgArg
arg) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UnaryVal" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> StgArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr StgArg
arg
extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
env Id
x (MultiVal [StgArg]
args)
= Bool -> UnariseEnv -> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert ((StgArg -> Bool) -> [StgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Type -> Bool
isNvUnaryType (Type -> Bool) -> (StgArg -> Type) -> StgArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> Type
stgArgType) [StgArg]
args)
UnariseEnv
env { ue_rho = extendVarEnv (ue_rho env) x (MultiVal args) }
extendRho UnariseEnv
env Id
x (UnaryVal StgArg
val)
= Bool -> UnariseEnv -> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert (Type -> Bool
isNvUnaryType (StgArg -> Type
stgArgType StgArg
val))
UnariseEnv
env { ue_rho = extendVarEnv (ue_rho env) x (UnaryVal val) }
extendRhoWithoutValue :: UnariseEnv -> Id -> UnariseEnv
extendRhoWithoutValue :: UnariseEnv -> Id -> UnariseEnv
extendRhoWithoutValue UnariseEnv
env Id
x = UnariseEnv
env { ue_rho = delVarEnv (ue_rho env) x }
lookupRho :: UnariseEnv -> Id -> Maybe UnariseVal
lookupRho :: UnariseEnv -> Id -> Maybe UnariseVal
lookupRho UnariseEnv
env Id
v = VarEnv UnariseVal -> Id -> Maybe UnariseVal
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (UnariseEnv -> VarEnv UnariseVal
ue_rho UnariseEnv
env) Id
v
unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
unarise UniqSupply
us [StgTopBinding]
binds = UniqSupply -> UniqSM [StgTopBinding] -> [StgTopBinding]
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us ((StgTopBinding -> UniqSM StgTopBinding)
-> [StgTopBinding] -> UniqSM [StgTopBinding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
unariseTopBinding (VarEnv UnariseVal -> UnariseEnv
initUnariseEnv VarEnv UnariseVal
forall a. VarEnv a
emptyVarEnv)) [StgTopBinding]
binds)
unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
unariseTopBinding UnariseEnv
rho (StgTopLifted GenStgBinding 'Vanilla
bind)
= GenStgBinding 'Vanilla -> StgTopBinding
forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted (GenStgBinding 'Vanilla -> StgTopBinding)
-> UniqSM (GenStgBinding 'Vanilla) -> UniqSM StgTopBinding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv
-> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho GenStgBinding 'Vanilla
bind
unariseTopBinding UnariseEnv
_ bind :: StgTopBinding
bind@StgTopStringLit{} = StgTopBinding -> UniqSM StgTopBinding
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return StgTopBinding
bind
unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
unariseBinding :: UnariseEnv
-> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho (StgNonRec BinderP 'Vanilla
x GenStgRhs 'Vanilla
rhs)
= BinderP 'Vanilla -> GenStgRhs 'Vanilla -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec BinderP 'Vanilla
x (GenStgRhs 'Vanilla -> GenStgBinding 'Vanilla)
-> UniqSM (GenStgRhs 'Vanilla) -> UniqSM (GenStgBinding 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv -> GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
unariseRhs UnariseEnv
rho GenStgRhs 'Vanilla
rhs
unariseBinding UnariseEnv
rho (StgRec [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
xrhss)
= [(Id, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla
[(BinderP 'Vanilla, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec ([(Id, GenStgRhs 'Vanilla)] -> GenStgBinding 'Vanilla)
-> UniqSM [(Id, GenStgRhs 'Vanilla)]
-> UniqSM (GenStgBinding 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Id, GenStgRhs 'Vanilla) -> UniqSM (Id, GenStgRhs 'Vanilla))
-> [(Id, GenStgRhs 'Vanilla)] -> UniqSM [(Id, GenStgRhs 'Vanilla)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Id
x, GenStgRhs 'Vanilla
rhs) -> (Id
x,) (GenStgRhs 'Vanilla -> (Id, GenStgRhs 'Vanilla))
-> UniqSM (GenStgRhs 'Vanilla) -> UniqSM (Id, GenStgRhs 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv -> GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
unariseRhs UnariseEnv
rho GenStgRhs 'Vanilla
rhs) [(Id, GenStgRhs 'Vanilla)]
[(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
xrhss
unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
unariseRhs :: UnariseEnv -> GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
unariseRhs UnariseEnv
rho (StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
ccs UpdateFlag
update_flag [BinderP 'Vanilla]
args GenStgExpr 'Vanilla
expr)
= do (UnariseEnv
rho', [Id]
args1) <- UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinders UnariseEnv
rho [Id]
[BinderP 'Vanilla]
args
GenStgExpr 'Vanilla
expr' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho' GenStgExpr 'Vanilla
expr
GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
ccs UpdateFlag
update_flag [Id]
[BinderP 'Vanilla]
args1 GenStgExpr 'Vanilla
expr')
unariseRhs UnariseEnv
rho (StgRhsCon CostCentreStack
ccs DataCon
con ConstructorNumber
mu [StgTickish]
ts [StgArg]
args)
= Bool
-> (GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla))
-> GenStgRhs 'Vanilla
-> UniqSM (GenStgRhs 'Vanilla)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (DataCon -> Bool
isUnboxedTupleDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con))
GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs 'Vanilla
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs pass
StgRhsCon CostCentreStack
ccs DataCon
con ConstructorNumber
mu [StgTickish]
ts (UnariseEnv -> [StgArg] -> [StgArg]
unariseConArgs UnariseEnv
rho [StgArg]
args))
unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr
unariseExpr :: UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho e :: GenStgExpr 'Vanilla
e@(StgApp Id
f [])
= case UnariseEnv -> Id -> Maybe UnariseVal
lookupRho UnariseEnv
rho Id
f of
Just (MultiVal [StgArg]
args)
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([StgArg] -> GenStgExpr 'Vanilla
mkTuple [StgArg]
args)
Just (UnaryVal (StgVarArg Id
f'))
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
f' [])
Just (UnaryVal (StgLitArg Literal
f'))
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
f')
Maybe UnariseVal
Nothing
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return GenStgExpr 'Vanilla
e
unariseExpr UnariseEnv
rho e :: GenStgExpr 'Vanilla
e@(StgApp Id
f [StgArg]
args)
= GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
f' (UnariseEnv -> [StgArg] -> [StgArg]
unariseFunArgs UnariseEnv
rho [StgArg]
args))
where
f' :: Id
f' = case UnariseEnv -> Id -> Maybe UnariseVal
lookupRho UnariseEnv
rho Id
f of
Just (UnaryVal (StgVarArg Id
f')) -> Id
f'
Maybe UnariseVal
Nothing -> Id
f
Maybe UnariseVal
err -> String -> SDoc -> Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseExpr - app2" (StgPprOpts -> GenStgExpr 'Vanilla -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts GenStgExpr 'Vanilla
e SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Maybe UnariseVal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe UnariseVal
err)
unariseExpr UnariseEnv
_ (StgLit Literal
l)
= GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
l)
unariseExpr UnariseEnv
rho (StgConApp DataCon
dc ConstructorNumber
n [StgArg]
args [Type]
ty_args)
| DataCon -> Bool
isUnboxedSumDataCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc
= do
UniqSupply
us <- UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
case UnariseEnv
-> UniqSupply
-> DataCon
-> [StgArg]
-> [Type]
-> ([StgArg], Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla))
unariseUbxSumOrTupleArgs UnariseEnv
rho UniqSupply
us DataCon
dc [StgArg]
args [Type]
ty_args of
([StgArg]
args', Just GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
cast_wrapper)
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla))
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
cast_wrapper ([StgArg] -> GenStgExpr 'Vanilla
mkTuple [StgArg]
args')
([StgArg]
args', Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
Nothing)
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla))
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ ([StgArg] -> GenStgExpr 'Vanilla
mkTuple [StgArg]
args')
| Bool
otherwise =
let args' :: [StgArg]
args' = UnariseEnv -> [StgArg] -> [StgArg]
unariseConArgs UnariseEnv
rho [StgArg]
args in
GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla))
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ (DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
n [StgArg]
args' ((StgArg -> Type) -> [StgArg] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> Type
stgArgType [StgArg]
args'))
unariseExpr UnariseEnv
rho (StgOpApp StgOp
op [StgArg]
args Type
ty)
= GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (StgOp -> [StgArg] -> Type -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp StgOp
op (UnariseEnv -> [StgArg] -> [StgArg]
unariseFunArgs UnariseEnv
rho [StgArg]
args) Type
ty)
unariseExpr UnariseEnv
rho (StgCase GenStgExpr 'Vanilla
scrut BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts)
| StgApp Id
v [] <- GenStgExpr 'Vanilla
scrut
, Just (MultiVal [StgArg]
xs) <- UnariseEnv -> Id -> Maybe UnariseVal
lookupRho UnariseEnv
rho Id
v
= UnariseEnv
-> [StgArg]
-> Id
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [StgArg]
xs Id
BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts
| StgConApp DataCon
dc ConstructorNumber
_n [StgArg]
args [Type]
ty_args <- GenStgExpr 'Vanilla
scrut
, DataCon -> Bool
isUnboxedSumDataCon DataCon
dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc
= do
UniqSupply
us <- UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
case UnariseEnv
-> UniqSupply
-> DataCon
-> [StgArg]
-> [Type]
-> ([StgArg], Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla))
unariseUbxSumOrTupleArgs UnariseEnv
rho UniqSupply
us DataCon
dc [StgArg]
args [Type]
ty_args of
([StgArg]
args',Just GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper) -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv
-> [StgArg]
-> Id
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [StgArg]
args' Id
BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts
([StgArg]
args',Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
Nothing) -> UnariseEnv
-> [StgArg]
-> Id
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [StgArg]
args' Id
BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts
| StgLit Literal
lit <- GenStgExpr 'Vanilla
scrut
, Just [StgArg]
args' <- Literal -> Maybe [StgArg]
unariseLiteral_maybe Literal
lit
= UnariseEnv
-> [StgArg]
-> Id
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [StgArg]
args' Id
BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts
| Bool
otherwise
= do GenStgExpr 'Vanilla
scrut' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho GenStgExpr 'Vanilla
scrut
[GenStgAlt 'Vanilla]
alts' <- UnariseEnv
-> AltType
-> Id
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseAlts UnariseEnv
rho AltType
alt_ty Id
BinderP 'Vanilla
bndr [GenStgAlt 'Vanilla]
alts
GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStgExpr 'Vanilla
-> BinderP 'Vanilla
-> AltType
-> [GenStgAlt 'Vanilla]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase GenStgExpr 'Vanilla
scrut' BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts')
unariseExpr UnariseEnv
rho (StgLet XLet 'Vanilla
ext GenStgBinding 'Vanilla
bind GenStgExpr 'Vanilla
e)
= XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
ext (GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> UniqSM (GenStgBinding 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv
-> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho GenStgBinding 'Vanilla
bind UniqSM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgExpr 'Vanilla)
forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho GenStgExpr 'Vanilla
e
unariseExpr UnariseEnv
rho (StgLetNoEscape XLetNoEscape 'Vanilla
ext GenStgBinding 'Vanilla
bind GenStgExpr 'Vanilla
e)
= XLetNoEscape 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape 'Vanilla
ext (GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> UniqSM (GenStgBinding 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv
-> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho GenStgBinding 'Vanilla
bind UniqSM (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgExpr 'Vanilla)
forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho GenStgExpr 'Vanilla
e
unariseExpr UnariseEnv
rho (StgTick StgTickish
tick GenStgExpr 'Vanilla
e)
= StgTickish -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
tick (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgExpr 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho GenStgExpr 'Vanilla
e
unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [Type]
-> ( [OutStgArg]
, Maybe (StgExpr -> StgExpr))
unariseUbxSumOrTupleArgs :: UnariseEnv
-> UniqSupply
-> DataCon
-> [StgArg]
-> [Type]
-> ([StgArg], Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla))
unariseUbxSumOrTupleArgs UnariseEnv
rho UniqSupply
us DataCon
dc [StgArg]
args [Type]
ty_args
| DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc
= (UnariseEnv -> [StgArg] -> [StgArg]
unariseConArgs UnariseEnv
rho [StgArg]
args, Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall a. Maybe a
Nothing)
| DataCon -> Bool
isUnboxedSumDataCon DataCon
dc
, let args1 :: [StgArg]
args1 = Bool -> [StgArg] -> [StgArg]
forall a. HasCallStack => Bool -> a -> a
assert ([StgArg] -> Bool
forall a. [a] -> Bool
isSingleton [StgArg]
args) (UnariseEnv -> [StgArg] -> [StgArg]
unariseConArgs UnariseEnv
rho [StgArg]
args)
= let ([StgArg]
args2, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
cast_wrapper) = (() :: Constraint) =>
DataCon
-> [Type]
-> [StgArg]
-> UniqSupply
-> ([StgArg], GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
DataCon
-> [Type]
-> [StgArg]
-> UniqSupply
-> ([StgArg], GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
mkUbxSum DataCon
dc [Type]
ty_args [StgArg]
args1 UniqSupply
us
in ([StgArg]
args2, (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall a. a -> Maybe a
Just GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
cast_wrapper)
| Bool
otherwise
= String
-> ([StgArg], Maybe (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla))
forall a. HasCallStack => String -> a
panic String
"unariseUbxSumOrTupleArgs: Constructor not a unboxed sum or tuple"
unariseLiteral_maybe :: Literal -> Maybe [OutStgArg]
unariseLiteral_maybe :: Literal -> Maybe [StgArg]
unariseLiteral_maybe (LitRubbish TypeOrConstraint
torc Type
rep)
| [PrimRep
prep] <- [PrimRep]
preps
, Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (PrimRep -> Bool
isVoidRep PrimRep
prep)) Bool
True
= Maybe [StgArg]
forall a. Maybe a
Nothing
| Bool
otherwise
= [StgArg] -> Maybe [StgArg]
forall a. a -> Maybe a
Just [ Literal -> StgArg
StgLitArg (TypeOrConstraint -> Type -> Literal
LitRubbish TypeOrConstraint
torc (PrimRep -> Type
primRepToRuntimeRep PrimRep
prep))
| PrimRep
prep <- [PrimRep]
preps, Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (PrimRep -> Bool
isVoidRep PrimRep
prep)) Bool
True ]
where
preps :: [PrimRep]
preps = (() :: Constraint) => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
runtimeRepPrimRep (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unariseLiteral_maybe") Type
rep
unariseLiteral_maybe Literal
_ = Maybe [StgArg]
forall a. Maybe a
Nothing
elimCase :: UnariseEnv
-> [OutStgArg]
-> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
elimCase :: UnariseEnv
-> [StgArg]
-> Id
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [StgArg]
args Id
bndr (MultiValAlt Int
_) [GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con = AltCon
_
, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP 'Vanilla]
bndrs
, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs = GenStgExpr 'Vanilla
rhs}]
= do let rho1 :: UnariseEnv
rho1 = UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
bndr ([StgArg] -> UnariseVal
MultiVal [StgArg]
args)
(UnariseEnv
rho2, GenStgExpr 'Vanilla
rhs') <- case () of
()
_
| Id -> Bool
isUnboxedTupleBndr Id
bndr
-> (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id] -> [StgArg] -> UnariseEnv -> UnariseEnv
mapTupleIdBinders [Id]
[BinderP 'Vanilla]
bndrs [StgArg]
args UnariseEnv
rho1, GenStgExpr 'Vanilla
rhs)
| Bool
otherwise
-> Bool
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. HasCallStack => Bool -> a -> a
assert (Id -> Bool
isUnboxedSumBndr Id
bndr) (UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla))
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$
case [BinderP 'Vanilla]
bndrs of
[] -> (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv
rho1, GenStgExpr 'Vanilla
rhs)
[BinderP 'Vanilla
alt_bndr] -> Id
-> [StgArg]
-> GenStgExpr 'Vanilla
-> UnariseEnv
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
mapSumIdBinders Id
BinderP 'Vanilla
alt_bndr [StgArg]
args GenStgExpr 'Vanilla
rhs UnariseEnv
rho1
[BinderP 'Vanilla]
_ -> String -> SDoc -> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mapSumIdBinders" ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
[BinderP 'Vanilla]
bndrs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args)
UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho2 GenStgExpr 'Vanilla
rhs'
elimCase UnariseEnv
rho args :: [StgArg]
args@(StgArg
tag_arg : [StgArg]
real_args) Id
bndr (MultiValAlt Int
_) [GenStgAlt 'Vanilla]
alts
| Id -> Bool
isUnboxedSumBndr Id
bndr
= do Id
tag_bndr <- FastString -> Type -> UniqSM Id
mkId (String -> FastString
mkFastString String
"tag") Type
tagTy
let rho1 :: UnariseEnv
rho1 = UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
bndr ([StgArg] -> UnariseVal
MultiVal [StgArg]
args)
scrut' :: GenStgExpr 'Vanilla
scrut' = case StgArg
tag_arg of
StgVarArg Id
v -> Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
v []
StgLitArg Literal
l -> Literal -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
l
[GenStgAlt 'Vanilla]
alts' <- UnariseEnv
-> [StgArg] -> [GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
unariseSumAlts UnariseEnv
rho1 [StgArg]
real_args [GenStgAlt 'Vanilla]
alts
GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStgExpr 'Vanilla
-> BinderP 'Vanilla
-> AltType
-> [GenStgAlt 'Vanilla]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase GenStgExpr 'Vanilla
scrut' Id
BinderP 'Vanilla
tag_bndr AltType
tagAltTy [GenStgAlt 'Vanilla]
alts')
elimCase UnariseEnv
_ [StgArg]
args Id
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts
= String -> SDoc -> UniqSM (GenStgExpr 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"elimCase - unhandled case"
([StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> AltType -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltType
alt_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [GenStgAlt 'Vanilla] -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
[GenStgAlt pass] -> SDoc
pprPanicAlts [GenStgAlt 'Vanilla]
alts)
unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
unariseAlts :: UnariseEnv
-> AltType
-> Id
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseAlts UnariseEnv
rho (MultiValAlt Int
n) Id
bndr [GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con = AltCon
DEFAULT
, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = []
, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs = GenStgExpr 'Vanilla
e}]
| Id -> Bool
isUnboxedTupleBndr Id
bndr
= do (UnariseEnv
rho', [Id]
ys) <- UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder UnariseEnv
rho Id
bndr
!GenStgExpr 'Vanilla
e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho' GenStgExpr 'Vanilla
e
[GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [AltCon
-> [BinderP 'Vanilla] -> GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla
forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed Int
n)) [Id]
[BinderP 'Vanilla]
ys GenStgExpr 'Vanilla
e']
unariseAlts UnariseEnv
rho (MultiValAlt Int
n) Id
bndr [GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con = DataAlt DataCon
_
, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP 'Vanilla]
ys
, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs = GenStgExpr 'Vanilla
e}]
| Id -> Bool
isUnboxedTupleBndr Id
bndr
= do (UnariseEnv
rho', [Id]
ys1) <- UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseConArgBinders UnariseEnv
rho [Id]
[BinderP 'Vanilla]
ys
Bool -> UniqSM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([Id]
ys1 [Id] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n)
let rho'' :: UnariseEnv
rho'' = UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho' Id
bndr ([StgArg] -> UnariseVal
MultiVal ((Id -> StgArg) -> [Id] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> StgArg
StgVarArg [Id]
ys1))
!GenStgExpr 'Vanilla
e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho'' GenStgExpr 'Vanilla
e
[GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [AltCon
-> [BinderP 'Vanilla] -> GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla
forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed Int
n)) [Id]
[BinderP 'Vanilla]
ys1 GenStgExpr 'Vanilla
e']
unariseAlts UnariseEnv
_ (MultiValAlt Int
_) Id
bndr [GenStgAlt 'Vanilla]
alts
| Id -> Bool
isUnboxedTupleBndr Id
bndr
= String -> SDoc -> UniqSM [GenStgAlt 'Vanilla]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseExpr: strange multi val alts" ([GenStgAlt 'Vanilla] -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
[GenStgAlt pass] -> SDoc
pprPanicAlts [GenStgAlt 'Vanilla]
alts)
unariseAlts UnariseEnv
rho (MultiValAlt Int
_) Id
bndr [GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con = AltCon
DEFAULT
, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = []
, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs = GenStgExpr 'Vanilla
rhs}]
| Id -> Bool
isUnboxedSumBndr Id
bndr
= do (UnariseEnv
rho_sum_bndrs, [Id]
sum_bndrs) <- UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder UnariseEnv
rho Id
bndr
GenStgExpr 'Vanilla
rhs' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho_sum_bndrs GenStgExpr 'Vanilla
rhs
[GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [AltCon
-> [BinderP 'Vanilla] -> GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla
forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
sum_bndrs))) [Id]
[BinderP 'Vanilla]
sum_bndrs GenStgExpr 'Vanilla
rhs']
unariseAlts UnariseEnv
rho (MultiValAlt Int
_) Id
bndr [GenStgAlt 'Vanilla]
alts
| Id -> Bool
isUnboxedSumBndr Id
bndr
= do (UnariseEnv
rho_sum_bndrs, scrt_bndrs :: [Id]
scrt_bndrs@(Id
tag_bndr : [Id]
real_bndrs)) <- UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder UnariseEnv
rho Id
bndr
[GenStgAlt 'Vanilla]
alts' <- UnariseEnv
-> [StgArg] -> [GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
unariseSumAlts UnariseEnv
rho_sum_bndrs ((Id -> StgArg) -> [Id] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> StgArg
StgVarArg [Id]
real_bndrs) [GenStgAlt 'Vanilla]
alts
let inner_case :: GenStgExpr 'Vanilla
inner_case = GenStgExpr 'Vanilla
-> BinderP 'Vanilla
-> AltType
-> [GenStgAlt 'Vanilla]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase (Id -> [StgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
tag_bndr []) Id
BinderP 'Vanilla
tag_bndr AltType
tagAltTy [GenStgAlt 'Vanilla]
alts'
[GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [GenStgAlt{ alt_con :: AltCon
alt_con = DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
scrt_bndrs))
, alt_bndrs :: [BinderP 'Vanilla]
alt_bndrs = [Id]
[BinderP 'Vanilla]
scrt_bndrs
, alt_rhs :: GenStgExpr 'Vanilla
alt_rhs = GenStgExpr 'Vanilla
inner_case
}]
unariseAlts UnariseEnv
rho AltType
_ Id
_ [GenStgAlt 'Vanilla]
alts
= (GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla))
-> [GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\GenStgAlt 'Vanilla
alt -> UnariseEnv -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseAlt UnariseEnv
rho GenStgAlt 'Vanilla
alt) [GenStgAlt 'Vanilla]
alts
unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
unariseAlt :: UnariseEnv -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseAlt UnariseEnv
rho alt :: GenStgAlt 'Vanilla
alt@GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
_,alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'Vanilla]
xs,alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=GenStgExpr 'Vanilla
e}
= do (UnariseEnv
rho', [Id]
xs') <- UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseConArgBinders UnariseEnv
rho [Id]
[BinderP 'Vanilla]
xs
!GenStgExpr 'Vanilla
e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho' GenStgExpr 'Vanilla
e
GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla))
-> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
forall a b. (a -> b) -> a -> b
$! GenStgAlt 'Vanilla
alt {alt_bndrs = xs', alt_rhs = e'}
unariseSumAlts :: UnariseEnv
-> [StgArg]
-> [StgAlt]
-> UniqSM [StgAlt]
unariseSumAlts :: UnariseEnv
-> [StgArg] -> [GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
unariseSumAlts UnariseEnv
env [StgArg]
args [GenStgAlt 'Vanilla]
alts
= do [GenStgAlt 'Vanilla]
alts' <- (GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla))
-> [GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (UnariseEnv
-> [StgArg] -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseSumAlt UnariseEnv
env [StgArg]
args) [GenStgAlt 'Vanilla]
alts
[GenStgAlt 'Vanilla] -> UniqSM [GenStgAlt 'Vanilla]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenStgAlt 'Vanilla] -> [GenStgAlt 'Vanilla]
mkDefaultLitAlt [GenStgAlt 'Vanilla]
alts')
unariseSumAlt :: UnariseEnv
-> [StgArg]
-> StgAlt
-> UniqSM StgAlt
unariseSumAlt :: UnariseEnv
-> [StgArg] -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseSumAlt UnariseEnv
rho [StgArg]
_ GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
DEFAULT,alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'Vanilla]
_,alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=GenStgExpr 'Vanilla
e}
= AltCon
-> [BinderP 'Vanilla] -> GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla
forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt AltCon
DEFAULT [Id]
[BinderP 'Vanilla]
forall a. Monoid a => a
mempty (GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgAlt 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho GenStgExpr 'Vanilla
e
unariseSumAlt UnariseEnv
rho [StgArg]
args alt :: GenStgAlt 'Vanilla
alt@GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con = DataAlt DataCon
sumCon
, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP 'Vanilla]
bs
, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs = GenStgExpr 'Vanilla
e
}
= do (UnariseEnv
rho',GenStgExpr 'Vanilla
e') <- case [BinderP 'Vanilla]
bs of
[BinderP 'Vanilla
b] -> Id
-> [StgArg]
-> GenStgExpr 'Vanilla
-> UnariseEnv
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
mapSumIdBinders Id
BinderP 'Vanilla
b [StgArg]
args GenStgExpr 'Vanilla
e UnariseEnv
rho
[BinderP 'Vanilla]
_ -> String -> SDoc -> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseSumAlt2" ([StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ GenStgAlt 'Vanilla -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgAlt pass -> SDoc
pprPanicAlt GenStgAlt 'Vanilla
alt)
let lit_case :: AltCon
lit_case = Literal -> AltCon
LitAlt (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DataCon -> Int
dataConTag DataCon
sumCon)))
AltCon
-> [BinderP 'Vanilla] -> GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla
forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt AltCon
lit_case [Id]
[BinderP 'Vanilla]
forall a. Monoid a => a
mempty (GenStgExpr 'Vanilla -> GenStgAlt 'Vanilla)
-> UniqSM (GenStgExpr 'Vanilla) -> UniqSM (GenStgAlt 'Vanilla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho' GenStgExpr 'Vanilla
e'
unariseSumAlt UnariseEnv
_ [StgArg]
scrt GenStgAlt 'Vanilla
alt
= String -> SDoc -> UniqSM (GenStgAlt 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseSumAlt3" ([StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
scrt SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ GenStgAlt 'Vanilla -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgAlt pass -> SDoc
pprPanicAlt GenStgAlt 'Vanilla
alt)
mapTupleIdBinders
:: [InId]
-> [OutStgArg]
-> UnariseEnv
-> UnariseEnv
mapTupleIdBinders :: [Id] -> [StgArg] -> UnariseEnv -> UnariseEnv
mapTupleIdBinders [Id]
ids [StgArg]
args0 UnariseEnv
rho0
= Bool -> UnariseEnv -> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ((StgArg -> Bool) -> [StgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((() :: Constraint) => Type -> Bool
Type -> Bool
isZeroBitTy (Type -> Bool) -> (StgArg -> Type) -> StgArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> Type
stgArgType) [StgArg]
args0)) (UnariseEnv -> UnariseEnv) -> UnariseEnv -> UnariseEnv
forall a b. (a -> b) -> a -> b
$
let
ids_unarised :: [(Id, [PrimRep])]
ids_unarised :: [(Id, [PrimRep])]
ids_unarised = (Id -> (Id, [PrimRep])) -> [Id] -> [(Id, [PrimRep])]
forall a b. (a -> b) -> [a] -> [b]
map (\Id
id -> (Id
id, (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
id))) [Id]
ids
map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
map_ids UnariseEnv
rho [] [StgArg]
_ = UnariseEnv
rho
map_ids UnariseEnv
rho ((Id
x, [PrimRep]
x_reps) : [(Id, [PrimRep])]
xs) [StgArg]
args =
let
x_arity :: Int
x_arity = [PrimRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PrimRep]
x_reps
([StgArg]
x_args, [StgArg]
args') =
Bool
-> (Int -> [StgArg] -> ([StgArg], [StgArg]))
-> Int
-> [StgArg]
-> ([StgArg], [StgArg])
forall a. HasCallStack => Bool -> a -> a
assert ([StgArg]
args [StgArg] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Int
x_arity)
Int -> [StgArg] -> ([StgArg], [StgArg])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
x_arity [StgArg]
args
rho' :: UnariseEnv
rho'
| Int
x_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
= Bool
-> (UnariseEnv -> Id -> UnariseVal -> UnariseEnv)
-> UnariseEnv
-> Id
-> UnariseVal
-> UnariseEnv
forall a. HasCallStack => Bool -> a -> a
assert ([StgArg]
x_args [StgArg] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
1)
UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x (StgArg -> UnariseVal
UnaryVal ([StgArg] -> StgArg
forall a. HasCallStack => [a] -> a
head [StgArg]
x_args))
| Bool
otherwise
= UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x ([StgArg] -> UnariseVal
MultiVal [StgArg]
x_args)
in
UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
map_ids UnariseEnv
rho' [(Id, [PrimRep])]
xs [StgArg]
args'
in
UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
map_ids UnariseEnv
rho0 [(Id, [PrimRep])]
ids_unarised [StgArg]
args0
mapSumIdBinders
:: InId
-> [OutStgArg]
-> InStgExpr
-> UnariseEnv
-> UniqSM (UnariseEnv, OutStgExpr)
mapSumIdBinders :: Id
-> [StgArg]
-> GenStgExpr 'Vanilla
-> UnariseEnv
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
mapSumIdBinders Id
alt_bndr [StgArg]
args GenStgExpr 'Vanilla
rhs UnariseEnv
rho0
= Bool
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ((StgArg -> Bool) -> [StgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((() :: Constraint) => Type -> Bool
Type -> Bool
isZeroBitTy (Type -> Bool) -> (StgArg -> Type) -> StgArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> Type
stgArgType) [StgArg]
args)) (UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla))
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ do
[UniqSupply]
uss <- UniqSupply -> [UniqSupply]
listSplitUniqSupply (UniqSupply -> [UniqSupply])
-> UniqSM UniqSupply -> UniqSM [UniqSupply]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
let
fld_reps :: [PrimRep]
fld_reps = (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
alt_bndr)
arg_slots :: [SlotTy]
arg_slots = (PrimRep -> SlotTy) -> [PrimRep] -> [SlotTy]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> SlotTy
primRepSlot ([PrimRep] -> [SlotTy]) -> [PrimRep] -> [SlotTy]
forall a b. (a -> b) -> a -> b
$ (StgArg -> [PrimRep]) -> [StgArg] -> [PrimRep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Type -> [PrimRep]) -> (StgArg -> Type) -> StgArg -> [PrimRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> Type
stgArgType) [StgArg]
args
id_slots :: [SlotTy]
id_slots = (PrimRep -> SlotTy) -> [PrimRep] -> [SlotTy]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> SlotTy
primRepSlot ([PrimRep] -> [SlotTy]) -> [PrimRep] -> [SlotTy]
forall a b. (a -> b) -> a -> b
$ [PrimRep]
fld_reps
layout1 :: [Int]
layout1 = [SlotTy] -> [SlotTy] -> [Int]
(() :: Constraint) => [SlotTy] -> [SlotTy] -> [Int]
layoutUbxSum [SlotTy]
arg_slots [SlotTy]
id_slots
id_arg_exprs :: [StgArg]
id_arg_exprs = [ [StgArg]
args [StgArg] -> Int -> StgArg
forall a. HasCallStack => [a] -> Int -> a
!! Int
i | Int
i <- [Int]
layout1 ]
id_vars :: [Id]
id_vars = [Id
v | StgVarArg Id
v <- [StgArg]
id_arg_exprs]
id_tys :: [Type]
id_tys = (PrimRep -> Type) -> [PrimRep] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> Type
primRepToType [PrimRep]
fld_reps
typed_id_arg_input :: [(Id, Type, UniqSupply)]
typed_id_arg_input = Bool -> [(Id, Type, UniqSupply)] -> [(Id, Type, UniqSupply)]
forall a. HasCallStack => Bool -> a -> a
assert ([Id] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Id]
id_vars [Type]
id_tys) ([(Id, Type, UniqSupply)] -> [(Id, Type, UniqSupply)])
-> [(Id, Type, UniqSupply)] -> [(Id, Type, UniqSupply)]
forall a b. (a -> b) -> a -> b
$
[Id] -> [Type] -> [UniqSupply] -> [(Id, Type, UniqSupply)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Id]
id_vars [Type]
id_tys [UniqSupply]
uss
mkCastInput :: (Id,Type,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id)
mkCastInput :: (Id, Type, UniqSupply) -> ([(PrimOp, Type, Unique)], Id, Id)
mkCastInput (Id
id,Type
tar_type,UniqSupply
bndr_us) =
let ([PrimOp]
ops,[Type]
types) = [(PrimOp, Type)] -> ([PrimOp], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(PrimOp, Type)] -> ([PrimOp], [Type]))
-> [(PrimOp, Type)] -> ([PrimOp], [Type])
forall a b. (a -> b) -> a -> b
$ PrimRep -> PrimRep -> [(PrimOp, Type)]
getCasts ((() :: Constraint) => Type -> PrimRep
Type -> PrimRep
typePrimRep1 (Type -> PrimRep) -> Type -> PrimRep
forall a b. (a -> b) -> a -> b
$ Id -> Type
idType Id
id) ((() :: Constraint) => Type -> PrimRep
Type -> PrimRep
typePrimRep1 Type
tar_type)
cst_opts :: [(PrimOp, Type, Unique)]
cst_opts = [PrimOp] -> [Type] -> [Unique] -> [(PrimOp, Type, Unique)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [PrimOp]
ops [Type]
types ([Unique] -> [(PrimOp, Type, Unique)])
-> [Unique] -> [(PrimOp, Type, Unique)]
forall a b. (a -> b) -> a -> b
$ UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
bndr_us
out_id :: Id
out_id = case [(PrimOp, Type, Unique)]
cst_opts of
[] -> Id
id
[(PrimOp, Type, Unique)]
_ -> let (PrimOp
_,Type
ty,Unique
uq) = [(PrimOp, Type, Unique)] -> (PrimOp, Type, Unique)
forall a. HasCallStack => [a] -> a
last [(PrimOp, Type, Unique)]
cst_opts
in Unique -> Type -> Id
mkCastVar Unique
uq Type
ty
in ([(PrimOp, Type, Unique)]
cst_opts,Id
id,Id
out_id)
cast_inputs :: [([(PrimOp, Type, Unique)], Id, Id)]
cast_inputs = ((Id, Type, UniqSupply) -> ([(PrimOp, Type, Unique)], Id, Id))
-> [(Id, Type, UniqSupply)] -> [([(PrimOp, Type, Unique)], Id, Id)]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Type, UniqSupply) -> ([(PrimOp, Type, Unique)], Id, Id)
mkCastInput [(Id, Type, UniqSupply)]
typed_id_arg_input
(GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
rhs_with_casts,[Id]
typed_ids) = ((GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> ([(PrimOp, Type, Unique)], Id, Id)
-> (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla, Id))
-> (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> [([(PrimOp, Type, Unique)], Id, Id)]
-> (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla, [Id])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> ([(PrimOp, Type, Unique)], Id, Id)
-> (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla, Id)
forall {c} {b}.
(GenStgExpr 'Vanilla -> c)
-> ([(PrimOp, Type, Unique)], Id, b)
-> (GenStgExpr 'Vanilla -> c, b)
cast_arg (\GenStgExpr 'Vanilla
x->GenStgExpr 'Vanilla
x) [([(PrimOp, Type, Unique)], Id, Id)]
cast_inputs
where
cast_arg :: (GenStgExpr 'Vanilla -> c)
-> ([(PrimOp, Type, Unique)], Id, b)
-> (GenStgExpr 'Vanilla -> c, b)
cast_arg GenStgExpr 'Vanilla -> c
rhs_in ([(PrimOp, Type, Unique)]
cast_ops,Id
in_id,b
out_id) =
let rhs_out :: GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
rhs_out = [(PrimOp, Type, Unique)]
-> StgArg -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
castArgRename [(PrimOp, Type, Unique)]
cast_ops (Id -> StgArg
StgVarArg Id
in_id)
in (GenStgExpr 'Vanilla -> c
rhs_in (GenStgExpr 'Vanilla -> c)
-> (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> GenStgExpr 'Vanilla
-> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
rhs_out, b
out_id)
typed_id_args :: [StgArg]
typed_id_args = (Id -> StgArg) -> [Id] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> StgArg
StgVarArg [Id]
typed_ids
if Id -> Bool
isMultiValBndr Id
alt_bndr
then (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho0 Id
alt_bndr ([StgArg] -> UnariseVal
MultiVal [StgArg]
typed_id_args), GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
rhs_with_casts GenStgExpr 'Vanilla
rhs)
else Bool
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. HasCallStack => Bool -> a -> a
assert ([StgArg]
typed_id_args [StgArg] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
1) (UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla))
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$
(UnariseEnv, GenStgExpr 'Vanilla)
-> UniqSM (UnariseEnv, GenStgExpr 'Vanilla)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho0 Id
alt_bndr (StgArg -> UnariseVal
UnaryVal ([StgArg] -> StgArg
forall a. HasCallStack => [a] -> a
head [StgArg]
typed_id_args)), GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
rhs_with_casts GenStgExpr 'Vanilla
rhs)
castArgRename :: [(PrimOp,Type,Unique)] -> StgArg -> StgExpr -> StgExpr
castArgRename :: [(PrimOp, Type, Unique)]
-> StgArg -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
castArgRename [(PrimOp, Type, Unique)]
ops StgArg
in_arg GenStgExpr 'Vanilla
rhs =
case [(PrimOp, Type, Unique)]
ops of
[] -> GenStgExpr 'Vanilla
rhs
((PrimOp
op,Type
ty,Unique
uq):[(PrimOp, Type, Unique)]
rest_ops) ->
let out_id' :: Id
out_id' = Unique -> Type -> Id
mkCastVar Unique
uq Type
ty
sub_cast :: GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
sub_cast = [(PrimOp, Type, Unique)]
-> StgArg -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
castArgRename [(PrimOp, Type, Unique)]
rest_ops (Id -> StgArg
StgVarArg Id
out_id')
in StgArg
-> PrimOp
-> Id
-> Type
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
mkCast StgArg
in_arg PrimOp
op Id
out_id' Type
ty (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall a b. (a -> b) -> a -> b
$ GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
sub_cast GenStgExpr 'Vanilla
rhs
mkCastVar :: Unique -> Type -> Id
mkCastVar :: Unique -> Type -> Id
mkCastVar Unique
uq Type
ty = FastString -> Unique -> Type -> Type -> Id
mkSysLocal (String -> FastString
fsLit String
"cst_sum") Unique
uq Type
ManyTy Type
ty
mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr
mkCast :: StgArg
-> PrimOp
-> Id
-> Type
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
mkCast StgArg
arg_in PrimOp
cast_op Id
out_id Type
out_ty GenStgExpr 'Vanilla
in_rhs =
let r2 :: PrimRep
r2 = (() :: Constraint) => Type -> PrimRep
Type -> PrimRep
typePrimRep1 Type
out_ty
scrut :: GenStgExpr 'Vanilla
scrut = StgOp -> [StgArg] -> Type -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (PrimOp -> StgOp
StgPrimOp PrimOp
cast_op) [StgArg
arg_in] Type
out_ty
alt :: GenStgAlt 'Vanilla
alt = GenStgAlt { alt_con :: AltCon
alt_con = AltCon
DEFAULT, alt_bndrs :: [BinderP 'Vanilla]
alt_bndrs = [], alt_rhs :: GenStgExpr 'Vanilla
alt_rhs = GenStgExpr 'Vanilla
in_rhs}
alt_ty :: AltType
alt_ty = PrimRep -> AltType
PrimAlt PrimRep
r2
in (GenStgExpr 'Vanilla
-> BinderP 'Vanilla
-> AltType
-> [GenStgAlt 'Vanilla]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase GenStgExpr 'Vanilla
scrut Id
BinderP 'Vanilla
out_id AltType
alt_ty [GenStgAlt 'Vanilla
alt])
mkUbxSum
:: HasDebugCallStack
=> DataCon
-> [Type]
-> [OutStgArg]
-> UniqSupply
-> ([OutStgArg]
,(StgExpr->StgExpr)
)
mkUbxSum :: (() :: Constraint) =>
DataCon
-> [Type]
-> [StgArg]
-> UniqSupply
-> ([StgArg], GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
mkUbxSum DataCon
dc [Type]
ty_args [StgArg]
args0 UniqSupply
us
= let
SlotTy
_ :| [SlotTy]
sum_slots = [[PrimRep]] -> NonEmpty SlotTy
ubxSumRepType ((Type -> [PrimRep]) -> [Type] -> [[PrimRep]]
forall a b. (a -> b) -> [a] -> [b]
map (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep [Type]
ty_args)
field_slots :: [SlotTy]
field_slots = ((StgArg -> Maybe SlotTy) -> [StgArg] -> [SlotTy]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Type -> Maybe SlotTy
typeSlotTy (Type -> Maybe SlotTy)
-> (StgArg -> Type) -> StgArg -> Maybe SlotTy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> Type
stgArgType) [StgArg]
args0)
tag :: Int
tag = DataCon -> Int
dataConTag DataCon
dc
layout' :: [Int]
layout' = [SlotTy] -> [SlotTy] -> [Int]
(() :: Constraint) => [SlotTy] -> [SlotTy] -> [Int]
layoutUbxSum [SlotTy]
sum_slots [SlotTy]
field_slots
tag_arg :: StgArg
tag_arg = Literal -> StgArg
StgLitArg (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tag))
arg_idxs :: IntMap StgArg
arg_idxs = [(Int, StgArg)] -> IntMap StgArg
forall a. [(Int, a)] -> IntMap a
IM.fromList (String -> [Int] -> [StgArg] -> [(Int, StgArg)]
forall a b. (() :: Constraint) => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"mkUbxSum" [Int]
layout' [StgArg]
args0)
((Int
_idx,IntMap StgArg
_idx_map,UniqSupply
_us,GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper),[StgArg]
slot_args)
= Bool
-> ((Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
[StgArg])
-> ((Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
[StgArg])
forall a. HasCallStack => Bool -> a -> a
assert (IntMap StgArg -> Int
forall a. IntMap a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length IntMap StgArg
arg_idxs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [SlotTy] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SlotTy]
sum_slots ) (((Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
[StgArg])
-> ((Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
[StgArg]))
-> ((Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
[StgArg])
-> ((Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
[StgArg])
forall a b. (a -> b) -> a -> b
$
((Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> SlotTy
-> ((Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
StgArg))
-> (Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> [SlotTy]
-> ((Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
[StgArg])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> SlotTy
-> ((Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
StgArg)
mkTupArg (Int
0,IntMap StgArg
arg_idxs,UniqSupply
us,GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall a. a -> a
id) [SlotTy]
sum_slots
mkTupArg :: (Int, IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr)
-> SlotTy
-> ((Int,IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr), StgArg)
mkTupArg :: (Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> SlotTy
-> ((Int, IntMap StgArg, UniqSupply,
GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla),
StgArg)
mkTupArg (Int
arg_idx, IntMap StgArg
arg_map, UniqSupply
us, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper) SlotTy
slot
| Just StgArg
stg_arg <- Int -> IntMap StgArg -> Maybe StgArg
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
arg_idx IntMap StgArg
arg_map
= case UniqSupply
-> SlotTy
-> StgArg
-> Maybe
(StgArg, UniqSupply, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
castArg UniqSupply
us SlotTy
slot StgArg
stg_arg of
Just (StgArg
casted_arg,UniqSupply
us',GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper') ->
( (Int
arg_idxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, IntMap StgArg
arg_map, UniqSupply
us', GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> (GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper')
, StgArg
casted_arg)
Maybe
(StgArg, UniqSupply, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
Nothing ->
( (Int
arg_idxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, IntMap StgArg
arg_map, UniqSupply
us, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper)
, StgArg
stg_arg)
| Bool
otherwise
= ( (Int
arg_idxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, IntMap StgArg
arg_map, UniqSupply
us, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper)
, SlotTy -> StgArg
ubxSumRubbishArg SlotTy
slot)
castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr)
castArg :: UniqSupply
-> SlotTy
-> StgArg
-> Maybe
(StgArg, UniqSupply, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
castArg UniqSupply
us SlotTy
slot_ty StgArg
arg
| SlotTy -> PrimRep
slotPrimRep SlotTy
slot_ty PrimRep -> PrimRep -> Bool
forall a. Eq a => a -> a -> Bool
/= (() :: Constraint) => Type -> PrimRep
Type -> PrimRep
typePrimRep1 (StgArg -> Type
stgArgType StgArg
arg)
, Type
out_ty <- PrimRep -> Type
primRepToType (PrimRep -> Type) -> PrimRep -> Type
forall a b. (a -> b) -> a -> b
$ SlotTy -> PrimRep
slotPrimRep SlotTy
slot_ty
, ([PrimOp]
ops,[Type]
types) <- [(PrimOp, Type)] -> ([PrimOp], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(PrimOp, Type)] -> ([PrimOp], [Type]))
-> [(PrimOp, Type)] -> ([PrimOp], [Type])
forall a b. (a -> b) -> a -> b
$ PrimRep -> PrimRep -> [(PrimOp, Type)]
getCasts ((() :: Constraint) => Type -> PrimRep
Type -> PrimRep
typePrimRep1 (Type -> PrimRep) -> Type -> PrimRep
forall a b. (a -> b) -> a -> b
$ StgArg -> Type
stgArgType StgArg
arg) (PrimRep -> [(PrimOp, Type)]) -> PrimRep -> [(PrimOp, Type)]
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => Type -> PrimRep
Type -> PrimRep
typePrimRep1 Type
out_ty
, Bool -> Bool
not (Bool -> Bool) -> ([PrimOp] -> Bool) -> [PrimOp] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PrimOp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([PrimOp] -> Bool) -> [PrimOp] -> Bool
forall a b. (a -> b) -> a -> b
$ [PrimOp]
ops
= let (UniqSupply
us1,UniqSupply
us2) = UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us
cast_uqs :: [Unique]
cast_uqs = UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
us1
cast_opts :: [(PrimOp, Type, Unique)]
cast_opts = [PrimOp] -> [Type] -> [Unique] -> [(PrimOp, Type, Unique)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [PrimOp]
ops [Type]
types [Unique]
cast_uqs
(PrimOp
_op,Type
out_ty,Unique
out_uq) = [(PrimOp, Type, Unique)] -> (PrimOp, Type, Unique)
forall a. HasCallStack => [a] -> a
last [(PrimOp, Type, Unique)]
cast_opts
casts :: GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
casts = [(PrimOp, Type, Unique)]
-> StgArg -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
castArgRename [(PrimOp, Type, Unique)]
cast_opts StgArg
arg :: StgExpr -> StgExpr
in (StgArg, UniqSupply, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
-> Maybe
(StgArg, UniqSupply, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall a. a -> Maybe a
Just (Id -> StgArg
StgVarArg (Unique -> Type -> Id
mkCastVar Unique
out_uq Type
out_ty),UniqSupply
us2,GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
casts)
| Bool
otherwise = Maybe
(StgArg, UniqSupply, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla)
forall a. Maybe a
Nothing
tup_args :: [StgArg]
tup_args = StgArg
tag_arg StgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
: [StgArg]
slot_args
in
([StgArg]
tup_args, GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
wrapper)
ubxSumRubbishArg :: SlotTy -> StgArg
ubxSumRubbishArg :: SlotTy -> StgArg
ubxSumRubbishArg SlotTy
PtrLiftedSlot = Id -> StgArg
StgVarArg Id
aBSENT_SUM_FIELD_ERROR_ID
ubxSumRubbishArg SlotTy
PtrUnliftedSlot = Id -> StgArg
StgVarArg Id
aBSENT_SUM_FIELD_ERROR_ID
ubxSumRubbishArg SlotTy
WordSlot = Literal -> StgArg
StgLitArg (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumWord Integer
0)
ubxSumRubbishArg SlotTy
Word64Slot = Literal -> StgArg
StgLitArg (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumWord64 Integer
0)
ubxSumRubbishArg SlotTy
FloatSlot = Literal -> StgArg
StgLitArg (Rational -> Literal
LitFloat Rational
0)
ubxSumRubbishArg SlotTy
DoubleSlot = Literal -> StgArg
StgLitArg (Rational -> Literal
LitDouble Rational
0)
ubxSumRubbishArg (VecSlot Int
n PrimElemRep
e) = Literal -> StgArg
StgLitArg (TypeOrConstraint -> Type -> Literal
LitRubbish TypeOrConstraint
TypeLike Type
vec_rep)
where vec_rep :: Type
vec_rep = PrimRep -> Type
primRepToRuntimeRep (Int -> PrimElemRep -> PrimRep
VecRep Int
n PrimElemRep
e)
unariseArgBinder
:: Bool
-> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseArgBinder :: Bool -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseArgBinder Bool
is_con_arg UnariseEnv
rho Id
x =
case (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
x) of
[]
| Bool
is_con_arg
-> (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x ([StgArg] -> UnariseVal
MultiVal []), [])
| Bool
otherwise
-> (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x ([StgArg] -> UnariseVal
MultiVal []), [Id
voidArgId])
[PrimRep
rep]
| Type -> Bool
isUnboxedSumType (Id -> Type
idType Id
x) Bool -> Bool -> Bool
|| Type -> Bool
isUnboxedTupleType (Id -> Type
idType Id
x)
-> do Id
x' <- FastString -> Type -> UniqSM Id
mkId (String -> FastString
mkFastString String
"us") (PrimRep -> Type
primRepToType PrimRep
rep)
(UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x ([StgArg] -> UnariseVal
MultiVal [Id -> StgArg
StgVarArg Id
x']), [Id
x'])
| Bool
otherwise
-> (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseEnv
extendRhoWithoutValue UnariseEnv
rho Id
x, [Id
x])
[PrimRep]
reps -> do
[Id]
xs <- FastString -> [Type] -> UniqSM [Id]
mkIds (String -> FastString
mkFastString String
"us") ((PrimRep -> Type) -> [PrimRep] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> Type
primRepToType [PrimRep]
reps)
(UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x ([StgArg] -> UnariseVal
MultiVal ((Id -> StgArg) -> [Id] -> [StgArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> StgArg
StgVarArg [Id]
xs)), [Id]
xs)
unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
unariseFunArg UnariseEnv
rho (StgVarArg Id
x) =
case UnariseEnv -> Id -> Maybe UnariseVal
lookupRho UnariseEnv
rho Id
x of
Just (MultiVal []) -> [StgArg
voidArg]
Just (MultiVal [StgArg]
as) -> [StgArg]
as
Just (UnaryVal StgArg
arg) -> [StgArg
arg]
Maybe UnariseVal
Nothing -> [Id -> StgArg
StgVarArg Id
x]
unariseFunArg UnariseEnv
_ arg :: StgArg
arg@(StgLitArg Literal
lit) = case Literal -> Maybe [StgArg]
unariseLiteral_maybe Literal
lit of
Just [] -> [StgArg
voidArg]
Just [StgArg]
as -> [StgArg]
as
Maybe [StgArg]
Nothing -> [StgArg
arg]
unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
unariseFunArgs = (StgArg -> [StgArg]) -> [StgArg] -> [StgArg]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((StgArg -> [StgArg]) -> [StgArg] -> [StgArg])
-> (UnariseEnv -> StgArg -> [StgArg])
-> UnariseEnv
-> [StgArg]
-> [StgArg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnariseEnv -> StgArg -> [StgArg]
unariseFunArg
unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinders UnariseEnv
rho [Id]
xs = ([[Id]] -> [Id]) -> (UnariseEnv, [[Id]]) -> (UnariseEnv, [Id])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [[Id]] -> [Id]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((UnariseEnv, [[Id]]) -> (UnariseEnv, [Id]))
-> UniqSM (UnariseEnv, [[Id]]) -> UniqSM (UnariseEnv, [Id])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]))
-> UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [[Id]])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinder UnariseEnv
rho [Id]
xs
unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinder = Bool -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseArgBinder Bool
False
unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]
unariseConArg :: UnariseEnv -> StgArg -> [StgArg]
unariseConArg UnariseEnv
rho (StgVarArg Id
x) =
case UnariseEnv -> Id -> Maybe UnariseVal
lookupRho UnariseEnv
rho Id
x of
Just (UnaryVal StgArg
arg) -> [StgArg
arg]
Just (MultiVal [StgArg]
as) -> [StgArg]
as
Maybe UnariseVal
Nothing
| (() :: Constraint) => Type -> Bool
Type -> Bool
isZeroBitTy (Id -> Type
idType Id
x) -> []
| Bool
otherwise -> [Id -> StgArg
StgVarArg Id
x]
unariseConArg UnariseEnv
_ arg :: StgArg
arg@(StgLitArg Literal
lit)
| Just [StgArg]
as <- Literal -> Maybe [StgArg]
unariseLiteral_maybe Literal
lit
= [StgArg]
as
| Bool
otherwise
= Bool -> [StgArg] -> [StgArg]
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ((() :: Constraint) => Type -> Bool
Type -> Bool
isZeroBitTy (Literal -> Type
literalType Literal
lit)))
[StgArg
arg]
unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
unariseConArgs :: UnariseEnv -> [StgArg] -> [StgArg]
unariseConArgs = (StgArg -> [StgArg]) -> [StgArg] -> [StgArg]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((StgArg -> [StgArg]) -> [StgArg] -> [StgArg])
-> (UnariseEnv -> StgArg -> [StgArg])
-> UnariseEnv
-> [StgArg]
-> [StgArg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnariseEnv -> StgArg -> [StgArg]
unariseConArg
unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseConArgBinders UnariseEnv
rho [Id]
xs = ([[Id]] -> [Id]) -> (UnariseEnv, [[Id]]) -> (UnariseEnv, [Id])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [[Id]] -> [Id]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((UnariseEnv, [[Id]]) -> (UnariseEnv, [Id]))
-> UniqSM (UnariseEnv, [[Id]]) -> UniqSM (UnariseEnv, [Id])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id]))
-> UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [[Id]])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder UnariseEnv
rho [Id]
xs
unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder = Bool -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseArgBinder Bool
True
mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
mkIds :: FastString -> [Type] -> UniqSM [Id]
mkIds FastString
fs [Type]
tys = FastString -> [Type] -> UniqSM [Id]
forall (m :: * -> *).
MonadUnique m =>
FastString -> [Type] -> m [Id]
mkUnarisedIds FastString
fs [Type]
tys
mkId :: FastString -> UnaryType -> UniqSM Id
mkId :: FastString -> Type -> UniqSM Id
mkId FastString
s Type
t = FastString -> Type -> UniqSM Id
forall (m :: * -> *). MonadUnique m => FastString -> Type -> m Id
mkUnarisedId FastString
s Type
t
isMultiValBndr :: Id -> Bool
isMultiValBndr :: Id -> Bool
isMultiValBndr Id
id
| [PrimRep
_] <- (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
id)
= Bool
False
| Bool
otherwise
= Bool
True
isUnboxedSumBndr :: Id -> Bool
isUnboxedSumBndr :: Id -> Bool
isUnboxedSumBndr = Type -> Bool
isUnboxedSumType (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType
isUnboxedTupleBndr :: Id -> Bool
isUnboxedTupleBndr :: Id -> Bool
isUnboxedTupleBndr = Type -> Bool
isUnboxedTupleType (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType
mkTuple :: [StgArg] -> StgExpr
mkTuple :: [StgArg] -> GenStgExpr 'Vanilla
mkTuple [StgArg]
args = DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([StgArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
args)) ConstructorNumber
NoNumber [StgArg]
args ((StgArg -> Type) -> [StgArg] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> Type
stgArgType [StgArg]
args)
tagAltTy :: AltType
tagAltTy :: AltType
tagAltTy = PrimRep -> AltType
PrimAlt PrimRep
IntRep
tagTy :: Type
tagTy :: Type
tagTy = Type
intPrimTy
voidArg :: StgArg
voidArg :: StgArg
voidArg = Id -> StgArg
StgVarArg Id
voidPrimId
mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
mkDefaultLitAlt :: [GenStgAlt 'Vanilla] -> [GenStgAlt 'Vanilla]
mkDefaultLitAlt [] = String -> SDoc -> [GenStgAlt 'Vanilla]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"elimUbxSumExpr.mkDefaultAlt" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Empty alts")
mkDefaultLitAlt alts :: [GenStgAlt 'Vanilla]
alts@(GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
DEFAULT,alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'Vanilla]
_,alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=GenStgExpr 'Vanilla
_} : [GenStgAlt 'Vanilla]
_) = [GenStgAlt 'Vanilla]
alts
mkDefaultLitAlt (alt :: GenStgAlt 'Vanilla
alt@GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=LitAlt{}, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[]} : [GenStgAlt 'Vanilla]
alts) = GenStgAlt 'Vanilla
alt {alt_con = DEFAULT} GenStgAlt 'Vanilla -> [GenStgAlt 'Vanilla] -> [GenStgAlt 'Vanilla]
forall a. a -> [a] -> [a]
: [GenStgAlt 'Vanilla]
alts
mkDefaultLitAlt [GenStgAlt 'Vanilla]
alts = String -> SDoc -> [GenStgAlt 'Vanilla]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkDefaultLitAlt" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Not a lit alt:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [GenStgAlt 'Vanilla] -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
[GenStgAlt pass] -> SDoc
pprPanicAlts [GenStgAlt 'Vanilla]
alts)
pprPanicAlts :: OutputablePass pass => [GenStgAlt pass] -> SDoc
pprPanicAlts :: forall (pass :: StgPass).
OutputablePass pass =>
[GenStgAlt pass] -> SDoc
pprPanicAlts [GenStgAlt pass]
alts = [SDoc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((GenStgAlt pass -> SDoc) -> [GenStgAlt pass] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenStgAlt pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgAlt pass -> SDoc
pprPanicAlt [GenStgAlt pass]
alts)
pprPanicAlt :: OutputablePass pass => GenStgAlt pass -> SDoc
pprPanicAlt :: forall (pass :: StgPass).
OutputablePass pass =>
GenStgAlt pass -> SDoc
pprPanicAlt GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
c,alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP pass]
b,alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=GenStgExpr pass
e} = (AltCon, [BinderP pass], SDoc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (AltCon
c,[BinderP pass]
b,StgPprOpts -> GenStgExpr pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts GenStgExpr pass
e)