{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
module StgSyn (
StgArg(..),
GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
GenStgAlt, AltType(..),
StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,
NoExtFieldSilent, noExtFieldSilent,
OutputablePass,
UpdateFlag(..), isUpdatable,
StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt,
CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt,
LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt,
InStgArg, InStgTopBinding, InStgBinding, InStgExpr, InStgRhs, InStgAlt,
OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt,
StgOp(..),
topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
isDllConApp,
stgArgType,
stripStgTicksTop, stripStgTicksTopE,
stgCaseBndrInScope,
pprStgBinding, pprGenStgTopBindings, pprStgTopBindings
) where
#include "HsVersions.h"
import GhcPrelude
import CoreSyn ( AltCon, Tickish )
import CostCentre ( CostCentreStack )
import Data.ByteString ( ByteString )
import Data.Data ( Data )
import Data.List ( intersperse )
import DataCon
import DynFlags
import ForeignCall ( ForeignCall )
import Id
import IdInfo ( mayHaveCafRefs )
import VarSet
import Literal ( Literal, literalType )
import Module ( Module )
import Outputable
import Packages ( isDllName )
import GHC.Platform
import PprCore ( )
import PrimOp ( PrimOp, PrimCall )
import TyCon ( PrimRep(..), TyCon )
import Type ( Type )
import RepType ( typePrimRep1 )
import Util
import Data.List.NonEmpty ( NonEmpty, toList )
data GenStgTopBinding pass
= StgTopLifted (GenStgBinding pass)
| StgTopStringLit Id ByteString
data GenStgBinding pass
= StgNonRec (BinderP pass) (GenStgRhs pass)
| StgRec [(BinderP pass, GenStgRhs pass)]
data StgArg
= StgVarArg Id
| StgLitArg Literal
isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp DynFlags
dflags Module
this_mod DataCon
con [StgArg]
args
| Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
= DynFlags -> Module -> Name -> Bool
isDllName DynFlags
dflags Module
this_mod (DataCon -> Name
dataConName DataCon
con) Bool -> Bool -> Bool
|| (StgArg -> Bool) -> [StgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StgArg -> Bool
is_dll_arg [StgArg]
args
| Bool
otherwise = Bool
False
where
is_dll_arg :: StgArg -> Bool
is_dll_arg :: StgArg -> Bool
is_dll_arg (StgVarArg Id
v) = PrimRep -> Bool
isAddrRep (HasDebugCallStack => UnaryType -> PrimRep
UnaryType -> PrimRep
typePrimRep1 (Id -> UnaryType
idType Id
v))
Bool -> Bool -> Bool
&& DynFlags -> Module -> Name -> Bool
isDllName DynFlags
dflags Module
this_mod (Id -> Name
idName Id
v)
is_dll_arg StgArg
_ = Bool
False
isAddrRep :: PrimRep -> Bool
isAddrRep :: PrimRep -> Bool
isAddrRep PrimRep
AddrRep = Bool
True
isAddrRep PrimRep
LiftedRep = Bool
True
isAddrRep PrimRep
UnliftedRep = Bool
True
isAddrRep PrimRep
_ = Bool
False
stgArgType :: StgArg -> Type
stgArgType :: StgArg -> UnaryType
stgArgType (StgVarArg Id
v) = Id -> UnaryType
idType Id
v
stgArgType (StgLitArg Literal
lit) = Literal -> UnaryType
literalType Literal
lit
stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
stripStgTicksTop :: (Tickish Id -> Bool)
-> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
stripStgTicksTop Tickish Id -> Bool
p = [Tickish Id] -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
go []
where go :: [Tickish Id] -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
go [Tickish Id]
ts (StgTick Tickish Id
t GenStgExpr p
e) | Tickish Id -> Bool
p Tickish Id
t = [Tickish Id] -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
go (Tickish Id
tTickish Id -> [Tickish Id] -> [Tickish Id]
forall a. a -> [a] -> [a]
:[Tickish Id]
ts) GenStgExpr p
e
go [Tickish Id]
ts GenStgExpr p
other = ([Tickish Id] -> [Tickish Id]
forall a. [a] -> [a]
reverse [Tickish Id]
ts, GenStgExpr p
other)
stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p
stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p
stripStgTicksTopE Tickish Id -> Bool
p = GenStgExpr p -> GenStgExpr p
go
where go :: GenStgExpr p -> GenStgExpr p
go (StgTick Tickish Id
t GenStgExpr p
e) | Tickish Id -> Bool
p Tickish Id
t = GenStgExpr p -> GenStgExpr p
go GenStgExpr p
e
go GenStgExpr p
other = GenStgExpr p
other
stgCaseBndrInScope :: AltType -> Bool -> Bool
stgCaseBndrInScope :: AltType -> Bool -> Bool
stgCaseBndrInScope AltType
alt_ty Bool
unarised =
case AltType
alt_ty of
AlgAlt TyCon
_ -> Bool
True
PrimAlt PrimRep
_ -> Bool
True
MultiValAlt Int
_ -> Bool -> Bool
not Bool
unarised
AltType
PolyAlt -> Bool
True
data GenStgExpr pass
= StgApp
Id
[StgArg]
| StgLit Literal
| StgConApp DataCon
[StgArg]
[Type]
| StgOpApp StgOp
[StgArg]
Type
| StgLam
(NonEmpty (BinderP pass))
StgExpr
| StgCase
(GenStgExpr pass)
(BinderP pass)
AltType
[GenStgAlt pass]
| StgLet
(XLet pass)
(GenStgBinding pass)
(GenStgExpr pass)
| StgLetNoEscape
(XLetNoEscape pass)
(GenStgBinding pass)
(GenStgExpr pass)
| StgTick
(Tickish Id)
(GenStgExpr pass)
data GenStgRhs pass
= StgRhsClosure
(XRhsClosure pass)
CostCentreStack
!UpdateFlag
[BinderP pass]
(GenStgExpr pass)
| StgRhsCon
CostCentreStack
DataCon
[StgArg]
data StgPass
= Vanilla
| LiftLams
| CodeGen
data NoExtFieldSilent = NoExtFieldSilent
deriving (Typeable NoExtFieldSilent
DataType
Constr
Typeable NoExtFieldSilent
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> NoExtFieldSilent -> c NoExtFieldSilent)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NoExtFieldSilent)
-> (NoExtFieldSilent -> Constr)
-> (NoExtFieldSilent -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c NoExtFieldSilent))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c NoExtFieldSilent))
-> ((forall b. Data b => b -> b)
-> NoExtFieldSilent -> NoExtFieldSilent)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> NoExtFieldSilent -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> NoExtFieldSilent -> r)
-> (forall u.
(forall d. Data d => d -> u) -> NoExtFieldSilent -> [u])
-> (forall u.
Int -> (forall d. Data d => d -> u) -> NoExtFieldSilent -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> NoExtFieldSilent -> m NoExtFieldSilent)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NoExtFieldSilent -> m NoExtFieldSilent)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NoExtFieldSilent -> m NoExtFieldSilent)
-> Data NoExtFieldSilent
NoExtFieldSilent -> DataType
NoExtFieldSilent -> Constr
(forall b. Data b => b -> b)
-> NoExtFieldSilent -> NoExtFieldSilent
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> NoExtFieldSilent -> c NoExtFieldSilent
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NoExtFieldSilent
forall a.
Typeable a
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> NoExtFieldSilent -> u
forall u. (forall d. Data d => d -> u) -> NoExtFieldSilent -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> NoExtFieldSilent -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> NoExtFieldSilent -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> NoExtFieldSilent -> m NoExtFieldSilent
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NoExtFieldSilent -> m NoExtFieldSilent
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NoExtFieldSilent
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> NoExtFieldSilent -> c NoExtFieldSilent
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c NoExtFieldSilent)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c NoExtFieldSilent)
$cNoExtFieldSilent :: Constr
$tNoExtFieldSilent :: DataType
gmapMo :: (forall d. Data d => d -> m d)
-> NoExtFieldSilent -> m NoExtFieldSilent
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NoExtFieldSilent -> m NoExtFieldSilent
gmapMp :: (forall d. Data d => d -> m d)
-> NoExtFieldSilent -> m NoExtFieldSilent
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> NoExtFieldSilent -> m NoExtFieldSilent
gmapM :: (forall d. Data d => d -> m d)
-> NoExtFieldSilent -> m NoExtFieldSilent
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> NoExtFieldSilent -> m NoExtFieldSilent
gmapQi :: Int -> (forall d. Data d => d -> u) -> NoExtFieldSilent -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> NoExtFieldSilent -> u
gmapQ :: (forall d. Data d => d -> u) -> NoExtFieldSilent -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> NoExtFieldSilent -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> NoExtFieldSilent -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> NoExtFieldSilent -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> NoExtFieldSilent -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> NoExtFieldSilent -> r
gmapT :: (forall b. Data b => b -> b)
-> NoExtFieldSilent -> NoExtFieldSilent
$cgmapT :: (forall b. Data b => b -> b)
-> NoExtFieldSilent -> NoExtFieldSilent
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c NoExtFieldSilent)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c NoExtFieldSilent)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c NoExtFieldSilent)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c NoExtFieldSilent)
dataTypeOf :: NoExtFieldSilent -> DataType
$cdataTypeOf :: NoExtFieldSilent -> DataType
toConstr :: NoExtFieldSilent -> Constr
$ctoConstr :: NoExtFieldSilent -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NoExtFieldSilent
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c NoExtFieldSilent
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> NoExtFieldSilent -> c NoExtFieldSilent
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> NoExtFieldSilent -> c NoExtFieldSilent
$cp1Data :: Typeable NoExtFieldSilent
Data, NoExtFieldSilent -> NoExtFieldSilent -> Bool
(NoExtFieldSilent -> NoExtFieldSilent -> Bool)
-> (NoExtFieldSilent -> NoExtFieldSilent -> Bool)
-> Eq NoExtFieldSilent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoExtFieldSilent -> NoExtFieldSilent -> Bool
$c/= :: NoExtFieldSilent -> NoExtFieldSilent -> Bool
== :: NoExtFieldSilent -> NoExtFieldSilent -> Bool
$c== :: NoExtFieldSilent -> NoExtFieldSilent -> Bool
Eq, Eq NoExtFieldSilent
Eq NoExtFieldSilent
-> (NoExtFieldSilent -> NoExtFieldSilent -> Ordering)
-> (NoExtFieldSilent -> NoExtFieldSilent -> Bool)
-> (NoExtFieldSilent -> NoExtFieldSilent -> Bool)
-> (NoExtFieldSilent -> NoExtFieldSilent -> Bool)
-> (NoExtFieldSilent -> NoExtFieldSilent -> Bool)
-> (NoExtFieldSilent -> NoExtFieldSilent -> NoExtFieldSilent)
-> (NoExtFieldSilent -> NoExtFieldSilent -> NoExtFieldSilent)
-> Ord NoExtFieldSilent
NoExtFieldSilent -> NoExtFieldSilent -> Bool
NoExtFieldSilent -> NoExtFieldSilent -> Ordering
NoExtFieldSilent -> NoExtFieldSilent -> NoExtFieldSilent
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NoExtFieldSilent -> NoExtFieldSilent -> NoExtFieldSilent
$cmin :: NoExtFieldSilent -> NoExtFieldSilent -> NoExtFieldSilent
max :: NoExtFieldSilent -> NoExtFieldSilent -> NoExtFieldSilent
$cmax :: NoExtFieldSilent -> NoExtFieldSilent -> NoExtFieldSilent
>= :: NoExtFieldSilent -> NoExtFieldSilent -> Bool
$c>= :: NoExtFieldSilent -> NoExtFieldSilent -> Bool
> :: NoExtFieldSilent -> NoExtFieldSilent -> Bool
$c> :: NoExtFieldSilent -> NoExtFieldSilent -> Bool
<= :: NoExtFieldSilent -> NoExtFieldSilent -> Bool
$c<= :: NoExtFieldSilent -> NoExtFieldSilent -> Bool
< :: NoExtFieldSilent -> NoExtFieldSilent -> Bool
$c< :: NoExtFieldSilent -> NoExtFieldSilent -> Bool
compare :: NoExtFieldSilent -> NoExtFieldSilent -> Ordering
$ccompare :: NoExtFieldSilent -> NoExtFieldSilent -> Ordering
$cp1Ord :: Eq NoExtFieldSilent
Ord)
instance Outputable NoExtFieldSilent where
ppr :: NoExtFieldSilent -> SDoc
ppr NoExtFieldSilent
_ = SDoc
empty
noExtFieldSilent :: NoExtFieldSilent
noExtFieldSilent :: NoExtFieldSilent
noExtFieldSilent = NoExtFieldSilent
NoExtFieldSilent
type family BinderP (pass :: StgPass)
type instance BinderP 'Vanilla = Id
type instance BinderP 'CodeGen = Id
type family XRhsClosure (pass :: StgPass)
type instance XRhsClosure 'Vanilla = NoExtFieldSilent
type instance XRhsClosure 'CodeGen = DIdSet
type family XLet (pass :: StgPass)
type instance XLet 'Vanilla = NoExtFieldSilent
type instance XLet 'CodeGen = NoExtFieldSilent
type family XLetNoEscape (pass :: StgPass)
type instance XLetNoEscape 'Vanilla = NoExtFieldSilent
type instance XLetNoEscape 'CodeGen = NoExtFieldSilent
stgRhsArity :: StgRhs -> Int
stgRhsArity :: StgRhs -> Int
stgRhsArity (StgRhsClosure XRhsClosure 'Vanilla
_ CostCentreStack
_ UpdateFlag
_ [BinderP 'Vanilla]
bndrs GenStgExpr 'Vanilla
_)
= ASSERT( all isId bndrs ) length bndrs
stgRhsArity (StgRhsCon CostCentreStack
_ DataCon
_ [StgArg]
_) = Int
0
topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool
topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool
topStgBindHasCafRefs (StgTopLifted (StgNonRec BinderP pass
_ GenStgRhs pass
rhs))
= GenStgRhs pass -> Bool
forall (pass :: StgPass). GenStgRhs pass -> Bool
topRhsHasCafRefs GenStgRhs pass
rhs
topStgBindHasCafRefs (StgTopLifted (StgRec [(BinderP pass, GenStgRhs pass)]
binds))
= (GenStgRhs pass -> Bool) -> [GenStgRhs pass] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenStgRhs pass -> Bool
forall (pass :: StgPass). GenStgRhs pass -> Bool
topRhsHasCafRefs (((BinderP pass, GenStgRhs pass) -> GenStgRhs pass)
-> [(BinderP pass, GenStgRhs pass)] -> [GenStgRhs pass]
forall a b. (a -> b) -> [a] -> [b]
map (BinderP pass, GenStgRhs pass) -> GenStgRhs pass
forall a b. (a, b) -> b
snd [(BinderP pass, GenStgRhs pass)]
binds)
topStgBindHasCafRefs StgTopStringLit{}
= Bool
False
topRhsHasCafRefs :: GenStgRhs pass -> Bool
topRhsHasCafRefs :: GenStgRhs pass -> Bool
topRhsHasCafRefs (StgRhsClosure XRhsClosure pass
_ CostCentreStack
_ UpdateFlag
upd [BinderP pass]
_ GenStgExpr pass
body)
=
UpdateFlag -> Bool
isUpdatable UpdateFlag
upd Bool -> Bool -> Bool
|| GenStgExpr pass -> Bool
forall (pass :: StgPass). GenStgExpr pass -> Bool
exprHasCafRefs GenStgExpr pass
body
topRhsHasCafRefs (StgRhsCon CostCentreStack
_ DataCon
_ [StgArg]
args)
= (StgArg -> Bool) -> [StgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StgArg -> Bool
stgArgHasCafRefs [StgArg]
args
exprHasCafRefs :: GenStgExpr pass -> Bool
exprHasCafRefs :: GenStgExpr pass -> Bool
exprHasCafRefs (StgApp Id
f [StgArg]
args)
= Id -> Bool
stgIdHasCafRefs Id
f Bool -> Bool -> Bool
|| (StgArg -> Bool) -> [StgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StgArg -> Bool
stgArgHasCafRefs [StgArg]
args
exprHasCafRefs StgLit{}
= Bool
False
exprHasCafRefs (StgConApp DataCon
_ [StgArg]
args [UnaryType]
_)
= (StgArg -> Bool) -> [StgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StgArg -> Bool
stgArgHasCafRefs [StgArg]
args
exprHasCafRefs (StgOpApp StgOp
_ [StgArg]
args UnaryType
_)
= (StgArg -> Bool) -> [StgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StgArg -> Bool
stgArgHasCafRefs [StgArg]
args
exprHasCafRefs (StgLam NonEmpty (BinderP pass)
_ GenStgExpr 'Vanilla
body)
= GenStgExpr 'Vanilla -> Bool
forall (pass :: StgPass). GenStgExpr pass -> Bool
exprHasCafRefs GenStgExpr 'Vanilla
body
exprHasCafRefs (StgCase GenStgExpr pass
scrt BinderP pass
_ AltType
_ [GenStgAlt pass]
alts)
= GenStgExpr pass -> Bool
forall (pass :: StgPass). GenStgExpr pass -> Bool
exprHasCafRefs GenStgExpr pass
scrt Bool -> Bool -> Bool
|| (GenStgAlt pass -> Bool) -> [GenStgAlt pass] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenStgAlt pass -> Bool
forall (pass :: StgPass). GenStgAlt pass -> Bool
altHasCafRefs [GenStgAlt pass]
alts
exprHasCafRefs (StgLet XLet pass
_ GenStgBinding pass
bind GenStgExpr pass
body)
= GenStgBinding pass -> Bool
forall (pass :: StgPass). GenStgBinding pass -> Bool
bindHasCafRefs GenStgBinding pass
bind Bool -> Bool -> Bool
|| GenStgExpr pass -> Bool
forall (pass :: StgPass). GenStgExpr pass -> Bool
exprHasCafRefs GenStgExpr pass
body
exprHasCafRefs (StgLetNoEscape XLetNoEscape pass
_ GenStgBinding pass
bind GenStgExpr pass
body)
= GenStgBinding pass -> Bool
forall (pass :: StgPass). GenStgBinding pass -> Bool
bindHasCafRefs GenStgBinding pass
bind Bool -> Bool -> Bool
|| GenStgExpr pass -> Bool
forall (pass :: StgPass). GenStgExpr pass -> Bool
exprHasCafRefs GenStgExpr pass
body
exprHasCafRefs (StgTick Tickish Id
_ GenStgExpr pass
expr)
= GenStgExpr pass -> Bool
forall (pass :: StgPass). GenStgExpr pass -> Bool
exprHasCafRefs GenStgExpr pass
expr
bindHasCafRefs :: GenStgBinding pass -> Bool
bindHasCafRefs :: GenStgBinding pass -> Bool
bindHasCafRefs (StgNonRec BinderP pass
_ GenStgRhs pass
rhs)
= GenStgRhs pass -> Bool
forall (pass :: StgPass). GenStgRhs pass -> Bool
rhsHasCafRefs GenStgRhs pass
rhs
bindHasCafRefs (StgRec [(BinderP pass, GenStgRhs pass)]
binds)
= (GenStgRhs pass -> Bool) -> [GenStgRhs pass] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenStgRhs pass -> Bool
forall (pass :: StgPass). GenStgRhs pass -> Bool
rhsHasCafRefs (((BinderP pass, GenStgRhs pass) -> GenStgRhs pass)
-> [(BinderP pass, GenStgRhs pass)] -> [GenStgRhs pass]
forall a b. (a -> b) -> [a] -> [b]
map (BinderP pass, GenStgRhs pass) -> GenStgRhs pass
forall a b. (a, b) -> b
snd [(BinderP pass, GenStgRhs pass)]
binds)
rhsHasCafRefs :: GenStgRhs pass -> Bool
rhsHasCafRefs :: GenStgRhs pass -> Bool
rhsHasCafRefs (StgRhsClosure XRhsClosure pass
_ CostCentreStack
_ UpdateFlag
_ [BinderP pass]
_ GenStgExpr pass
body)
= GenStgExpr pass -> Bool
forall (pass :: StgPass). GenStgExpr pass -> Bool
exprHasCafRefs GenStgExpr pass
body
rhsHasCafRefs (StgRhsCon CostCentreStack
_ DataCon
_ [StgArg]
args)
= (StgArg -> Bool) -> [StgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StgArg -> Bool
stgArgHasCafRefs [StgArg]
args
altHasCafRefs :: GenStgAlt pass -> Bool
altHasCafRefs :: GenStgAlt pass -> Bool
altHasCafRefs (AltCon
_, [BinderP pass]
_, GenStgExpr pass
rhs) = GenStgExpr pass -> Bool
forall (pass :: StgPass). GenStgExpr pass -> Bool
exprHasCafRefs GenStgExpr pass
rhs
stgArgHasCafRefs :: StgArg -> Bool
stgArgHasCafRefs :: StgArg -> Bool
stgArgHasCafRefs (StgVarArg Id
id)
= Id -> Bool
stgIdHasCafRefs Id
id
stgArgHasCafRefs StgArg
_
= Bool
False
stgIdHasCafRefs :: Id -> Bool
stgIdHasCafRefs :: Id -> Bool
stgIdHasCafRefs Id
id =
Id -> Bool
isGlobalId Id
id Bool -> Bool -> Bool
&& CafInfo -> Bool
mayHaveCafRefs (Id -> CafInfo
idCafInfo Id
id)
type GenStgAlt pass
= (AltCon,
[BinderP pass],
GenStgExpr pass)
data AltType
= PolyAlt
| MultiValAlt Int
| AlgAlt TyCon
| PrimAlt PrimRep
type StgTopBinding = GenStgTopBinding 'Vanilla
type StgBinding = GenStgBinding 'Vanilla
type StgExpr = GenStgExpr 'Vanilla
type StgRhs = GenStgRhs 'Vanilla
type StgAlt = GenStgAlt 'Vanilla
type LlStgTopBinding = GenStgTopBinding 'LiftLams
type LlStgBinding = GenStgBinding 'LiftLams
type LlStgExpr = GenStgExpr 'LiftLams
type LlStgRhs = GenStgRhs 'LiftLams
type LlStgAlt = GenStgAlt 'LiftLams
type CgStgTopBinding = GenStgTopBinding 'CodeGen
type CgStgBinding = GenStgBinding 'CodeGen
type CgStgExpr = GenStgExpr 'CodeGen
type CgStgRhs = GenStgRhs 'CodeGen
type CgStgAlt = GenStgAlt 'CodeGen
type InStgTopBinding = StgTopBinding
type InStgBinding = StgBinding
type InStgArg = StgArg
type InStgExpr = StgExpr
type InStgRhs = StgRhs
type InStgAlt = StgAlt
type OutStgTopBinding = StgTopBinding
type OutStgBinding = StgBinding
type OutStgArg = StgArg
type OutStgExpr = StgExpr
type OutStgRhs = StgRhs
type OutStgAlt = StgAlt
data UpdateFlag = ReEntrant | Updatable | SingleEntry
instance Outputable UpdateFlag where
ppr :: UpdateFlag -> SDoc
ppr UpdateFlag
u = Char -> SDoc
char (Char -> SDoc) -> Char -> SDoc
forall a b. (a -> b) -> a -> b
$ case UpdateFlag
u of
UpdateFlag
ReEntrant -> Char
'r'
UpdateFlag
Updatable -> Char
'u'
UpdateFlag
SingleEntry -> Char
's'
isUpdatable :: UpdateFlag -> Bool
isUpdatable :: UpdateFlag -> Bool
isUpdatable UpdateFlag
ReEntrant = Bool
False
isUpdatable UpdateFlag
SingleEntry = Bool
False
isUpdatable UpdateFlag
Updatable = Bool
True
data StgOp
= StgPrimOp PrimOp
| StgPrimCallOp PrimCall
| StgFCallOp ForeignCall Type
type OutputablePass pass =
( Outputable (XLet pass)
, Outputable (XLetNoEscape pass)
, Outputable (XRhsClosure pass)
, OutputableBndr (BinderP pass)
)
pprGenStgTopBinding
:: OutputablePass pass => GenStgTopBinding pass -> SDoc
pprGenStgTopBinding :: GenStgTopBinding pass -> SDoc
pprGenStgTopBinding (StgTopStringLit Id
bndr ByteString
str)
= SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
hsep [BindingSite -> Id -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind Id
bndr, SDoc
equals])
Int
4 (ByteString -> SDoc
pprHsBytes ByteString
str SDoc -> SDoc -> SDoc
<> SDoc
semi)
pprGenStgTopBinding (StgTopLifted GenStgBinding pass
bind)
= GenStgBinding pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgBinding pass -> SDoc
pprGenStgBinding GenStgBinding pass
bind
pprGenStgBinding
:: OutputablePass pass => GenStgBinding pass -> SDoc
pprGenStgBinding :: GenStgBinding pass -> SDoc
pprGenStgBinding (StgNonRec BinderP pass
bndr GenStgRhs pass
rhs)
= SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
hsep [BindingSite -> BinderP pass -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind BinderP pass
bndr, SDoc
equals])
Int
4 (GenStgRhs pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenStgRhs pass
rhs SDoc -> SDoc -> SDoc
<> SDoc
semi)
pprGenStgBinding (StgRec [(BinderP pass, GenStgRhs pass)]
pairs)
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Rec {"
, [SDoc] -> SDoc
vcat (SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse SDoc
blankLine (((BinderP pass, GenStgRhs pass) -> SDoc)
-> [(BinderP pass, GenStgRhs pass)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BinderP pass, GenStgRhs pass) -> SDoc
forall a a. (OutputableBndr a, Outputable a) => (a, a) -> SDoc
ppr_bind [(BinderP pass, GenStgRhs pass)]
pairs))
, String -> SDoc
text String
"end Rec }" ]
where
ppr_bind :: (a, a) -> SDoc
ppr_bind (a
bndr, a
expr)
= SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
hsep [BindingSite -> a -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind a
bndr, SDoc
equals])
Int
4 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
expr SDoc -> SDoc -> SDoc
<> SDoc
semi)
pprGenStgTopBindings
:: (OutputablePass pass) => [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings :: [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings [GenStgTopBinding pass]
binds
= [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse SDoc
blankLine ((GenStgTopBinding pass -> SDoc)
-> [GenStgTopBinding pass] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenStgTopBinding pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgTopBinding pass -> SDoc
pprGenStgTopBinding [GenStgTopBinding pass]
binds)
pprStgBinding :: StgBinding -> SDoc
pprStgBinding :: StgBinding -> SDoc
pprStgBinding = StgBinding -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgBinding pass -> SDoc
pprGenStgBinding
pprStgTopBindings :: [StgTopBinding] -> SDoc
pprStgTopBindings :: [StgTopBinding] -> SDoc
pprStgTopBindings = [StgTopBinding] -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
[GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings
instance Outputable StgArg where
ppr :: StgArg -> SDoc
ppr = StgArg -> SDoc
pprStgArg
instance OutputablePass pass => Outputable (GenStgTopBinding pass) where
ppr :: GenStgTopBinding pass -> SDoc
ppr = GenStgTopBinding pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgTopBinding pass -> SDoc
pprGenStgTopBinding
instance OutputablePass pass => Outputable (GenStgBinding pass) where
ppr :: GenStgBinding pass -> SDoc
ppr = GenStgBinding pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgBinding pass -> SDoc
pprGenStgBinding
instance OutputablePass pass => Outputable (GenStgExpr pass) where
ppr :: GenStgExpr pass -> SDoc
ppr = GenStgExpr pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgExpr pass -> SDoc
pprStgExpr
instance OutputablePass pass => Outputable (GenStgRhs pass) where
ppr :: GenStgRhs pass -> SDoc
ppr GenStgRhs pass
rhs = GenStgRhs pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgRhs pass -> SDoc
pprStgRhs GenStgRhs pass
rhs
pprStgArg :: StgArg -> SDoc
pprStgArg :: StgArg -> SDoc
pprStgArg (StgVarArg Id
var) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
var
pprStgArg (StgLitArg Literal
con) = Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
con
pprStgExpr :: OutputablePass pass => GenStgExpr pass -> SDoc
pprStgExpr :: GenStgExpr pass -> SDoc
pprStgExpr (StgLit Literal
lit) = Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
lit
pprStgExpr (StgApp Id
func [StgArg]
args)
= SDoc -> Int -> SDoc -> SDoc
hang (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
func) Int
4 ([SDoc] -> SDoc
sep ((StgArg -> SDoc) -> [StgArg] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (StgArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [StgArg]
args))
pprStgExpr (StgConApp DataCon
con [StgArg]
args [UnaryType]
_)
= [SDoc] -> SDoc
hsep [ DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con, SDoc -> SDoc
brackets ([StgArg] -> SDoc
forall a. Outputable a => [a] -> SDoc
interppSP [StgArg]
args) ]
pprStgExpr (StgOpApp StgOp
op [StgArg]
args UnaryType
_)
= [SDoc] -> SDoc
hsep [ StgOp -> SDoc
pprStgOp StgOp
op, SDoc -> SDoc
brackets ([StgArg] -> SDoc
forall a. Outputable a => [a] -> SDoc
interppSP [StgArg]
args)]
pprStgExpr (StgLam NonEmpty (BinderP pass)
bndrs GenStgExpr 'Vanilla
body)
= [SDoc] -> SDoc
sep [ Char -> SDoc
char Char
'\\' SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
ppr_list ((BinderP pass -> SDoc) -> [BinderP pass] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BindingSite -> BinderP pass -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LambdaBind) (NonEmpty (BinderP pass) -> [BinderP pass]
forall a. NonEmpty a -> [a]
toList NonEmpty (BinderP pass)
bndrs))
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"->",
GenStgExpr 'Vanilla -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgExpr pass -> SDoc
pprStgExpr GenStgExpr 'Vanilla
body ]
where ppr_list :: [SDoc] -> SDoc
ppr_list = SDoc -> SDoc
brackets (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
fsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
pprStgExpr (StgLet XLet pass
ext GenStgBinding pass
bind expr :: GenStgExpr pass
expr@StgLet{})
= SDoc -> SDoc -> SDoc
($$)
([SDoc] -> SDoc
sep [SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"let" SDoc -> SDoc -> SDoc
<+> XLet pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr XLet pass
ext SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"{")
Int
2 ([SDoc] -> SDoc
hsep [GenStgBinding pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgBinding pass -> SDoc
pprGenStgBinding GenStgBinding pass
bind, String -> SDoc
text String
"} in"])])
(GenStgExpr pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenStgExpr pass
expr)
pprStgExpr (StgLet XLet pass
ext GenStgBinding pass
bind GenStgExpr pass
expr)
= [SDoc] -> SDoc
sep [SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"let" SDoc -> SDoc -> SDoc
<+> XLet pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr XLet pass
ext SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"{") Int
2 (GenStgBinding pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgBinding pass -> SDoc
pprGenStgBinding GenStgBinding pass
bind),
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"} in ") Int
2 (GenStgExpr pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenStgExpr pass
expr)]
pprStgExpr (StgLetNoEscape XLetNoEscape pass
ext GenStgBinding pass
bind GenStgExpr pass
expr)
= [SDoc] -> SDoc
sep [SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"let-no-escape" SDoc -> SDoc -> SDoc
<+> XLetNoEscape pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr XLetNoEscape pass
ext SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"{")
Int
2 (GenStgBinding pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgBinding pass -> SDoc
pprGenStgBinding GenStgBinding pass
bind),
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"} in ")
Int
2 (GenStgExpr pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenStgExpr pass
expr)]
pprStgExpr (StgTick Tickish Id
tickish GenStgExpr pass
expr)
= (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressTicks DynFlags
dflags
then GenStgExpr pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgExpr pass -> SDoc
pprStgExpr GenStgExpr pass
expr
else [SDoc] -> SDoc
sep [ Tickish Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Tickish Id
tickish, GenStgExpr pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgExpr pass -> SDoc
pprStgExpr GenStgExpr pass
expr ]
pprStgExpr (StgCase GenStgExpr pass
expr BinderP pass
bndr AltType
alt_type [GenStgAlt pass
alt])
= [SDoc] -> SDoc
sep [[SDoc] -> SDoc
sep [String -> SDoc
text String
"case",
Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
hsep [GenStgExpr pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgExpr pass -> SDoc
pprStgExpr GenStgExpr pass
expr,
SDoc -> SDoc
whenPprDebug (SDoc
dcolon SDoc -> SDoc -> SDoc
<+> AltType -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltType
alt_type)]),
String -> SDoc
text String
"of", BindingSite -> BinderP pass -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
CaseBind BinderP pass
bndr, Char -> SDoc
char Char
'{'],
Bool -> GenStgAlt pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
Bool -> GenStgAlt pass -> SDoc
pprStgAlt Bool
False GenStgAlt pass
alt,
Char -> SDoc
char Char
'}']
pprStgExpr (StgCase GenStgExpr pass
expr BinderP pass
bndr AltType
alt_type [GenStgAlt pass]
alts)
= [SDoc] -> SDoc
sep [[SDoc] -> SDoc
sep [String -> SDoc
text String
"case",
Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
hsep [GenStgExpr pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
GenStgExpr pass -> SDoc
pprStgExpr GenStgExpr pass
expr,
SDoc -> SDoc
whenPprDebug (SDoc
dcolon SDoc -> SDoc -> SDoc
<+> AltType -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltType
alt_type)]),
String -> SDoc
text String
"of", BindingSite -> BinderP pass -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
CaseBind BinderP pass
bndr, Char -> SDoc
char Char
'{'],
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat ((GenStgAlt pass -> SDoc) -> [GenStgAlt pass] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> GenStgAlt pass -> SDoc
forall (pass :: StgPass).
OutputablePass pass =>
Bool -> GenStgAlt pass -> SDoc
pprStgAlt Bool
True) [GenStgAlt pass]
alts)),
Char -> SDoc
char Char
'}']
pprStgAlt :: OutputablePass pass => Bool -> GenStgAlt pass -> SDoc
pprStgAlt :: Bool -> GenStgAlt pass -> SDoc
pprStgAlt Bool
indent (AltCon
con, [BinderP pass]
params, GenStgExpr pass
expr)
| Bool
indent = SDoc -> Int -> SDoc -> SDoc
hang SDoc
altPattern Int
4 (GenStgExpr pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenStgExpr pass
expr SDoc -> SDoc -> SDoc
<> SDoc
semi)
| Bool
otherwise = [SDoc] -> SDoc
sep [SDoc
altPattern, GenStgExpr pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenStgExpr pass
expr SDoc -> SDoc -> SDoc
<> SDoc
semi]
where
altPattern :: SDoc
altPattern = ([SDoc] -> SDoc
hsep [AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
con, [SDoc] -> SDoc
sep ((BinderP pass -> SDoc) -> [BinderP pass] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BindingSite -> BinderP pass -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
CasePatBind) [BinderP pass]
params), String -> SDoc
text String
"->"])
pprStgOp :: StgOp -> SDoc
pprStgOp :: StgOp -> SDoc
pprStgOp (StgPrimOp PrimOp
op) = PrimOp -> SDoc
forall a. Outputable a => a -> SDoc
ppr PrimOp
op
pprStgOp (StgPrimCallOp PrimCall
op)= PrimCall -> SDoc
forall a. Outputable a => a -> SDoc
ppr PrimCall
op
pprStgOp (StgFCallOp ForeignCall
op UnaryType
_) = ForeignCall -> SDoc
forall a. Outputable a => a -> SDoc
ppr ForeignCall
op
instance Outputable AltType where
ppr :: AltType -> SDoc
ppr AltType
PolyAlt = String -> SDoc
text String
"Polymorphic"
ppr (MultiValAlt Int
n) = String -> SDoc
text String
"MultiAlt" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n
ppr (AlgAlt TyCon
tc) = String -> SDoc
text String
"Alg" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
ppr (PrimAlt PrimRep
tc) = String -> SDoc
text String
"Prim" SDoc -> SDoc -> SDoc
<+> PrimRep -> SDoc
forall a. Outputable a => a -> SDoc
ppr PrimRep
tc
pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc
pprStgRhs :: GenStgRhs pass -> SDoc
pprStgRhs (StgRhsClosure XRhsClosure pass
ext CostCentreStack
cc UpdateFlag
upd_flag [BinderP pass]
args GenStgExpr pass
body)
= (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
hsep [if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags then CostCentreStack -> SDoc
forall a. Outputable a => a -> SDoc
ppr CostCentreStack
cc else SDoc
empty,
if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressStgExts DynFlags
dflags
then XRhsClosure pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr XRhsClosure pass
ext else SDoc
empty,
Char -> SDoc
char Char
'\\' SDoc -> SDoc -> SDoc
<> UpdateFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr UpdateFlag
upd_flag, SDoc -> SDoc
brackets ([BinderP pass] -> SDoc
forall a. Outputable a => [a] -> SDoc
interppSP [BinderP pass]
args)])
Int
4 (GenStgExpr pass -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenStgExpr pass
body)
pprStgRhs (StgRhsCon CostCentreStack
cc DataCon
con [StgArg]
args)
= [SDoc] -> SDoc
hcat [ CostCentreStack -> SDoc
forall a. Outputable a => a -> SDoc
ppr CostCentreStack
cc,
SDoc
space, DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con, String -> SDoc
text String
"! ", SDoc -> SDoc
brackets ([StgArg] -> SDoc
forall a. Outputable a => [a] -> SDoc
interppSP [StgArg]
args)]