{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Stg.Unarise (unarise) where
import GHC.Prelude
import GHC.Types.Basic
import GHC.Core
import GHC.Core.DataCon
import GHC.Core.TyCon ( isVoidRep )
import GHC.Data.FastString (FastString, mkFastString)
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.Utils.Misc
import GHC.Types.Var.Env
import Data.Bifunctor (second)
import Data.Maybe (mapMaybe)
import qualified Data.IntMap as IM
type UnariseEnv = VarEnv UnariseVal
data UnariseVal
= MultiVal [OutStgArg]
| UnaryVal OutStgArg
instance Outputable UnariseVal where
ppr :: UnariseVal -> SDoc
ppr (MultiVal [OutStgArg]
args) = String -> SDoc
text String
"MultiVal" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [OutStgArg]
args
ppr (UnaryVal OutStgArg
arg) = String -> SDoc
text String
"UnaryVal" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr OutStgArg
arg
extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho :: UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
x (MultiVal [OutStgArg]
args)
= forall a. HasCallStack => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Type -> Bool
isNvUnaryType forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutStgArg -> Type
stgArgType) [OutStgArg]
args)
forall a. VarEnv a -> InId -> a -> VarEnv a
extendVarEnv UnariseEnv
rho InId
x ([OutStgArg] -> UnariseVal
MultiVal [OutStgArg]
args)
extendRho UnariseEnv
rho InId
x (UnaryVal OutStgArg
val)
= forall a. HasCallStack => Bool -> a -> a
assert (Type -> Bool
isNvUnaryType (OutStgArg -> Type
stgArgType OutStgArg
val))
forall a. VarEnv a -> InId -> a -> VarEnv a
extendVarEnv UnariseEnv
rho InId
x (OutStgArg -> UnariseVal
UnaryVal OutStgArg
val)
extendRhoWithoutValue :: UnariseEnv -> Id -> UnariseEnv
extendRhoWithoutValue :: UnariseEnv -> InId -> UnariseEnv
extendRhoWithoutValue UnariseEnv
rho InId
x = forall a. VarEnv a -> InId -> VarEnv a
delVarEnv UnariseEnv
rho InId
x
unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
unarise UniqSupply
us [StgTopBinding]
binds = forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
unariseTopBinding forall a. VarEnv a
emptyVarEnv) [StgTopBinding]
binds)
unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
unariseTopBinding UnariseEnv
rho (StgTopLifted GenStgBinding 'Vanilla
bind)
= forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted 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{} = 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)
= forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec BinderP 'Vanilla
x 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)
= forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(InId
x, GenStgRhs 'Vanilla
rhs) -> (InId
x,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv -> GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
unariseRhs UnariseEnv
rho GenStgRhs 'Vanilla
rhs) [(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', [InId]
args1) <- UnariseEnv -> [InId] -> UniqSM (UnariseEnv, [InId])
unariseFunArgBinders UnariseEnv
rho [BinderP 'Vanilla]
args
GenStgExpr 'Vanilla
expr' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho' GenStgExpr 'Vanilla
expr
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
ext CostCentreStack
ccs UpdateFlag
update_flag [InId]
args1 GenStgExpr 'Vanilla
expr')
unariseRhs UnariseEnv
rho (StgRhsCon CostCentreStack
ccs DataCon
con ConstructorNumber
mu [StgTickish]
ts [OutStgArg]
args)
= forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (DataCon -> Bool
isUnboxedTupleDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con))
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [OutStgArg]
-> GenStgRhs pass
StgRhsCon CostCentreStack
ccs DataCon
con ConstructorNumber
mu [StgTickish]
ts (UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseConArgs UnariseEnv
rho [OutStgArg]
args))
unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr
unariseExpr :: UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho e :: GenStgExpr 'Vanilla
e@(StgApp InId
f [])
= case forall a. VarEnv a -> InId -> Maybe a
lookupVarEnv UnariseEnv
rho InId
f of
Just (MultiVal [OutStgArg]
args)
-> forall (m :: * -> *) a. Monad m => a -> m a
return ([OutStgArg] -> GenStgExpr 'Vanilla
mkTuple [OutStgArg]
args)
Just (UnaryVal (StgVarArg InId
f'))
-> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass). InId -> [OutStgArg] -> GenStgExpr pass
StgApp InId
f' [])
Just (UnaryVal (StgLitArg Literal
f'))
-> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
f')
Maybe UnariseVal
Nothing
-> forall (m :: * -> *) a. Monad m => a -> m a
return GenStgExpr 'Vanilla
e
unariseExpr UnariseEnv
rho e :: GenStgExpr 'Vanilla
e@(StgApp InId
f [OutStgArg]
args)
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass). InId -> [OutStgArg] -> GenStgExpr pass
StgApp InId
f' (UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseFunArgs UnariseEnv
rho [OutStgArg]
args))
where
f' :: InId
f' = case forall a. VarEnv a -> InId -> Maybe a
lookupVarEnv UnariseEnv
rho InId
f of
Just (UnaryVal (StgVarArg InId
f')) -> InId
f'
Maybe UnariseVal
Nothing -> InId
f
Maybe UnariseVal
err -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseExpr - app2" (forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts GenStgExpr 'Vanilla
e SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Maybe UnariseVal
err)
unariseExpr UnariseEnv
_ (StgLit Literal
l)
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
l)
unariseExpr UnariseEnv
rho (StgConApp DataCon
dc ConstructorNumber
n [OutStgArg]
args [Type]
ty_args)
| Just [OutStgArg]
args' <- UnariseEnv -> DataCon -> [OutStgArg] -> [Type] -> Maybe [OutStgArg]
unariseMulti_maybe UnariseEnv
rho DataCon
dc [OutStgArg]
args [Type]
ty_args
= forall (m :: * -> *) a. Monad m => a -> m a
return ([OutStgArg] -> GenStgExpr 'Vanilla
mkTuple [OutStgArg]
args')
| Bool
otherwise
, let args' :: [OutStgArg]
args' = UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseConArgs UnariseEnv
rho [OutStgArg]
args
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [OutStgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
n [OutStgArg]
args' (forall a b. (a -> b) -> [a] -> [b]
map OutStgArg -> Type
stgArgType [OutStgArg]
args'))
unariseExpr UnariseEnv
rho (StgOpApp StgOp
op [OutStgArg]
args Type
ty)
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass).
StgOp -> [OutStgArg] -> Type -> GenStgExpr pass
StgOpApp StgOp
op (UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseFunArgs UnariseEnv
rho [OutStgArg]
args) Type
ty)
unariseExpr UnariseEnv
rho (StgCase GenStgExpr 'Vanilla
scrut BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts)
| StgApp InId
v [] <- GenStgExpr 'Vanilla
scrut
, Just (MultiVal [OutStgArg]
xs) <- forall a. VarEnv a -> InId -> Maybe a
lookupVarEnv UnariseEnv
rho InId
v
= UnariseEnv
-> [OutStgArg]
-> InId
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [OutStgArg]
xs BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts
| StgConApp DataCon
dc ConstructorNumber
_n [OutStgArg]
args [Type]
ty_args <- GenStgExpr 'Vanilla
scrut
, Just [OutStgArg]
args' <- UnariseEnv -> DataCon -> [OutStgArg] -> [Type] -> Maybe [OutStgArg]
unariseMulti_maybe UnariseEnv
rho DataCon
dc [OutStgArg]
args [Type]
ty_args
= UnariseEnv
-> [OutStgArg]
-> InId
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [OutStgArg]
args' BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts
| StgLit Literal
lit <- GenStgExpr 'Vanilla
scrut
, Just [OutStgArg]
args' <- Literal -> Maybe [OutStgArg]
unariseRubbish_maybe Literal
lit
= UnariseEnv
-> [OutStgArg]
-> InId
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [OutStgArg]
args' 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
-> InId
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseAlts UnariseEnv
rho AltType
alt_ty BinderP 'Vanilla
bndr [GenStgAlt 'Vanilla]
alts
forall (m :: * -> *) a. Monad m => a -> m a
return (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)
= forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
ext forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv
-> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho GenStgBinding 'Vanilla
bind 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)
= forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape 'Vanilla
ext forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv
-> GenStgBinding 'Vanilla -> UniqSM (GenStgBinding 'Vanilla)
unariseBinding UnariseEnv
rho GenStgBinding 'Vanilla
bind 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)
= forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
tick forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho GenStgExpr 'Vanilla
e
unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]
unariseMulti_maybe :: UnariseEnv -> DataCon -> [OutStgArg] -> [Type] -> Maybe [OutStgArg]
unariseMulti_maybe UnariseEnv
rho DataCon
dc [OutStgArg]
args [Type]
ty_args
| DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc
= forall a. a -> Maybe a
Just (UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseConArgs UnariseEnv
rho [OutStgArg]
args)
| DataCon -> Bool
isUnboxedSumDataCon DataCon
dc
, let args1 :: [OutStgArg]
args1 = forall a. HasCallStack => Bool -> a -> a
assert (forall a. [a] -> Bool
isSingleton [OutStgArg]
args) (UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseConArgs UnariseEnv
rho [OutStgArg]
args)
= forall a. a -> Maybe a
Just (DataCon -> [Type] -> [OutStgArg] -> [OutStgArg]
mkUbxSum DataCon
dc [Type]
ty_args [OutStgArg]
args1)
| Bool
otherwise
= forall a. Maybe a
Nothing
unariseRubbish_maybe :: Literal -> Maybe [OutStgArg]
unariseRubbish_maybe :: Literal -> Maybe [OutStgArg]
unariseRubbish_maybe (LitRubbish Type
rep)
| [PrimRep
prep] <- [PrimRep]
preps
, Bool -> Bool
not (PrimRep -> Bool
isVoidRep PrimRep
prep)
= forall a. Maybe a
Nothing
| Bool
otherwise
= forall a. a -> Maybe a
Just [ Literal -> OutStgArg
StgLitArg (Type -> Literal
LitRubbish (PrimRep -> Type
primRepToRuntimeRep PrimRep
prep))
| PrimRep
prep <- [PrimRep]
preps, Bool -> Bool
not (PrimRep -> Bool
isVoidRep PrimRep
prep) ]
where
preps :: [PrimRep]
preps = HasDebugCallStack => SDoc -> Type -> [PrimRep]
runtimeRepPrimRep (String -> SDoc
text String
"unariseRubbish_maybe") Type
rep
unariseRubbish_maybe Literal
_ = forall a. Maybe a
Nothing
elimCase :: UnariseEnv
-> [OutStgArg]
-> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
elimCase :: UnariseEnv
-> [OutStgArg]
-> InId
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [OutStgArg]
args InId
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 -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
bndr ([OutStgArg] -> UnariseVal
MultiVal [OutStgArg]
args)
rho2 :: UnariseEnv
rho2
| InId -> Bool
isUnboxedTupleBndr InId
bndr
= [InId] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapTupleIdBinders [BinderP 'Vanilla]
bndrs [OutStgArg]
args UnariseEnv
rho1
| Bool
otherwise
= forall a. HasCallStack => Bool -> a -> a
assert (InId -> Bool
isUnboxedSumBndr InId
bndr) forall a b. (a -> b) -> a -> b
$
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BinderP 'Vanilla]
bndrs then UnariseEnv
rho1
else [InId] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapSumIdBinders [BinderP 'Vanilla]
bndrs [OutStgArg]
args UnariseEnv
rho1
UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho2 GenStgExpr 'Vanilla
rhs
elimCase UnariseEnv
rho [OutStgArg]
args InId
bndr (MultiValAlt Int
_) [GenStgAlt 'Vanilla]
alts
| InId -> Bool
isUnboxedSumBndr InId
bndr
= do let (OutStgArg
tag_arg : [OutStgArg]
real_args) = [OutStgArg]
args
InId
tag_bndr <- FastString -> Type -> UniqSM InId
mkId (String -> FastString
mkFastString String
"tag") Type
tagTy
let rho1 :: UnariseEnv
rho1 = UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
bndr ([OutStgArg] -> UnariseVal
MultiVal [OutStgArg]
args)
scrut' :: GenStgExpr 'Vanilla
scrut' = case OutStgArg
tag_arg of
StgVarArg InId
v -> forall (pass :: StgPass). InId -> [OutStgArg] -> GenStgExpr pass
StgApp InId
v []
StgLitArg Literal
l -> forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
l
[GenStgAlt 'Vanilla]
alts' <- UnariseEnv
-> [OutStgArg]
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseSumAlts UnariseEnv
rho1 [OutStgArg]
real_args [GenStgAlt 'Vanilla]
alts
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase GenStgExpr 'Vanilla
scrut' InId
tag_bndr AltType
tagAltTy [GenStgAlt 'Vanilla]
alts')
elimCase UnariseEnv
_ [OutStgArg]
args InId
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"elimCase - unhandled case"
(forall a. Outputable a => a -> SDoc
ppr [OutStgArg]
args SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr InId
bndr SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr AltType
alt_ty SDoc -> SDoc -> SDoc
$$ forall (pass :: StgPass).
OutputablePass pass =>
[GenStgAlt pass] -> SDoc
pprPanicAlts [GenStgAlt 'Vanilla]
alts)
unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
unariseAlts :: UnariseEnv
-> AltType
-> InId
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseAlts UnariseEnv
rho (MultiValAlt Int
n) InId
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}]
| InId -> Bool
isUnboxedTupleBndr InId
bndr
= do (UnariseEnv
rho', [InId]
ys) <- UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseConArgBinder UnariseEnv
rho InId
bndr
!GenStgExpr 'Vanilla
e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho' GenStgExpr 'Vanilla
e
forall (m :: * -> *) a. Monad m => a -> m a
return [forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed Int
n)) [InId]
ys GenStgExpr 'Vanilla
e']
unariseAlts UnariseEnv
rho (MultiValAlt Int
n) InId
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}]
| InId -> Bool
isUnboxedTupleBndr InId
bndr
= do (UnariseEnv
rho', [InId]
ys1) <- UnariseEnv -> [InId] -> UniqSM (UnariseEnv, [InId])
unariseConArgBinders UnariseEnv
rho [BinderP 'Vanilla]
ys
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([InId]
ys1 forall a. [a] -> Int -> Bool
`lengthIs` Int
n)
let rho'' :: UnariseEnv
rho'' = UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho' InId
bndr ([OutStgArg] -> UnariseVal
MultiVal (forall a b. (a -> b) -> [a] -> [b]
map InId -> OutStgArg
StgVarArg [InId]
ys1))
!GenStgExpr 'Vanilla
e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho'' GenStgExpr 'Vanilla
e
forall (m :: * -> *) a. Monad m => a -> m a
return [forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed Int
n)) [InId]
ys1 GenStgExpr 'Vanilla
e']
unariseAlts UnariseEnv
_ (MultiValAlt Int
_) InId
bndr [GenStgAlt 'Vanilla]
alts
| InId -> Bool
isUnboxedTupleBndr InId
bndr
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseExpr: strange multi val alts" (forall (pass :: StgPass).
OutputablePass pass =>
[GenStgAlt pass] -> SDoc
pprPanicAlts [GenStgAlt 'Vanilla]
alts)
unariseAlts UnariseEnv
rho (MultiValAlt Int
_) InId
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}]
| InId -> Bool
isUnboxedSumBndr InId
bndr
= do (UnariseEnv
rho_sum_bndrs, [InId]
sum_bndrs) <- UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseConArgBinder UnariseEnv
rho InId
bndr
GenStgExpr 'Vanilla
rhs' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho_sum_bndrs GenStgExpr 'Vanilla
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return [forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed (forall (t :: * -> *) a. Foldable t => t a -> Int
length [InId]
sum_bndrs))) [InId]
sum_bndrs GenStgExpr 'Vanilla
rhs']
unariseAlts UnariseEnv
rho (MultiValAlt Int
_) InId
bndr [GenStgAlt 'Vanilla]
alts
| InId -> Bool
isUnboxedSumBndr InId
bndr
= do (UnariseEnv
rho_sum_bndrs, scrt_bndrs :: [InId]
scrt_bndrs@(InId
tag_bndr : [InId]
real_bndrs)) <- UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseConArgBinder UnariseEnv
rho InId
bndr
[GenStgAlt 'Vanilla]
alts' <- UnariseEnv
-> [OutStgArg]
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseSumAlts UnariseEnv
rho_sum_bndrs (forall a b. (a -> b) -> [a] -> [b]
map InId -> OutStgArg
StgVarArg [InId]
real_bndrs) [GenStgAlt 'Vanilla]
alts
let inner_case :: GenStgExpr 'Vanilla
inner_case = forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase (forall (pass :: StgPass). InId -> [OutStgArg] -> GenStgExpr pass
StgApp InId
tag_bndr []) InId
tag_bndr AltType
tagAltTy [GenStgAlt 'Vanilla]
alts'
forall (m :: * -> *) a. Monad m => a -> m a
return [GenStgAlt{ alt_con :: AltCon
alt_con = DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed (forall (t :: * -> *) a. Foldable t => t a -> Int
length [InId]
scrt_bndrs))
, alt_bndrs :: [BinderP 'Vanilla]
alt_bndrs = [InId]
scrt_bndrs
, alt_rhs :: GenStgExpr 'Vanilla
alt_rhs = GenStgExpr 'Vanilla
inner_case
}]
unariseAlts UnariseEnv
rho AltType
_ InId
_ [GenStgAlt 'Vanilla]
alts
= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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', [InId]
xs') <- UnariseEnv -> [InId] -> UniqSM (UnariseEnv, [InId])
unariseConArgBinders UnariseEnv
rho [BinderP 'Vanilla]
xs
!GenStgExpr 'Vanilla
e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho' GenStgExpr 'Vanilla
e
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! GenStgAlt 'Vanilla
alt {alt_bndrs :: [BinderP 'Vanilla]
alt_bndrs = [InId]
xs', alt_rhs :: GenStgExpr 'Vanilla
alt_rhs = GenStgExpr 'Vanilla
e'}
unariseSumAlts :: UnariseEnv
-> [StgArg]
-> [StgAlt]
-> UniqSM [StgAlt]
unariseSumAlts :: UnariseEnv
-> [OutStgArg]
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseSumAlts UnariseEnv
env [OutStgArg]
args [GenStgAlt 'Vanilla]
alts
= do [GenStgAlt 'Vanilla]
alts' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (UnariseEnv
-> [OutStgArg] -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseSumAlt UnariseEnv
env [OutStgArg]
args) [GenStgAlt 'Vanilla]
alts
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
-> [OutStgArg] -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseSumAlt UnariseEnv
rho [OutStgArg]
_ 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}
= forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt AltCon
DEFAULT forall a. Monoid a => a
mempty 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 [OutStgArg]
args 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 let rho' :: UnariseEnv
rho' = [InId] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapSumIdBinders [BinderP 'Vanilla]
bs [OutStgArg]
args UnariseEnv
rho
lit_case :: AltCon
lit_case = Literal -> AltCon
LitAlt (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral (DataCon -> Int
dataConTag DataCon
sumCon)))
forall (pass :: StgPass).
AltCon -> [BinderP pass] -> GenStgExpr pass -> GenStgAlt pass
GenStgAlt AltCon
lit_case forall a. Monoid a => a
mempty 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
_ [OutStgArg]
scrt GenStgAlt 'Vanilla
alt
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseSumAlt" (forall a. Outputable a => a -> SDoc
ppr [OutStgArg]
scrt SDoc -> SDoc -> SDoc
$$ forall (pass :: StgPass).
OutputablePass pass =>
GenStgAlt pass -> SDoc
pprPanicAlt GenStgAlt 'Vanilla
alt)
mapTupleIdBinders
:: [InId]
-> [OutStgArg]
-> UnariseEnv
-> UnariseEnv
mapTupleIdBinders :: [InId] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapTupleIdBinders [InId]
ids [OutStgArg]
args0 UnariseEnv
rho0
= forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HasDebugCallStack => Type -> Bool
isZeroBitTy forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutStgArg -> Type
stgArgType) [OutStgArg]
args0)) forall a b. (a -> b) -> a -> b
$
let
ids_unarised :: [(Id, [PrimRep])]
ids_unarised :: [(InId, [PrimRep])]
ids_unarised = forall a b. (a -> b) -> [a] -> [b]
map (\InId
id -> (InId
id, HasDebugCallStack => Type -> [PrimRep]
typePrimRep (InId -> Type
idType InId
id))) [InId]
ids
map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
map_ids :: UnariseEnv -> [(InId, [PrimRep])] -> [OutStgArg] -> UnariseEnv
map_ids UnariseEnv
rho [] [OutStgArg]
_ = UnariseEnv
rho
map_ids UnariseEnv
rho ((InId
x, [PrimRep]
x_reps) : [(InId, [PrimRep])]
xs) [OutStgArg]
args =
let
x_arity :: Int
x_arity = forall (t :: * -> *) a. Foldable t => t a -> Int
length [PrimRep]
x_reps
([OutStgArg]
x_args, [OutStgArg]
args') =
forall a. HasCallStack => Bool -> a -> a
assert ([OutStgArg]
args forall a. [a] -> Int -> Bool
`lengthAtLeast` Int
x_arity)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
x_arity [OutStgArg]
args
rho' :: UnariseEnv
rho'
| Int
x_arity forall a. Eq a => a -> a -> Bool
== Int
1
= forall a. HasCallStack => Bool -> a -> a
assert ([OutStgArg]
x_args forall a. [a] -> Int -> Bool
`lengthIs` Int
1)
UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
x (OutStgArg -> UnariseVal
UnaryVal (forall a. [a] -> a
head [OutStgArg]
x_args))
| Bool
otherwise
= UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
x ([OutStgArg] -> UnariseVal
MultiVal [OutStgArg]
x_args)
in
UnariseEnv -> [(InId, [PrimRep])] -> [OutStgArg] -> UnariseEnv
map_ids UnariseEnv
rho' [(InId, [PrimRep])]
xs [OutStgArg]
args'
in
UnariseEnv -> [(InId, [PrimRep])] -> [OutStgArg] -> UnariseEnv
map_ids UnariseEnv
rho0 [(InId, [PrimRep])]
ids_unarised [OutStgArg]
args0
mapSumIdBinders
:: [InId]
-> [OutStgArg]
-> UnariseEnv
-> UnariseEnv
mapSumIdBinders :: [InId] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapSumIdBinders [InId
id] [OutStgArg]
args UnariseEnv
rho0
= forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HasDebugCallStack => Type -> Bool
isZeroBitTy forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutStgArg -> Type
stgArgType) [OutStgArg]
args)) forall a b. (a -> b) -> a -> b
$
let
arg_slots :: [SlotTy]
arg_slots = forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> SlotTy
primRepSlot forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HasDebugCallStack => Type -> [PrimRep]
typePrimRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutStgArg -> Type
stgArgType) [OutStgArg]
args
id_slots :: [SlotTy]
id_slots = forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> SlotTy
primRepSlot forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> [PrimRep]
typePrimRep (InId -> Type
idType InId
id)
layout1 :: [Int]
layout1 = [SlotTy] -> [SlotTy] -> [Int]
layoutUbxSum [SlotTy]
arg_slots [SlotTy]
id_slots
in
if InId -> Bool
isMultiValBndr InId
id
then UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho0 InId
id ([OutStgArg] -> UnariseVal
MultiVal [ [OutStgArg]
args forall a. [a] -> Int -> a
!! Int
i | Int
i <- [Int]
layout1 ])
else forall a. HasCallStack => Bool -> a -> a
assert ([Int]
layout1 forall a. [a] -> Int -> Bool
`lengthIs` Int
1)
UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho0 InId
id (OutStgArg -> UnariseVal
UnaryVal ([OutStgArg]
args forall a. [a] -> Int -> a
!! forall a. [a] -> a
head [Int]
layout1))
mapSumIdBinders [InId]
ids [OutStgArg]
sum_args UnariseEnv
_
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mapSumIdBinders" (forall a. Outputable a => a -> SDoc
ppr [InId]
ids SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [OutStgArg]
sum_args)
mkUbxSum
:: DataCon
-> [Type]
-> [OutStgArg]
-> [OutStgArg]
mkUbxSum :: DataCon -> [Type] -> [OutStgArg] -> [OutStgArg]
mkUbxSum DataCon
dc [Type]
ty_args [OutStgArg]
args0
= let
(SlotTy
_ : [SlotTy]
sum_slots) = [[PrimRep]] -> [SlotTy]
ubxSumRepType (forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Type -> [PrimRep]
typePrimRep [Type]
ty_args)
tag :: Int
tag = DataCon -> Int
dataConTag DataCon
dc
layout' :: [Int]
layout' = [SlotTy] -> [SlotTy] -> [Int]
layoutUbxSum [SlotTy]
sum_slots (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Type -> Maybe SlotTy
typeSlotTy forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutStgArg -> Type
stgArgType) [OutStgArg]
args0)
tag_arg :: OutStgArg
tag_arg = Literal -> OutStgArg
StgLitArg (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tag))
arg_idxs :: IntMap OutStgArg
arg_idxs = forall a. [(Int, a)] -> IntMap a
IM.fromList (forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"mkUbxSum" [Int]
layout' [OutStgArg]
args0)
mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
mkTupArgs :: Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
mkTupArgs Int
_ [] IntMap OutStgArg
_
= []
mkTupArgs Int
arg_idx (SlotTy
slot : [SlotTy]
slots_left) IntMap OutStgArg
arg_map
| Just OutStgArg
stg_arg <- forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
arg_idx IntMap OutStgArg
arg_map
= OutStgArg
stg_arg forall a. a -> [a] -> [a]
: Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
mkTupArgs (Int
arg_idx forall a. Num a => a -> a -> a
+ Int
1) [SlotTy]
slots_left IntMap OutStgArg
arg_map
| Bool
otherwise
= SlotTy -> OutStgArg
ubxSumRubbishArg SlotTy
slot forall a. a -> [a] -> [a]
: Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
mkTupArgs (Int
arg_idx forall a. Num a => a -> a -> a
+ Int
1) [SlotTy]
slots_left IntMap OutStgArg
arg_map
in
OutStgArg
tag_arg forall a. a -> [a] -> [a]
: Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
mkTupArgs Int
0 [SlotTy]
sum_slots IntMap OutStgArg
arg_idxs
ubxSumRubbishArg :: SlotTy -> StgArg
ubxSumRubbishArg :: SlotTy -> OutStgArg
ubxSumRubbishArg SlotTy
PtrLiftedSlot = InId -> OutStgArg
StgVarArg InId
aBSENT_SUM_FIELD_ERROR_ID
ubxSumRubbishArg SlotTy
PtrUnliftedSlot = InId -> OutStgArg
StgVarArg InId
aBSENT_SUM_FIELD_ERROR_ID
ubxSumRubbishArg SlotTy
WordSlot = Literal -> OutStgArg
StgLitArg (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumWord Integer
0)
ubxSumRubbishArg SlotTy
Word64Slot = Literal -> OutStgArg
StgLitArg (LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumWord64 Integer
0)
ubxSumRubbishArg SlotTy
FloatSlot = Literal -> OutStgArg
StgLitArg (Rational -> Literal
LitFloat Rational
0)
ubxSumRubbishArg SlotTy
DoubleSlot = Literal -> OutStgArg
StgLitArg (Rational -> Literal
LitDouble Rational
0)
ubxSumRubbishArg (VecSlot Int
n PrimElemRep
e) = Literal -> OutStgArg
StgLitArg (Type -> Literal
LitRubbish 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 -> InId -> UniqSM (UnariseEnv, [InId])
unariseArgBinder Bool
is_con_arg UnariseEnv
rho InId
x =
case HasDebugCallStack => Type -> [PrimRep]
typePrimRep (InId -> Type
idType InId
x) of
[]
| Bool
is_con_arg
-> forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
x ([OutStgArg] -> UnariseVal
MultiVal []), [])
| Bool
otherwise
-> forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
x ([OutStgArg] -> UnariseVal
MultiVal []), [InId
voidArgId])
[PrimRep
rep]
| Type -> Bool
isUnboxedSumType (InId -> Type
idType InId
x) Bool -> Bool -> Bool
|| Type -> Bool
isUnboxedTupleType (InId -> Type
idType InId
x)
-> do InId
x' <- FastString -> Type -> UniqSM InId
mkId (String -> FastString
mkFastString String
"us") (PrimRep -> Type
primRepToType PrimRep
rep)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
x ([OutStgArg] -> UnariseVal
MultiVal [InId -> OutStgArg
StgVarArg InId
x']), [InId
x'])
| Bool
otherwise
-> forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> InId -> UnariseEnv
extendRhoWithoutValue UnariseEnv
rho InId
x, [InId
x])
[PrimRep]
reps -> do
[InId]
xs <- FastString -> [Type] -> UniqSM [InId]
mkIds (String -> FastString
mkFastString String
"us") (forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> Type
primRepToType [PrimRep]
reps)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> InId -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho InId
x ([OutStgArg] -> UnariseVal
MultiVal (forall a b. (a -> b) -> [a] -> [b]
map InId -> OutStgArg
StgVarArg [InId]
xs)), [InId]
xs)
unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
unariseFunArg :: UnariseEnv -> OutStgArg -> [OutStgArg]
unariseFunArg UnariseEnv
rho (StgVarArg InId
x) =
case forall a. VarEnv a -> InId -> Maybe a
lookupVarEnv UnariseEnv
rho InId
x of
Just (MultiVal []) -> [OutStgArg
voidArg]
Just (MultiVal [OutStgArg]
as) -> [OutStgArg]
as
Just (UnaryVal OutStgArg
arg) -> [OutStgArg
arg]
Maybe UnariseVal
Nothing -> [InId -> OutStgArg
StgVarArg InId
x]
unariseFunArg UnariseEnv
_ OutStgArg
arg = [OutStgArg
arg]
unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
unariseFunArgs :: UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseFunArgs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnariseEnv -> OutStgArg -> [OutStgArg]
unariseFunArg
unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinders :: UnariseEnv -> [InId] -> UniqSM (UnariseEnv, [InId])
unariseFunArgBinders UnariseEnv
rho [InId]
xs = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseFunArgBinder UnariseEnv
rho [InId]
xs
unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseFunArgBinder :: UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseFunArgBinder = Bool -> UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseArgBinder Bool
False
unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]
unariseConArg :: UnariseEnv -> OutStgArg -> [OutStgArg]
unariseConArg UnariseEnv
rho (StgVarArg InId
x) =
case forall a. VarEnv a -> InId -> Maybe a
lookupVarEnv UnariseEnv
rho InId
x of
Just (UnaryVal OutStgArg
arg) -> [OutStgArg
arg]
Just (MultiVal [OutStgArg]
as) -> [OutStgArg]
as
Maybe UnariseVal
Nothing
| HasDebugCallStack => Type -> Bool
isZeroBitTy (InId -> Type
idType InId
x) -> []
| Bool
otherwise -> [InId -> OutStgArg
StgVarArg InId
x]
unariseConArg UnariseEnv
_ arg :: OutStgArg
arg@(StgLitArg Literal
lit)
| Just [OutStgArg]
as <- Literal -> Maybe [OutStgArg]
unariseRubbish_maybe Literal
lit
= [OutStgArg]
as
| Bool
otherwise
= forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (HasDebugCallStack => Type -> Bool
isZeroBitTy (Literal -> Type
literalType Literal
lit)))
[OutStgArg
arg]
unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
unariseConArgs :: UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseConArgs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnariseEnv -> OutStgArg -> [OutStgArg]
unariseConArg
unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseConArgBinders :: UnariseEnv -> [InId] -> UniqSM (UnariseEnv, [InId])
unariseConArgBinders UnariseEnv
rho [InId]
xs = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseConArgBinder UnariseEnv
rho [InId]
xs
unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseConArgBinder :: UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseConArgBinder = Bool -> UnariseEnv -> InId -> UniqSM (UnariseEnv, [InId])
unariseArgBinder Bool
True
mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
mkIds :: FastString -> [Type] -> UniqSM [InId]
mkIds FastString
fs [Type]
tys = forall (m :: * -> *).
MonadUnique m =>
FastString -> [Type] -> m [InId]
mkUnarisedIds FastString
fs [Type]
tys
mkId :: FastString -> UnaryType -> UniqSM Id
mkId :: FastString -> Type -> UniqSM InId
mkId FastString
s Type
t = forall (m :: * -> *). MonadUnique m => FastString -> Type -> m InId
mkUnarisedId FastString
s Type
t
isMultiValBndr :: Id -> Bool
isMultiValBndr :: InId -> Bool
isMultiValBndr InId
id
| [PrimRep
_] <- HasDebugCallStack => Type -> [PrimRep]
typePrimRep (InId -> Type
idType InId
id)
= Bool
False
| Bool
otherwise
= Bool
True
isUnboxedSumBndr :: Id -> Bool
isUnboxedSumBndr :: InId -> Bool
isUnboxedSumBndr = Type -> Bool
isUnboxedSumType forall b c a. (b -> c) -> (a -> b) -> a -> c
. InId -> Type
idType
isUnboxedTupleBndr :: Id -> Bool
isUnboxedTupleBndr :: InId -> Bool
isUnboxedTupleBndr = Type -> Bool
isUnboxedTupleType forall b c a. (b -> c) -> (a -> b) -> a -> c
. InId -> Type
idType
mkTuple :: [StgArg] -> StgExpr
mkTuple :: [OutStgArg] -> GenStgExpr 'Vanilla
mkTuple [OutStgArg]
args = forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [OutStgArg] -> [Type] -> GenStgExpr pass
StgConApp (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed (forall (t :: * -> *) a. Foldable t => t a -> Int
length [OutStgArg]
args)) ConstructorNumber
NoNumber [OutStgArg]
args (forall a b. (a -> b) -> [a] -> [b]
map OutStgArg -> Type
stgArgType [OutStgArg]
args)
tagAltTy :: AltType
tagAltTy :: AltType
tagAltTy = PrimRep -> AltType
PrimAlt PrimRep
IntRep
tagTy :: Type
tagTy :: Type
tagTy = Type
intPrimTy
voidArg :: StgArg
voidArg :: OutStgArg
voidArg = InId -> OutStgArg
StgVarArg InId
voidPrimId
mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
mkDefaultLitAlt :: [GenStgAlt 'Vanilla] -> [GenStgAlt 'Vanilla]
mkDefaultLitAlt [] = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"elimUbxSumExpr.mkDefaultAlt" (String -> SDoc
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 :: AltCon
alt_con = AltCon
DEFAULT} forall a. a -> [a] -> [a]
: [GenStgAlt 'Vanilla]
alts
mkDefaultLitAlt [GenStgAlt 'Vanilla]
alts = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkDefaultLitAlt" (String -> SDoc
text String
"Not a lit alt:" SDoc -> SDoc -> 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 = forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map 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} = forall a. Outputable a => a -> SDoc
ppr (AltCon
c,[BinderP pass]
b,forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts GenStgExpr pass
e)