{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Stg.Unarise (unarise) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Types.Basic
import GHC.Core
import GHC.Core.DataCon
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.Types.RepType
import GHC.Stg.Syntax
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
<+> [OutStgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [OutStgArg]
args
ppr (UnaryVal OutStgArg
arg) = String -> SDoc
text String
"UnaryVal" SDoc -> SDoc -> SDoc
<+> OutStgArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutStgArg
arg
extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x (MultiVal [OutStgArg]
args)
= ASSERT(all (isNvUnaryType . stgArgType) args)
UnariseEnv -> Id -> UnariseVal -> UnariseEnv
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv UnariseEnv
rho Id
x ([OutStgArg] -> UnariseVal
MultiVal [OutStgArg]
args)
extendRho UnariseEnv
rho Id
x (UnaryVal OutStgArg
val)
= ASSERT(isNvUnaryType (stgArgType val))
UnariseEnv -> Id -> UnariseVal -> UnariseEnv
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv UnariseEnv
rho Id
x (OutStgArg -> UnariseVal
UnaryVal OutStgArg
val)
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)
mapM (UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
unariseTopBinding UnariseEnv
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 (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
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)
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 (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 [OutStgArg]
args)
= ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
GenStgRhs 'Vanilla -> UniqSM (GenStgRhs 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
return (CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [OutStgArg]
-> GenStgRhs 'Vanilla
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 Id
f [])
= case UnariseEnv -> Id -> Maybe UnariseVal
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv UnariseEnv
rho Id
f of
Just (MultiVal [OutStgArg]
args)
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
return ([OutStgArg] -> GenStgExpr 'Vanilla
mkTuple [OutStgArg]
args)
Just (UnaryVal (StgVarArg Id
f'))
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> [OutStgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [OutStgArg] -> GenStgExpr pass
StgApp Id
f' [])
Just (UnaryVal (StgLitArg Literal
f'))
-> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
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 (m :: * -> *) a. Monad m => a -> m a
return GenStgExpr 'Vanilla
e
unariseExpr UnariseEnv
rho e :: GenStgExpr 'Vanilla
e@(StgApp Id
f [OutStgArg]
args)
= GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> [OutStgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [OutStgArg] -> GenStgExpr pass
StgApp Id
f' (UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseFunArgs UnariseEnv
rho [OutStgArg]
args))
where
f' :: Id
f' = case UnariseEnv -> Id -> Maybe UnariseVal
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv 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
$$ Maybe UnariseVal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe UnariseVal
err)
unariseExpr UnariseEnv
_ (StgLit Literal
l)
= GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
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 XConApp 'Vanilla
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
= GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
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
= GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataCon
-> XConApp 'Vanilla -> [OutStgArg] -> [Type] -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
DataCon -> XConApp pass -> [OutStgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
dc XConApp 'Vanilla
n [OutStgArg]
args' ((OutStgArg -> Type) -> [OutStgArg] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map OutStgArg -> Type
stgArgType [OutStgArg]
args'))
unariseExpr UnariseEnv
rho (StgOpApp StgOp
op [OutStgArg]
args Type
ty)
= GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
return (StgOp -> [OutStgArg] -> Type -> GenStgExpr 'Vanilla
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 Id
v [] <- GenStgExpr 'Vanilla
scrut
, Just (MultiVal [OutStgArg]
xs) <- UnariseEnv -> Id -> Maybe UnariseVal
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv UnariseEnv
rho Id
v
= UnariseEnv
-> [OutStgArg]
-> Id
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [OutStgArg]
xs Id
BinderP 'Vanilla
bndr AltType
alt_ty [GenStgAlt 'Vanilla]
alts
| StgConApp DataCon
dc XConApp 'Vanilla
_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]
-> Id
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [OutStgArg]
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
[(AltCon, [Id], GenStgExpr '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 (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 [(AltCon, [Id], GenStgExpr 'Vanilla)]
[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 (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 (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
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
= [OutStgArg] -> Maybe [OutStgArg]
forall a. a -> Maybe a
Just (UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseConArgs UnariseEnv
rho [OutStgArg]
args)
| DataCon -> Bool
isUnboxedSumDataCon DataCon
dc
, let args1 :: [OutStgArg]
args1 = ASSERT(isSingleton args) (unariseConArgs rho args)
= [OutStgArg] -> Maybe [OutStgArg]
forall a. a -> Maybe a
Just (DataCon -> [Type] -> [OutStgArg] -> [OutStgArg]
mkUbxSum DataCon
dc [Type]
ty_args [OutStgArg]
args1)
| Bool
otherwise
= Maybe [OutStgArg]
forall a. Maybe a
Nothing
elimCase :: UnariseEnv
-> [OutStgArg]
-> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
elimCase :: UnariseEnv
-> [OutStgArg]
-> Id
-> AltType
-> [GenStgAlt 'Vanilla]
-> UniqSM (GenStgExpr 'Vanilla)
elimCase UnariseEnv
rho [OutStgArg]
args Id
bndr (MultiValAlt Int
_) [(AltCon
_, [BinderP 'Vanilla]
bndrs, GenStgExpr 'Vanilla
rhs)]
= do let rho1 :: UnariseEnv
rho1 = UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
bndr ([OutStgArg] -> UnariseVal
MultiVal [OutStgArg]
args)
rho2 :: UnariseEnv
rho2
| Id -> Bool
isUnboxedTupleBndr Id
bndr
= [Id] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapTupleIdBinders [Id]
[BinderP 'Vanilla]
bndrs [OutStgArg]
args UnariseEnv
rho1
| Bool
otherwise
= ASSERT(isUnboxedSumBndr bndr)
if [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
[BinderP 'Vanilla]
bndrs then UnariseEnv
rho1
else [Id] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapSumIdBinders [Id]
[BinderP 'Vanilla]
bndrs [OutStgArg]
args UnariseEnv
rho1
UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho2 GenStgExpr 'Vanilla
rhs
elimCase UnariseEnv
rho [OutStgArg]
args Id
bndr (MultiValAlt Int
_) [GenStgAlt 'Vanilla]
alts
| Id -> Bool
isUnboxedSumBndr Id
bndr
= do let (OutStgArg
tag_arg : [OutStgArg]
real_args) = [OutStgArg]
args
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 ([OutStgArg] -> UnariseVal
MultiVal [OutStgArg]
args)
scrut' :: GenStgExpr 'Vanilla
scrut' = case OutStgArg
tag_arg of
StgVarArg Id
v -> Id -> [OutStgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [OutStgArg] -> GenStgExpr pass
StgApp Id
v []
StgLitArg Literal
l -> Literal -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
l
[(AltCon, [Id], GenStgExpr 'Vanilla)]
alts' <- UnariseEnv
-> [OutStgArg]
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseSumAlts UnariseEnv
rho1 [OutStgArg]
real_args [GenStgAlt 'Vanilla]
alts
GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
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 [(AltCon, [Id], GenStgExpr 'Vanilla)]
[GenStgAlt 'Vanilla]
alts')
elimCase UnariseEnv
_ [OutStgArg]
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"
([OutStgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [OutStgArg]
args SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr SDoc -> SDoc -> SDoc
<+> AltType -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltType
alt_ty SDoc -> SDoc -> SDoc
$$ [(AltCon, [Id], GenStgExpr 'Vanilla)] -> SDoc
forall a b (pass :: StgPass).
(Outputable a, Outputable b, OutputablePass pass) =>
[(a, b, GenStgExpr pass)] -> SDoc
pprPanicAlts [(AltCon, [Id], GenStgExpr 'Vanilla)]
[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 [(AltCon
DEFAULT, [], 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
[(AltCon, [Id], GenStgExpr 'Vanilla)]
-> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed Int
n), [Id]
ys, GenStgExpr 'Vanilla
e')]
unariseAlts UnariseEnv
rho (MultiValAlt Int
n) Id
bndr [(DataAlt DataCon
_, [BinderP 'Vanilla]
ys, 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
MASSERT(ys1 `lengthIs` n)
let rho'' :: UnariseEnv
rho'' = UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho' Id
bndr ([OutStgArg] -> UnariseVal
MultiVal ((Id -> OutStgArg) -> [Id] -> [OutStgArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> OutStgArg
StgVarArg [Id]
ys1))
GenStgExpr 'Vanilla
e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho'' GenStgExpr 'Vanilla
e
[(AltCon, [Id], GenStgExpr 'Vanilla)]
-> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed Int
n), [Id]
ys1, GenStgExpr 'Vanilla
e')]
unariseAlts UnariseEnv
_ (MultiValAlt Int
_) Id
bndr [GenStgAlt 'Vanilla]
alts
| Id -> Bool
isUnboxedTupleBndr Id
bndr
= String -> SDoc -> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseExpr: strange multi val alts" ([(AltCon, [Id], GenStgExpr 'Vanilla)] -> SDoc
forall a b (pass :: StgPass).
(Outputable a, Outputable b, OutputablePass pass) =>
[(a, b, GenStgExpr pass)] -> SDoc
pprPanicAlts [(AltCon, [Id], GenStgExpr 'Vanilla)]
[GenStgAlt 'Vanilla]
alts)
unariseAlts UnariseEnv
rho (MultiValAlt Int
_) Id
bndr [(AltCon
DEFAULT, [BinderP 'Vanilla]
_, 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
[(AltCon, [Id], GenStgExpr 'Vanilla)]
-> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
sum_bndrs)), [Id]
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
[(AltCon, [Id], GenStgExpr 'Vanilla)]
alts' <- UnariseEnv
-> [OutStgArg]
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseSumAlts UnariseEnv
rho_sum_bndrs ((Id -> OutStgArg) -> [Id] -> [OutStgArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> OutStgArg
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 -> [OutStgArg] -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Id -> [OutStgArg] -> GenStgExpr pass
StgApp Id
tag_bndr []) Id
BinderP 'Vanilla
tag_bndr AltType
tagAltTy [(AltCon, [Id], GenStgExpr 'Vanilla)]
[GenStgAlt 'Vanilla]
alts'
[(AltCon, [Id], GenStgExpr 'Vanilla)]
-> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (DataCon -> AltCon
DataAlt (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
scrt_bndrs)),
[Id]
scrt_bndrs,
GenStgExpr 'Vanilla
inner_case) ]
unariseAlts UnariseEnv
rho AltType
_ Id
_ [GenStgAlt 'Vanilla]
alts
= ((AltCon, [Id], GenStgExpr 'Vanilla)
-> UniqSM (AltCon, [Id], GenStgExpr 'Vanilla))
-> [(AltCon, [Id], GenStgExpr 'Vanilla)]
-> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(AltCon, [Id], GenStgExpr 'Vanilla)
alt -> UnariseEnv -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseAlt UnariseEnv
rho (AltCon, [Id], GenStgExpr 'Vanilla)
GenStgAlt 'Vanilla
alt) [(AltCon, [Id], GenStgExpr 'Vanilla)]
[GenStgAlt 'Vanilla]
alts
unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
unariseAlt :: UnariseEnv -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseAlt UnariseEnv
rho (AltCon
con, [BinderP 'Vanilla]
xs, GenStgExpr 'Vanilla
e)
= do (UnariseEnv
rho', [Id]
xs') <- UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
unariseConArgBinders UnariseEnv
rho [Id]
[BinderP 'Vanilla]
xs
(AltCon
con, [Id]
xs',) (GenStgExpr 'Vanilla -> (AltCon, [Id], GenStgExpr 'Vanilla))
-> UniqSM (GenStgExpr 'Vanilla)
-> UniqSM (AltCon, [Id], 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
unariseSumAlts :: UnariseEnv
-> [StgArg]
-> [StgAlt]
-> UniqSM [StgAlt]
unariseSumAlts :: UnariseEnv
-> [OutStgArg]
-> [GenStgAlt 'Vanilla]
-> UniqSM [GenStgAlt 'Vanilla]
unariseSumAlts UnariseEnv
env [OutStgArg]
args [GenStgAlt 'Vanilla]
alts
= do [(AltCon, [Id], GenStgExpr 'Vanilla)]
alts' <- ((AltCon, [Id], GenStgExpr 'Vanilla)
-> UniqSM (AltCon, [Id], GenStgExpr 'Vanilla))
-> [(AltCon, [Id], GenStgExpr 'Vanilla)]
-> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
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) [(AltCon, [Id], GenStgExpr 'Vanilla)]
[GenStgAlt 'Vanilla]
alts
[(AltCon, [Id], GenStgExpr 'Vanilla)]
-> UniqSM [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenStgAlt 'Vanilla] -> [GenStgAlt 'Vanilla]
mkDefaultLitAlt [(AltCon, [Id], GenStgExpr 'Vanilla)]
[GenStgAlt 'Vanilla]
alts')
unariseSumAlt :: UnariseEnv
-> [StgArg]
-> StgAlt
-> UniqSM StgAlt
unariseSumAlt :: UnariseEnv
-> [OutStgArg] -> GenStgAlt 'Vanilla -> UniqSM (GenStgAlt 'Vanilla)
unariseSumAlt UnariseEnv
rho [OutStgArg]
_ (AltCon
DEFAULT, [BinderP 'Vanilla]
_, GenStgExpr 'Vanilla
e)
= ( AltCon
DEFAULT, [], ) (GenStgExpr 'Vanilla -> (AltCon, [Id], GenStgExpr 'Vanilla))
-> UniqSM (GenStgExpr 'Vanilla)
-> UniqSM (AltCon, [Id], 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
unariseSumAlt UnariseEnv
rho [OutStgArg]
args (DataAlt DataCon
sumCon, [BinderP 'Vanilla]
bs, GenStgExpr 'Vanilla
e)
= do let rho' :: UnariseEnv
rho' = [Id] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapSumIdBinders [Id]
[BinderP 'Vanilla]
bs [OutStgArg]
args UnariseEnv
rho
GenStgExpr 'Vanilla
e' <- UnariseEnv -> GenStgExpr 'Vanilla -> UniqSM (GenStgExpr 'Vanilla)
unariseExpr UnariseEnv
rho' GenStgExpr 'Vanilla
e
(AltCon, [Id], GenStgExpr 'Vanilla)
-> UniqSM (AltCon, [Id], GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
return ( 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))), [], GenStgExpr 'Vanilla
e' )
unariseSumAlt UnariseEnv
_ [OutStgArg]
scrt GenStgAlt 'Vanilla
alt
= String -> SDoc -> UniqSM (AltCon, [Id], GenStgExpr 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unariseSumAlt" ([OutStgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [OutStgArg]
scrt SDoc -> SDoc -> SDoc
$$ (AltCon, [Id], GenStgExpr 'Vanilla) -> SDoc
forall a b (pass :: StgPass).
(Outputable a, Outputable b, OutputablePass pass) =>
(a, b, GenStgExpr pass) -> SDoc
pprPanicAlt (AltCon, [Id], GenStgExpr 'Vanilla)
GenStgAlt 'Vanilla
alt)
mapTupleIdBinders
:: [InId]
-> [OutStgArg]
-> UnariseEnv
-> UnariseEnv
mapTupleIdBinders :: [Id] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapTupleIdBinders [Id]
ids [OutStgArg]
args0 UnariseEnv
rho0
= ASSERT(not (any (isVoidTy . stgArgType) args0))
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, HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
id))) [Id]
ids
map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [OutStgArg] -> UnariseEnv
map_ids UnariseEnv
rho [] [OutStgArg]
_ = UnariseEnv
rho
map_ids UnariseEnv
rho ((Id
x, [PrimRep]
x_reps) : [(Id, [PrimRep])]
xs) [OutStgArg]
args =
let
x_arity :: Int
x_arity = [PrimRep] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PrimRep]
x_reps
([OutStgArg]
x_args, [OutStgArg]
args') =
ASSERT(args `lengthAtLeast` x_arity)
Int -> [OutStgArg] -> ([OutStgArg], [OutStgArg])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
x_arity [OutStgArg]
args
rho' :: UnariseEnv
rho'
| Int
x_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
= ASSERT(x_args `lengthIs` 1)
UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x (OutStgArg -> UnariseVal
UnaryVal ([OutStgArg] -> OutStgArg
forall a. [a] -> a
head [OutStgArg]
x_args))
| Bool
otherwise
= UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x ([OutStgArg] -> UnariseVal
MultiVal [OutStgArg]
x_args)
in
UnariseEnv -> [(Id, [PrimRep])] -> [OutStgArg] -> UnariseEnv
map_ids UnariseEnv
rho' [(Id, [PrimRep])]
xs [OutStgArg]
args'
in
UnariseEnv -> [(Id, [PrimRep])] -> [OutStgArg] -> UnariseEnv
map_ids UnariseEnv
rho0 [(Id, [PrimRep])]
ids_unarised [OutStgArg]
args0
mapSumIdBinders
:: [InId]
-> [OutStgArg]
-> UnariseEnv
-> UnariseEnv
mapSumIdBinders :: [Id] -> [OutStgArg] -> UnariseEnv -> UnariseEnv
mapSumIdBinders [Id
id] [OutStgArg]
args UnariseEnv
rho0
= ASSERT(not (any (isVoidTy . stgArgType) args))
let
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
$ (OutStgArg -> [PrimRep]) -> [OutStgArg] -> [PrimRep]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Type -> [PrimRep])
-> (OutStgArg -> Type) -> OutStgArg -> [PrimRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutStgArg -> Type
stgArgType) [OutStgArg]
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
$ HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
id)
layout1 :: [Int]
layout1 = [SlotTy] -> [SlotTy] -> [Int]
layoutUbxSum [SlotTy]
arg_slots [SlotTy]
id_slots
in
if Id -> Bool
isMultiValBndr Id
id
then UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho0 Id
id ([OutStgArg] -> UnariseVal
MultiVal [ [OutStgArg]
args [OutStgArg] -> Int -> OutStgArg
forall a. [a] -> Int -> a
!! Int
i | Int
i <- [Int]
layout1 ])
else ASSERT(layout1 `lengthIs` 1)
UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho0 Id
id (OutStgArg -> UnariseVal
UnaryVal ([OutStgArg]
args [OutStgArg] -> Int -> OutStgArg
forall a. [a] -> Int -> a
!! [Int] -> Int
forall a. [a] -> a
head [Int]
layout1))
mapSumIdBinders [Id]
ids [OutStgArg]
sum_args UnariseEnv
_
= String -> SDoc -> UnariseEnv
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mapSumIdBinders" ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
ids SDoc -> SDoc -> SDoc
$$ [OutStgArg] -> 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 ((Type -> [PrimRep]) -> [Type] -> [[PrimRep]]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep [Type]
ty_args)
tag :: Int
tag = DataCon -> Int
dataConTag DataCon
dc
layout' :: [Int]
layout' = [SlotTy] -> [SlotTy] -> [Int]
layoutUbxSum [SlotTy]
sum_slots ((OutStgArg -> Maybe SlotTy) -> [OutStgArg] -> [SlotTy]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Type -> Maybe SlotTy
typeSlotTy (Type -> Maybe SlotTy)
-> (OutStgArg -> Type) -> OutStgArg -> Maybe SlotTy
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 (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tag))
arg_idxs :: IntMap OutStgArg
arg_idxs = [(Int, OutStgArg)] -> IntMap OutStgArg
forall a. [(Int, a)] -> IntMap a
IM.fromList (String -> [Int] -> [OutStgArg] -> [(Int, OutStgArg)]
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 <- Int -> IntMap OutStgArg -> Maybe OutStgArg
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
arg_idx IntMap OutStgArg
arg_map
= OutStgArg
stg_arg OutStgArg -> [OutStgArg] -> [OutStgArg]
forall a. a -> [a] -> [a]
: Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
mkTupArgs (Int
arg_idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [SlotTy]
slots_left IntMap OutStgArg
arg_map
| Bool
otherwise
= SlotTy -> OutStgArg
ubxSumRubbishArg SlotTy
slot OutStgArg -> [OutStgArg] -> [OutStgArg]
forall a. a -> [a] -> [a]
: Int -> [SlotTy] -> IntMap OutStgArg -> [OutStgArg]
mkTupArgs (Int
arg_idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [SlotTy]
slots_left IntMap OutStgArg
arg_map
in
OutStgArg
tag_arg OutStgArg -> [OutStgArg] -> [OutStgArg]
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 = Id -> OutStgArg
StgVarArg Id
aBSENT_SUM_FIELD_ERROR_ID
ubxSumRubbishArg SlotTy
PtrUnliftedSlot = Id -> OutStgArg
StgVarArg Id
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)
unariseArgBinder
:: Bool
-> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseArgBinder :: Bool -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
unariseArgBinder Bool
is_con_arg UnariseEnv
rho Id
x =
case HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (Id -> Type
idType Id
x) of
[]
| Bool
is_con_arg
-> (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x ([OutStgArg] -> UnariseVal
MultiVal []), [])
| Bool
otherwise
-> (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x ([OutStgArg] -> 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 (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x ([OutStgArg] -> UnariseVal
MultiVal [Id -> OutStgArg
StgVarArg Id
x']), [Id
x'])
| Bool
otherwise
-> (UnariseEnv, [Id]) -> UniqSM (UnariseEnv, [Id])
forall (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv
rho, [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 (m :: * -> *) a. Monad m => a -> m a
return (UnariseEnv -> Id -> UnariseVal -> UnariseEnv
extendRho UnariseEnv
rho Id
x ([OutStgArg] -> UnariseVal
MultiVal ((Id -> OutStgArg) -> [Id] -> [OutStgArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> OutStgArg
StgVarArg [Id]
xs)), [Id]
xs)
unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
unariseFunArg :: UnariseEnv -> OutStgArg -> [OutStgArg]
unariseFunArg UnariseEnv
rho (StgVarArg Id
x) =
case UnariseEnv -> Id -> Maybe UnariseVal
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv UnariseEnv
rho Id
x of
Just (MultiVal []) -> [OutStgArg
voidArg]
Just (MultiVal [OutStgArg]
as) -> [OutStgArg]
as
Just (UnaryVal OutStgArg
arg) -> [OutStgArg
arg]
Maybe UnariseVal
Nothing -> [Id -> OutStgArg
StgVarArg Id
x]
unariseFunArg UnariseEnv
_ OutStgArg
arg = [OutStgArg
arg]
unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
unariseFunArgs :: UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseFunArgs = (OutStgArg -> [OutStgArg]) -> [OutStgArg] -> [OutStgArg]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((OutStgArg -> [OutStgArg]) -> [OutStgArg] -> [OutStgArg])
-> (UnariseEnv -> OutStgArg -> [OutStgArg])
-> UnariseEnv
-> [OutStgArg]
-> [OutStgArg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnariseEnv -> OutStgArg -> [OutStgArg]
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 (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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [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 -> OutStgArg -> [OutStgArg]
unariseConArg UnariseEnv
rho (StgVarArg Id
x) =
case UnariseEnv -> Id -> Maybe UnariseVal
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv UnariseEnv
rho Id
x of
Just (UnaryVal OutStgArg
arg) -> [OutStgArg
arg]
Just (MultiVal [OutStgArg]
as) -> [OutStgArg]
as
Maybe UnariseVal
Nothing
| Type -> Bool
isVoidTy (Id -> Type
idType Id
x) -> []
| Bool
otherwise -> [Id -> OutStgArg
StgVarArg Id
x]
unariseConArg UnariseEnv
_ arg :: OutStgArg
arg@(StgLitArg Literal
lit) =
ASSERT(not (isVoidTy (literalType lit)))
[OutStgArg
arg]
unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
unariseConArgs :: UnariseEnv -> [OutStgArg] -> [OutStgArg]
unariseConArgs = (OutStgArg -> [OutStgArg]) -> [OutStgArg] -> [OutStgArg]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((OutStgArg -> [OutStgArg]) -> [OutStgArg] -> [OutStgArg])
-> (UnariseEnv -> OutStgArg -> [OutStgArg])
-> UnariseEnv
-> [OutStgArg]
-> [OutStgArg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnariseEnv -> OutStgArg -> [OutStgArg]
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 (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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [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 = (Type -> UniqSM Id) -> [Type] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FastString -> Type -> UniqSM Id
mkId FastString
fs) [Type]
tys
mkId :: FastString -> UnaryType -> UniqSM Id
mkId :: FastString -> Type -> UniqSM Id
mkId FastString
s Type
t = FastString -> Type -> Type -> UniqSM Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m Id
mkSysLocalM FastString
s Type
Many Type
t
isMultiValBndr :: Id -> Bool
isMultiValBndr :: Id -> Bool
isMultiValBndr Id
id
| [PrimRep
_] <- HasDebugCallStack => 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 :: [OutStgArg] -> GenStgExpr 'Vanilla
mkTuple [OutStgArg]
args = DataCon
-> XConApp 'Vanilla -> [OutStgArg] -> [Type] -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
DataCon -> XConApp pass -> [OutStgArg] -> [Type] -> GenStgExpr pass
StgConApp (Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([OutStgArg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [OutStgArg]
args)) ConstructorNumber
XConApp 'Vanilla
NoNumber [OutStgArg]
args ((OutStgArg -> Type) -> [OutStgArg] -> [Type]
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 = Id -> OutStgArg
StgVarArg Id
voidPrimId
mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
mkDefaultLitAlt :: [GenStgAlt 'Vanilla] -> [GenStgAlt 'Vanilla]
mkDefaultLitAlt [] = String -> SDoc -> [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"elimUbxSumExpr.mkDefaultAlt" (String -> SDoc
text String
"Empty alts")
mkDefaultLitAlt alts :: [GenStgAlt 'Vanilla]
alts@((AltCon
DEFAULT, [BinderP 'Vanilla]
_, GenStgExpr 'Vanilla
_) : [GenStgAlt 'Vanilla]
_) = [GenStgAlt 'Vanilla]
alts
mkDefaultLitAlt ((LitAlt{}, [], GenStgExpr 'Vanilla
rhs) : [GenStgAlt 'Vanilla]
alts) = (AltCon
DEFAULT, [], GenStgExpr 'Vanilla
rhs) (AltCon, [Id], GenStgExpr 'Vanilla)
-> [(AltCon, [Id], GenStgExpr 'Vanilla)]
-> [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall a. a -> [a] -> [a]
: [(AltCon, [Id], GenStgExpr 'Vanilla)]
[GenStgAlt 'Vanilla]
alts
mkDefaultLitAlt [GenStgAlt 'Vanilla]
alts = String -> SDoc -> [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkDefaultLitAlt" (String -> SDoc
text String
"Not a lit alt:" SDoc -> SDoc -> SDoc
<+> [(AltCon, [Id], GenStgExpr 'Vanilla)] -> SDoc
forall a b (pass :: StgPass).
(Outputable a, Outputable b, OutputablePass pass) =>
[(a, b, GenStgExpr pass)] -> SDoc
pprPanicAlts [(AltCon, [Id], GenStgExpr 'Vanilla)]
[GenStgAlt 'Vanilla]
alts)
pprPanicAlts :: (Outputable a, Outputable b, OutputablePass pass) => [(a,b,GenStgExpr pass)] -> SDoc
pprPanicAlts :: forall a b (pass :: StgPass).
(Outputable a, Outputable b, OutputablePass pass) =>
[(a, b, GenStgExpr pass)] -> SDoc
pprPanicAlts [(a, b, GenStgExpr pass)]
alts = [SDoc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (((a, b, GenStgExpr pass) -> SDoc)
-> [(a, b, GenStgExpr pass)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (a, b, GenStgExpr pass) -> SDoc
forall a b (pass :: StgPass).
(Outputable a, Outputable b, OutputablePass pass) =>
(a, b, GenStgExpr pass) -> SDoc
pprPanicAlt [(a, b, GenStgExpr pass)]
alts)
pprPanicAlt :: (Outputable a, Outputable b, OutputablePass pass) => (a,b,GenStgExpr pass) -> SDoc
pprPanicAlt :: forall a b (pass :: StgPass).
(Outputable a, Outputable b, OutputablePass pass) =>
(a, b, GenStgExpr pass) -> SDoc
pprPanicAlt (a
c,b
b,GenStgExpr pass
e) = (a, b, SDoc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (a
c,b
b,StgPprOpts -> GenStgExpr pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> GenStgExpr pass -> SDoc
pprStgExpr StgPprOpts
panicStgPprOpts GenStgExpr pass
e)