{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.CoreToStg ( coreToStg ) where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Config.Stg.Debug
import GHC.Core
import GHC.Core.Utils   ( exprType, findDefault, isJoinBind
                        , exprIsTickedString_maybe )
import GHC.Core.Opt.Arity   ( manifestArity )
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Stg.Syntax
import GHC.Stg.Debug
import GHC.Stg.Utils
import GHC.Types.RepType
import GHC.Types.Id.Make ( coercionTokenId )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.CostCentre
import GHC.Types.Tickish
import GHC.Types.Var.Env
import GHC.Types.Name   ( isExternalName, nameModule_maybe )
import GHC.Types.Basic  ( Arity )
import GHC.Types.Literal
import GHC.Types.ForeignCall
import GHC.Types.IPE
import GHC.Types.Demand    ( isUsedOnceDmd )
import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )
import GHC.Unit.Module
import GHC.Builtin.Types ( unboxedUnitDataCon )
import GHC.Data.FastString
import GHC.Platform.Ways
import GHC.Builtin.PrimOps ( PrimCall(..) )
import GHC.Utils.Outputable
import GHC.Utils.Monad
import GHC.Utils.Misc (HasDebugCallStack)
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Trace
import Control.Monad (ap)
import Data.Maybe (fromMaybe)
import Data.Tuple (swap)
coreToStg :: DynFlags -> Module -> ModLocation -> CoreProgram
          -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg :: DynFlags
-> Module
-> ModLocation
-> CoreProgram
-> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg DynFlags
dflags Module
this_mod ModLocation
ml CoreProgram
pgm
  = ([StgTopBinding]
pgm'', InfoTableProvMap
denv, CollectedCCs
final_ccs)
  where
    (IdEnv HowBound
_, ([CostCentre]
local_ccs, [CostCentreStack]
local_cc_stacks), [StgTopBinding]
pgm')
      = DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg DynFlags
dflags Module
this_mod IdEnv HowBound
forall a. VarEnv a
emptyVarEnv CollectedCCs
emptyCollectedCCs CoreProgram
pgm
    
    (![StgTopBinding]
pgm'', !InfoTableProvMap
denv) =
        if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InfoTableMap DynFlags
dflags
          then StgDebugOpts
-> ModLocation
-> [StgTopBinding]
-> ([StgTopBinding], InfoTableProvMap)
collectDebugInformation (DynFlags -> StgDebugOpts
initStgDebugOpts DynFlags
dflags) ModLocation
ml [StgTopBinding]
pgm'
          else ([StgTopBinding]
pgm', InfoTableProvMap
emptyInfoTableProvMap)
    prof :: Bool
prof = DynFlags -> Ways
ways DynFlags
dflags Ways -> Way -> Bool
`hasWay` Way
WayProf
    final_ccs :: CollectedCCs
final_ccs
      | Bool
prof Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AutoSccsOnIndividualCafs DynFlags
dflags
      = ([CostCentre]
local_ccs,[CostCentreStack]
local_cc_stacks)  
      | Bool
prof
      = (CostCentre
all_cafs_ccCostCentre -> [CostCentre] -> [CostCentre]
forall a. a -> [a] -> [a]
:[CostCentre]
local_ccs, CostCentreStack
all_cafs_ccsCostCentreStack -> [CostCentreStack] -> [CostCentreStack]
forall a. a -> [a] -> [a]
:[CostCentreStack]
local_cc_stacks)
      | Bool
otherwise
      = CollectedCCs
emptyCollectedCCs
    (CostCentre
all_cafs_cc, CostCentreStack
all_cafs_ccs) = Module -> (CostCentre, CostCentreStack)
getAllCAFsCC Module
this_mod
coreTopBindsToStg
    :: DynFlags
    -> Module
    -> IdEnv HowBound           
    -> CollectedCCs
    -> CoreProgram
    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg :: DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg DynFlags
_      Module
_        IdEnv HowBound
env CollectedCCs
ccs []
  = (IdEnv HowBound
env, CollectedCCs
ccs, [])
coreTopBindsToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env CollectedCCs
ccs (CoreBind
b:CoreProgram
bs)
  | NonRec Id
_ CoreArg
rhs <- CoreBind
b, CoreArg -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreArg
rhs
  = DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env1 CollectedCCs
ccs1 CoreProgram
bs
  | Bool
otherwise
  = (IdEnv HowBound
env2, CollectedCCs
ccs2, StgTopBinding
b'StgTopBinding -> [StgTopBinding] -> [StgTopBinding]
forall a. a -> [a] -> [a]
:[StgTopBinding]
bs')
  where
    (IdEnv HowBound
env1, CollectedCCs
ccs1, StgTopBinding
b' ) = DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreBind
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env CollectedCCs
ccs CoreBind
b
    (IdEnv HowBound
env2, CollectedCCs
ccs2, [StgTopBinding]
bs') = DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env1 CollectedCCs
ccs1 CoreProgram
bs
coreTopBindToStg
        :: DynFlags
        -> Module
        -> IdEnv HowBound
        -> CollectedCCs
        -> CoreBind
        -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg :: DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreBind
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg DynFlags
_ Module
_ IdEnv HowBound
env CollectedCCs
ccs (NonRec Id
id CoreArg
e)
  | Just ByteString
str <- CoreArg -> Maybe ByteString
exprIsTickedString_maybe CoreArg
e
  
  
  = let
        env' :: IdEnv HowBound
env' = IdEnv HowBound -> Id -> HowBound -> IdEnv HowBound
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv IdEnv HowBound
env Id
id HowBound
how_bound
        how_bound :: HowBound
how_bound = LetInfo -> Arity -> HowBound
LetBound LetInfo
TopLet Arity
0
    in (IdEnv HowBound
env', CollectedCCs
ccs, Id -> ByteString -> StgTopBinding
forall (pass :: StgPass). Id -> ByteString -> GenStgTopBinding pass
StgTopStringLit Id
id ByteString
str)
coreTopBindToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env CollectedCCs
ccs (NonRec Id
id CoreArg
rhs)
  = let
        env' :: IdEnv HowBound
env'      = IdEnv HowBound -> Id -> HowBound -> IdEnv HowBound
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv IdEnv HowBound
env Id
id HowBound
how_bound
        how_bound :: HowBound
how_bound = LetInfo -> Arity -> HowBound
LetBound LetInfo
TopLet (Arity -> HowBound) -> Arity -> HowBound
forall a b. (a -> b) -> a -> b
$! CoreArg -> Arity
manifestArity CoreArg
rhs
        (StgRhs
stg_rhs, CollectedCCs
ccs') =
            DynFlags
-> IdEnv HowBound
-> CtsM (StgRhs, CollectedCCs)
-> (StgRhs, CollectedCCs)
forall a. DynFlags -> IdEnv HowBound -> CtsM a -> a
initCts DynFlags
dflags IdEnv HowBound
env (CtsM (StgRhs, CollectedCCs) -> (StgRhs, CollectedCCs))
-> CtsM (StgRhs, CollectedCCs) -> (StgRhs, CollectedCCs)
forall a b. (a -> b) -> a -> b
$
              DynFlags
-> CollectedCCs
-> Module
-> (Id, CoreArg)
-> CtsM (StgRhs, CollectedCCs)
coreToTopStgRhs DynFlags
dflags CollectedCCs
ccs Module
this_mod (Id
id,CoreArg
rhs)
        bind :: StgTopBinding
bind = GenStgBinding 'Vanilla -> StgTopBinding
forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted (GenStgBinding 'Vanilla -> StgTopBinding)
-> GenStgBinding 'Vanilla -> StgTopBinding
forall a b. (a -> b) -> a -> b
$ BinderP 'Vanilla -> StgRhs -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
BinderP 'Vanilla
id StgRhs
stg_rhs
    in
      
      
      
      
    (IdEnv HowBound
env', CollectedCCs
ccs', StgTopBinding
bind)
coreTopBindToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env CollectedCCs
ccs (Rec [(Id, CoreArg)]
pairs)
  = Bool
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([(Id, CoreArg)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Id, CoreArg)]
pairs)) ((IdEnv HowBound, CollectedCCs, StgTopBinding)
 -> (IdEnv HowBound, CollectedCCs, StgTopBinding))
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
forall a b. (a -> b) -> a -> b
$
    let
        binders :: [Id]
binders = ((Id, CoreArg) -> Id) -> [(Id, CoreArg)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreArg) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreArg)]
pairs
        extra_env' :: [(Id, HowBound)]
extra_env' = [ (Id
b, LetInfo -> Arity -> HowBound
LetBound LetInfo
TopLet (Arity -> HowBound) -> Arity -> HowBound
forall a b. (a -> b) -> a -> b
$! CoreArg -> Arity
manifestArity CoreArg
rhs)
                     | (Id
b, CoreArg
rhs) <- [(Id, CoreArg)]
pairs ]
        env' :: IdEnv HowBound
env' = IdEnv HowBound -> [(Id, HowBound)] -> IdEnv HowBound
forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList IdEnv HowBound
env [(Id, HowBound)]
extra_env'
        
        (CollectedCCs
ccs', [StgRhs]
stg_rhss)
          = DynFlags
-> IdEnv HowBound
-> CtsM (CollectedCCs, [StgRhs])
-> (CollectedCCs, [StgRhs])
forall a. DynFlags -> IdEnv HowBound -> CtsM a -> a
initCts DynFlags
dflags IdEnv HowBound
env' (CtsM (CollectedCCs, [StgRhs]) -> (CollectedCCs, [StgRhs]))
-> CtsM (CollectedCCs, [StgRhs]) -> (CollectedCCs, [StgRhs])
forall a b. (a -> b) -> a -> b
$
              (CollectedCCs -> (Id, CoreArg) -> CtsM (CollectedCCs, StgRhs))
-> CollectedCCs -> [(Id, CoreArg)] -> CtsM (CollectedCCs, [StgRhs])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (\CollectedCCs
ccs (Id, CoreArg)
rhs -> (StgRhs, CollectedCCs) -> (CollectedCCs, StgRhs)
forall a b. (a, b) -> (b, a)
swap ((StgRhs, CollectedCCs) -> (CollectedCCs, StgRhs))
-> CtsM (StgRhs, CollectedCCs) -> CtsM (CollectedCCs, StgRhs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags
-> CollectedCCs
-> Module
-> (Id, CoreArg)
-> CtsM (StgRhs, CollectedCCs)
coreToTopStgRhs DynFlags
dflags CollectedCCs
ccs Module
this_mod (Id, CoreArg)
rhs)
                         CollectedCCs
ccs
                         [(Id, CoreArg)]
pairs
        bind :: StgTopBinding
bind = GenStgBinding 'Vanilla -> StgTopBinding
forall (pass :: StgPass).
GenStgBinding pass -> GenStgTopBinding pass
StgTopLifted (GenStgBinding 'Vanilla -> StgTopBinding)
-> GenStgBinding 'Vanilla -> StgTopBinding
forall a b. (a -> b) -> a -> b
$ [(BinderP 'Vanilla, StgRhs)] -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec ([Id] -> [StgRhs] -> [(Id, StgRhs)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
binders [StgRhs]
stg_rhss)
    in
    (IdEnv HowBound
env', CollectedCCs
ccs', StgTopBinding
bind)
coreToTopStgRhs
        :: DynFlags
        -> CollectedCCs
        -> Module
        -> (Id,CoreExpr)
        -> CtsM (StgRhs, CollectedCCs)
coreToTopStgRhs :: DynFlags
-> CollectedCCs
-> Module
-> (Id, CoreArg)
-> CtsM (StgRhs, CollectedCCs)
coreToTopStgRhs DynFlags
dflags CollectedCCs
ccs Module
this_mod (Id
bndr, CoreArg
rhs)
  = do { PreStgRhs
new_rhs <- (() :: Constraint) => CoreArg -> CtsM PreStgRhs
CoreArg -> CtsM PreStgRhs
coreToPreStgRhs CoreArg
rhs
       ; let (StgRhs
stg_rhs, CollectedCCs
ccs') =
               DynFlags
-> Module
-> CollectedCCs
-> Id
-> PreStgRhs
-> (StgRhs, CollectedCCs)
mkTopStgRhs DynFlags
dflags Module
this_mod CollectedCCs
ccs Id
bndr PreStgRhs
new_rhs
             stg_arity :: Arity
stg_arity =
               StgRhs -> Arity
stgRhsArity StgRhs
stg_rhs
       ; (StgRhs, CollectedCCs) -> CtsM (StgRhs, CollectedCCs)
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> SDoc -> StgRhs -> StgRhs
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Arity -> Bool
arity_ok Arity
stg_arity) (Arity -> SDoc
mk_arity_msg Arity
stg_arity) StgRhs
stg_rhs,
                 CollectedCCs
ccs') }
  where
        
        
        
        
        
        
        
        
        
        
    arity_ok :: Arity -> Bool
arity_ok Arity
stg_arity
       | Name -> Bool
isExternalName (Id -> Name
idName Id
bndr) = Arity
id_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
stg_arity
       | Bool
otherwise                    = Bool
True
    id_arity :: Arity
id_arity  = Id -> Arity
idArity Id
bndr
    mk_arity_msg :: Arity -> SDoc
mk_arity_msg Arity
stg_arity
        = [SDoc] -> SDoc
vcat [Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr,
                String -> SDoc
text String
"Id arity:" SDoc -> SDoc -> SDoc
<+> Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
id_arity,
                String -> SDoc
text String
"STG arity:" SDoc -> SDoc -> SDoc
<+> Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
stg_arity]
coreToStgExpr
        :: HasDebugCallStack => CoreExpr
        -> CtsM StgExpr
coreToStgExpr :: (() :: Constraint) => CoreArg -> CtsM StgExpr
coreToStgExpr (Lit (LitNumber LitNumType
LitNumBigNat Integer
_))  = String -> CtsM StgExpr
forall a. String -> a
panic String
"coreToStgExpr: LitNumBigNat"
coreToStgExpr (Lit Literal
l)                           = StgExpr -> CtsM StgExpr
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> StgExpr
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
l)
coreToStgExpr (Var Id
v) = Id -> [CoreArg] -> [CoreTickish] -> CtsM StgExpr
coreToStgApp Id
v [] []
coreToStgExpr (Coercion Coercion
_)
  
  = Id -> [CoreArg] -> [CoreTickish] -> CtsM StgExpr
coreToStgApp Id
coercionTokenId [] []
coreToStgExpr expr :: CoreArg
expr@(App CoreArg
_ CoreArg
_)
  = case CoreArg
app_head of
      Var Id
f -> Id -> [CoreArg] -> [CoreTickish] -> CtsM StgExpr
coreToStgApp Id
f [CoreArg]
args [CoreTickish]
ticks 
      Lit Literal
l | Literal -> Bool
isLitRubbish Literal
l             
            -> StgExpr -> CtsM StgExpr
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> StgExpr
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
l)         
      CoreArg
_     -> String -> SDoc -> CtsM StgExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStgExpr - Invalid app head:" (CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
expr)
    where
      (CoreArg
app_head, [CoreArg]
args, [CoreTickish]
ticks) = (() :: Constraint) =>
CoreArg -> (CoreArg, [CoreArg], [CoreTickish])
CoreArg -> (CoreArg, [CoreArg], [CoreTickish])
myCollectArgs CoreArg
expr
coreToStgExpr expr :: CoreArg
expr@(Lam Id
_ CoreArg
_)
  = let
        ([Id]
args, CoreArg
body) = CoreArg -> ([Id], CoreArg)
myCollectBinders CoreArg
expr
    in
    case [Id] -> [Id]
filterStgBinders [Id]
args of
      [] -> (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
body
      [Id]
_ -> String -> SDoc -> CtsM StgExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coretoStgExpr" (SDoc -> CtsM StgExpr) -> SDoc -> CtsM StgExpr
forall a b. (a -> b) -> a -> b
$
        String -> SDoc
text String
"Unexpected value lambda:" SDoc -> SDoc -> SDoc
$$ CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
expr
coreToStgExpr (Tick CoreTickish
tick CoreArg
expr)
  = do
       let !stg_tick :: StgTickish
stg_tick = Type -> CoreTickish -> StgTickish
coreToStgTick ((() :: Constraint) => CoreArg -> Type
CoreArg -> Type
exprType CoreArg
expr) CoreTickish
tick
       !StgExpr
expr2 <- (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
expr
       StgExpr -> CtsM StgExpr
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (StgTickish -> StgExpr -> StgExpr
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
stg_tick StgExpr
expr2)
coreToStgExpr (Cast CoreArg
expr Coercion
_)
  = (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
expr
coreToStgExpr (Case CoreArg
scrut Id
bndr Type
_ [Alt Id]
alts)
  = do { StgExpr
scrut2 <- (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
scrut
       ; [StgAlt]
alts2 <- [(Id, HowBound)] -> CtsM [StgAlt] -> CtsM [StgAlt]
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Id
bndr, HowBound
LambdaBound)] ((Alt Id -> CtsM StgAlt) -> [Alt Id] -> CtsM [StgAlt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Alt Id -> CtsM StgAlt
vars_alt [Alt Id]
alts)
       ; StgExpr -> CtsM StgExpr
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (StgExpr -> BinderP 'Vanilla -> AltType -> [StgAlt] -> StgExpr
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase StgExpr
scrut2 Id
BinderP 'Vanilla
bndr (Id -> [Alt Id] -> AltType
mkStgAltType Id
bndr [Alt Id]
alts) [StgAlt]
alts2) }
  where
    vars_alt :: CoreAlt -> CtsM StgAlt
    vars_alt :: Alt Id -> CtsM StgAlt
vars_alt (Alt AltCon
con [Id]
binders CoreArg
rhs)
      | DataAlt DataCon
c <- AltCon
con, DataCon
c DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
unboxedUnitDataCon
      = 
        
        
        Bool -> CtsM StgAlt -> CtsM StgAlt
forall a. HasCallStack => Bool -> a -> a
assert ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
binders) (CtsM StgAlt -> CtsM StgAlt) -> CtsM StgAlt -> CtsM StgAlt
forall a b. (a -> b) -> a -> b
$
        do { StgExpr
rhs2 <- (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
rhs
           ; StgAlt -> CtsM StgAlt
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return GenStgAlt{alt_con :: AltCon
alt_con=AltCon
DEFAULT,alt_bndrs :: [BinderP 'Vanilla]
alt_bndrs=[Id]
[BinderP 'Vanilla]
forall a. Monoid a => a
mempty,alt_rhs :: StgExpr
alt_rhs=StgExpr
rhs2}
           }
      | Bool
otherwise
      = let     
            binders' :: [Id]
binders' = [Id] -> [Id]
filterStgBinders [Id]
binders
        in
        [(Id, HowBound)] -> CtsM StgAlt -> CtsM StgAlt
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Id
b, HowBound
LambdaBound) | Id
b <- [Id]
binders'] (CtsM StgAlt -> CtsM StgAlt) -> CtsM StgAlt -> CtsM StgAlt
forall a b. (a -> b) -> a -> b
$ do
        StgExpr
rhs2 <- (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
rhs
        StgAlt -> CtsM StgAlt
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (StgAlt -> CtsM StgAlt) -> StgAlt -> CtsM StgAlt
forall a b. (a -> b) -> a -> b
$! GenStgAlt{ alt_con :: AltCon
alt_con   = AltCon
con
                           , alt_bndrs :: [BinderP 'Vanilla]
alt_bndrs = [Id]
[BinderP 'Vanilla]
binders'
                           , alt_rhs :: StgExpr
alt_rhs   = StgExpr
rhs2
                           }
coreToStgExpr (Let CoreBind
bind CoreArg
body) = CoreBind -> CoreArg -> CtsM StgExpr
coreToStgLet CoreBind
bind CoreArg
body
coreToStgExpr CoreArg
e               = String -> SDoc -> CtsM StgExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStgExpr" (CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
e)
mkStgAltType :: Id -> [CoreAlt] -> AltType
mkStgAltType :: Id -> [Alt Id] -> AltType
mkStgAltType Id
bndr [Alt Id]
alts
  | Type -> Bool
isUnboxedTupleType Type
bndr_ty Bool -> Bool -> Bool
|| Type -> Bool
isUnboxedSumType Type
bndr_ty
  = Arity -> AltType
MultiValAlt ([PrimRep] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [PrimRep]
prim_reps)  
  | Bool
otherwise
  = case [PrimRep]
prim_reps of
      [PrimRep
rep] | PrimRep -> Bool
isGcPtrRep PrimRep
rep ->
        case Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
unwrapType Type
bndr_ty) of
          Just TyCon
tc
            | TyCon -> Bool
isAbstractTyCon TyCon
tc -> AltType
look_for_better_tycon
            | TyCon -> Bool
isAlgTyCon TyCon
tc      -> TyCon -> AltType
AlgAlt TyCon
tc
            | Bool
otherwise          -> Bool -> SDoc -> AltType -> AltType
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TyCon -> Bool
_is_poly_alt_tycon TyCon
tc) (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) AltType
PolyAlt
          Maybe TyCon
Nothing                -> AltType
PolyAlt
      [PrimRep
non_gcd] -> PrimRep -> AltType
PrimAlt PrimRep
non_gcd
      [PrimRep]
not_unary -> Arity -> AltType
MultiValAlt ([PrimRep] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [PrimRep]
not_unary)
  where
   bndr_ty :: Type
bndr_ty   = Id -> Type
idType Id
bndr
   prim_reps :: [PrimRep]
prim_reps = (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
bndr_ty
   _is_poly_alt_tycon :: TyCon -> Bool
_is_poly_alt_tycon TyCon
tc
        =  TyCon -> Bool
isFunTyCon TyCon
tc
        Bool -> Bool -> Bool
|| TyCon -> Bool
isPrimTyCon TyCon
tc   
        Bool -> Bool -> Bool
|| TyCon -> Bool
isFamilyTyCon TyCon
tc 
                            
                            
   
   
   
   
   look_for_better_tycon :: AltType
look_for_better_tycon
        | ((Alt (DataAlt DataCon
con) [Id]
_ CoreArg
_) : [Alt Id]
_) <- [Alt Id]
data_alts =
                TyCon -> AltType
AlgAlt (DataCon -> TyCon
dataConTyCon DataCon
con)
        | Bool
otherwise =
                Bool -> AltType -> AltType
forall a. HasCallStack => Bool -> a -> a
assert ([Alt Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
data_alts)
                AltType
PolyAlt
        where
                ([Alt Id]
data_alts, Maybe CoreArg
_deflt) = [Alt Id] -> ([Alt Id], Maybe CoreArg)
forall b. [Alt b] -> ([Alt b], Maybe (Expr b))
findDefault [Alt Id]
alts
coreToStgApp :: Id            
             -> [CoreArg]     
             -> [CoreTickish] 
             -> CtsM StgExpr
coreToStgApp :: Id -> [CoreArg] -> [CoreTickish] -> CtsM StgExpr
coreToStgApp Id
f [CoreArg]
args [CoreTickish]
ticks = do
    ([StgArg]
args', [StgTickish]
ticks') <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [CoreArg]
args
    HowBound
how_bound <- Id -> CtsM HowBound
lookupVarCts Id
f
    let
        n_val_args :: Arity
n_val_args       = [CoreArg] -> Arity
forall b. [Arg b] -> Arity
valArgCount [CoreArg]
args
        
        
        
        
        
        
        
        f_arity :: Arity
f_arity   = Id -> HowBound -> Arity
stgArity Id
f HowBound
how_bound
        saturated :: Bool
saturated = Arity
f_arity Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
<= Arity
n_val_args
        res_ty :: Type
res_ty = (() :: Constraint) => CoreArg -> Type
CoreArg -> Type
exprType (CoreArg -> [CoreArg] -> CoreArg
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreArg
forall b. Id -> Expr b
Var Id
f) [CoreArg]
args)
        app :: StgExpr
app = case Id -> IdDetails
idDetails Id
f of
                DataConWorkId DataCon
dc
                  | Bool
saturated    -> DataCon -> ConstructorNumber -> [StgArg] -> [Type] -> StgExpr
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
NoNumber [StgArg]
args'
                                      ([Type] -> [Type]
dropRuntimeRepArgs ([Type] -> Maybe [Type] -> [Type]
forall a. a -> Maybe a -> a
fromMaybe [] (Type -> Maybe [Type]
tyConAppArgs_maybe Type
res_ty)))
                
                
                
                PrimOpId PrimOp
op      -> Bool -> StgExpr -> StgExpr
forall a. HasCallStack => Bool -> a -> a
assert Bool
saturated (StgExpr -> StgExpr) -> StgExpr -> StgExpr
forall a b. (a -> b) -> a -> b
$
                                    StgOp -> [StgArg] -> Type -> StgExpr
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (PrimOp -> StgOp
StgPrimOp PrimOp
op) [StgArg]
args' Type
res_ty
                
                FCallId (CCall (CCallSpec (StaticTarget SourceText
_ CLabelString
lbl (Just Unit
pkgId) Bool
True)
                                          CCallConv
PrimCallConv Safety
_))
                                 -> Bool -> StgExpr -> StgExpr
forall a. HasCallStack => Bool -> a -> a
assert Bool
saturated (StgExpr -> StgExpr) -> StgExpr -> StgExpr
forall a b. (a -> b) -> a -> b
$
                                    StgOp -> [StgArg] -> Type -> StgExpr
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (PrimCall -> StgOp
StgPrimCallOp (CLabelString -> Unit -> PrimCall
PrimCall CLabelString
lbl Unit
pkgId)) [StgArg]
args' Type
res_ty
                
                FCallId ForeignCall
call     -> Bool -> StgExpr -> StgExpr
forall a. HasCallStack => Bool -> a -> a
assert Bool
saturated (StgExpr -> StgExpr) -> StgExpr -> StgExpr
forall a b. (a -> b) -> a -> b
$
                                    StgOp -> [StgArg] -> Type -> StgExpr
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (ForeignCall -> Type -> StgOp
StgFCallOp ForeignCall
call (Id -> Type
idType Id
f)) [StgArg]
args' Type
res_ty
                TickBoxOpId {}   -> String -> SDoc -> StgExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStg TickBox" (SDoc -> StgExpr) -> SDoc -> StgExpr
forall a b. (a -> b) -> a -> b
$ (Id, [StgArg]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id
f,[StgArg]
args')
                IdDetails
_other           -> Id -> [StgArg] -> StgExpr
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
f [StgArg]
args'
        add_tick :: StgTickish -> GenStgExpr pass -> GenStgExpr pass
add_tick !StgTickish
t !GenStgExpr pass
e = StgTickish -> GenStgExpr pass -> GenStgExpr pass
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
t GenStgExpr pass
e
        tapp :: StgExpr
tapp = (StgTickish -> StgExpr -> StgExpr)
-> StgExpr -> [StgTickish] -> StgExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr StgTickish -> StgExpr -> StgExpr
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
add_tick StgExpr
app ((CoreTickish -> StgTickish) -> [CoreTickish] -> [StgTickish]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> CoreTickish -> StgTickish
coreToStgTick Type
res_ty) [CoreTickish]
ticks [StgTickish] -> [StgTickish] -> [StgTickish]
forall a. [a] -> [a] -> [a]
++ [StgTickish]
ticks')
    
    
    StgExpr
app StgExpr -> CtsM StgExpr -> CtsM StgExpr
forall a b. a -> b -> b
`seq` StgExpr -> CtsM StgExpr
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return StgExpr
tapp
coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs []
  = ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
coreToStgArgs (Type Type
_ : [CoreArg]
args) = do     
    ([StgArg]
args', [StgTickish]
ts) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [CoreArg]
args
    ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([StgArg]
args', [StgTickish]
ts)
coreToStgArgs (Coercion Coercion
_ : [CoreArg]
args) 
  = do { ([StgArg]
args', [StgTickish]
ts) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [CoreArg]
args
       ; ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> StgArg
StgVarArg Id
coercionTokenId StgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
: [StgArg]
args', [StgTickish]
ts) }
coreToStgArgs (Tick CoreTickish
t CoreArg
e : [CoreArg]
args)
  = Bool
-> CtsM ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t)) (CtsM ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish]))
-> CtsM ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a b. (a -> b) -> a -> b
$
    do { ([StgArg]
args', [StgTickish]
ts) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs (CoreArg
e CoreArg -> [CoreArg] -> [CoreArg]
forall a. a -> [a] -> [a]
: [CoreArg]
args)
       ; let !t' :: StgTickish
t' = Type -> CoreTickish -> StgTickish
coreToStgTick ((() :: Constraint) => CoreArg -> Type
CoreArg -> Type
exprType CoreArg
e) CoreTickish
t
       ; ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([StgArg]
args', StgTickish
t'StgTickish -> [StgTickish] -> [StgTickish]
forall a. a -> [a] -> [a]
:[StgTickish]
ts) }
coreToStgArgs (CoreArg
arg : [CoreArg]
args) = do         
    ([StgArg]
stg_args, [StgTickish]
ticks) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [CoreArg]
args
    StgExpr
arg' <- (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
arg
    let
        ([StgTickish]
aticks, StgExpr
arg'') = (StgTickish -> Bool) -> StgExpr -> ([StgTickish], StgExpr)
forall (p :: StgPass).
(StgTickish -> Bool)
-> GenStgExpr p -> ([StgTickish], GenStgExpr p)
stripStgTicksTop StgTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable StgExpr
arg'
        stg_arg :: StgArg
stg_arg = case StgExpr
arg'' of
                       StgApp Id
v []        -> Id -> StgArg
StgVarArg Id
v
                       StgConApp DataCon
con ConstructorNumber
_ [] [Type]
_ -> Id -> StgArg
StgVarArg (DataCon -> Id
dataConWorkId DataCon
con)
                       StgLit Literal
lit         -> Literal -> StgArg
StgLitArg Literal
lit
                       StgExpr
_                  -> String -> SDoc -> StgArg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStgArgs" (CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
arg)
        
        
        
        
        
        
        
        
        
    Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> CtsM DynFlags -> CtsM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CtsM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let
        arg_rep :: [PrimRep]
arg_rep = (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep ((() :: Constraint) => CoreArg -> Type
CoreArg -> Type
exprType CoreArg
arg)
        stg_arg_rep :: [PrimRep]
stg_arg_rep = (() :: Constraint) => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep (StgArg -> Type
stgArgType StgArg
stg_arg)
        bad_args :: Bool
bad_args = Bool -> Bool
not (Platform -> [PrimRep] -> [PrimRep] -> Bool
primRepsCompatible Platform
platform [PrimRep]
arg_rep [PrimRep]
stg_arg_rep)
    Bool
-> String
-> SDoc
-> CtsM ([StgArg], [StgTickish])
-> CtsM ([StgArg], [StgTickish])
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
bad_args String
"Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
arg) (CtsM ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish]))
-> CtsM ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a b. (a -> b) -> a -> b
$
     ([StgArg], [StgTickish]) -> CtsM ([StgArg], [StgTickish])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (StgArg
stg_arg StgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
: [StgArg]
stg_args, [StgTickish]
ticks [StgTickish] -> [StgTickish] -> [StgTickish]
forall a. [a] -> [a] -> [a]
++ [StgTickish]
aticks)
coreToStgTick :: Type 
              -> CoreTickish
              -> StgTickish
coreToStgTick :: Type -> CoreTickish -> StgTickish
coreToStgTick Type
_ty (HpcTick Module
m Arity
i)           = Module -> Arity -> StgTickish
forall (pass :: TickishPass). Module -> Arity -> GenTickish pass
HpcTick Module
m Arity
i
coreToStgTick Type
_ty (SourceNote RealSrcSpan
span String
nm)    = RealSrcSpan -> String -> StgTickish
forall (pass :: TickishPass).
RealSrcSpan -> String -> GenTickish pass
SourceNote RealSrcSpan
span String
nm
coreToStgTick Type
_ty (ProfNote CostCentre
cc Bool
cnt Bool
scope) = CostCentre -> Bool -> Bool -> StgTickish
forall (pass :: TickishPass).
CostCentre -> Bool -> Bool -> GenTickish pass
ProfNote CostCentre
cc Bool
cnt Bool
scope
coreToStgTick !Type
ty (Breakpoint XBreakpoint 'TickishPassCore
_ Arity
bid [XTickishId 'TickishPassCore]
fvs)  = XBreakpoint 'TickishPassStg
-> Arity -> [XTickishId 'TickishPassStg] -> StgTickish
forall (pass :: TickishPass).
XBreakpoint pass -> Arity -> [XTickishId pass] -> GenTickish pass
Breakpoint Type
XBreakpoint 'TickishPassStg
ty Arity
bid [XTickishId 'TickishPassCore]
[XTickishId 'TickishPassStg]
fvs
coreToStgLet
         :: CoreBind     
         -> CoreExpr     
         -> CtsM StgExpr 
coreToStgLet :: CoreBind -> CoreArg -> CtsM StgExpr
coreToStgLet CoreBind
bind CoreArg
body
  | NonRec Id
_ CoreArg
rhs <- CoreBind
bind, CoreArg -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreArg
rhs
  = (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
body
  | Bool
otherwise
  = do { (GenStgBinding 'Vanilla
bind2, [(Id, HowBound)]
env_ext) <- CoreBind -> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
vars_bind CoreBind
bind
          
         ; StgExpr
body2 <- [(Id, HowBound)] -> CtsM StgExpr -> CtsM StgExpr
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Id, HowBound)]
env_ext (CtsM StgExpr -> CtsM StgExpr) -> CtsM StgExpr -> CtsM StgExpr
forall a b. (a -> b) -> a -> b
$
                    (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
body
        
        ; let new_let :: StgExpr
new_let | CoreBind -> Bool
isJoinBind CoreBind
bind
                      = XLetNoEscape 'Vanilla
-> GenStgBinding 'Vanilla -> StgExpr -> StgExpr
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape 'Vanilla
NoExtFieldSilent
noExtFieldSilent GenStgBinding 'Vanilla
bind2 StgExpr
body2
                      | Bool
otherwise
                      = XLet 'Vanilla -> GenStgBinding 'Vanilla -> StgExpr -> StgExpr
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
NoExtFieldSilent
noExtFieldSilent GenStgBinding 'Vanilla
bind2 StgExpr
body2
        ; StgExpr -> CtsM StgExpr
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return StgExpr
new_let }
  where
    mk_binding :: a -> CoreArg -> (a, HowBound)
mk_binding a
binder CoreArg
rhs
        = (a
binder, LetInfo -> Arity -> HowBound
LetBound LetInfo
NestedLet (CoreArg -> Arity
manifestArity CoreArg
rhs))
    vars_bind :: CoreBind
              -> CtsM (StgBinding,
                       [(Id, HowBound)])  
    vars_bind :: CoreBind -> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
vars_bind (NonRec Id
binder CoreArg
rhs) = do
        StgRhs
rhs2 <- (Id, CoreArg) -> CtsM StgRhs
coreToStgRhs (Id
binder,CoreArg
rhs)
        let
            env_ext_item :: (Id, HowBound)
env_ext_item = Id -> CoreArg -> (Id, HowBound)
forall {a}. a -> CoreArg -> (a, HowBound)
mk_binding Id
binder CoreArg
rhs
        (GenStgBinding 'Vanilla, [(Id, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinderP 'Vanilla -> StgRhs -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec Id
BinderP 'Vanilla
binder StgRhs
rhs2, [(Id, HowBound)
env_ext_item])
    vars_bind (Rec [(Id, CoreArg)]
pairs)
      =    let
                binders :: [Id]
binders = ((Id, CoreArg) -> Id) -> [(Id, CoreArg)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreArg) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreArg)]
pairs
                env_ext :: [(Id, HowBound)]
env_ext = [ Id -> CoreArg -> (Id, HowBound)
forall {a}. a -> CoreArg -> (a, HowBound)
mk_binding Id
b CoreArg
rhs
                          | (Id
b,CoreArg
rhs) <- [(Id, CoreArg)]
pairs ]
           in
           [(Id, HowBound)]
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Id, HowBound)]
env_ext (CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
 -> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)]))
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
forall a b. (a -> b) -> a -> b
$ do
              [StgRhs]
rhss2 <- ((Id, CoreArg) -> CtsM StgRhs) -> [(Id, CoreArg)] -> CtsM [StgRhs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id, CoreArg) -> CtsM StgRhs
coreToStgRhs [(Id, CoreArg)]
pairs
              (GenStgBinding 'Vanilla, [(Id, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(BinderP 'Vanilla, StgRhs)] -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec ([Id]
binders [Id] -> [StgRhs] -> [(Id, StgRhs)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [StgRhs]
rhss2), [(Id, HowBound)]
env_ext)
coreToStgRhs :: (Id,CoreExpr)
             -> CtsM StgRhs
coreToStgRhs :: (Id, CoreArg) -> CtsM StgRhs
coreToStgRhs (Id
bndr, CoreArg
rhs) = do
    PreStgRhs
new_rhs <- (() :: Constraint) => CoreArg -> CtsM PreStgRhs
CoreArg -> CtsM PreStgRhs
coreToPreStgRhs CoreArg
rhs
    StgRhs -> CtsM StgRhs
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> PreStgRhs -> StgRhs
mkStgRhs Id
bndr PreStgRhs
new_rhs)
data PreStgRhs = PreStgRhs [Id] StgExpr 
coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs
coreToPreStgRhs :: (() :: Constraint) => CoreArg -> CtsM PreStgRhs
coreToPreStgRhs (Cast CoreArg
expr Coercion
_) = (() :: Constraint) => CoreArg -> CtsM PreStgRhs
CoreArg -> CtsM PreStgRhs
coreToPreStgRhs CoreArg
expr
coreToPreStgRhs expr :: CoreArg
expr@(Lam Id
_ CoreArg
_) =
    let
        ([Id]
args, CoreArg
body) = CoreArg -> ([Id], CoreArg)
myCollectBinders CoreArg
expr
        args' :: [Id]
args'        = [Id] -> [Id]
filterStgBinders [Id]
args
    in
        [(Id, HowBound)] -> CtsM PreStgRhs -> CtsM PreStgRhs
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [ (Id
a, HowBound
LambdaBound) | Id
a <- [Id]
args' ] (CtsM PreStgRhs -> CtsM PreStgRhs)
-> CtsM PreStgRhs -> CtsM PreStgRhs
forall a b. (a -> b) -> a -> b
$ do
          StgExpr
body' <- (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
body
          PreStgRhs -> CtsM PreStgRhs
forall a. a -> CtsM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id] -> StgExpr -> PreStgRhs
PreStgRhs [Id]
args' StgExpr
body')
coreToPreStgRhs CoreArg
expr = [Id] -> StgExpr -> PreStgRhs
PreStgRhs [] (StgExpr -> PreStgRhs) -> CtsM StgExpr -> CtsM PreStgRhs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (() :: Constraint) => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
expr
mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
            -> Id -> PreStgRhs -> (StgRhs, CollectedCCs)
mkTopStgRhs :: DynFlags
-> Module
-> CollectedCCs
-> Id
-> PreStgRhs
-> (StgRhs, CollectedCCs)
mkTopStgRhs DynFlags
dflags Module
this_mod CollectedCCs
ccs Id
bndr (PreStgRhs [Id]
bndrs StgExpr
rhs)
  | Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bndrs)
  = 
    ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                    CostCentreStack
dontCareCCS
                    UpdateFlag
ReEntrant
                    [Id]
[BinderP 'Vanilla]
bndrs StgExpr
rhs
    , CollectedCCs
ccs )
  
  
  | StgConApp DataCon
con ConstructorNumber
mn [StgArg]
args [Type]
_ <- StgExpr
unticked_rhs
  , 
    Bool -> Bool
not (Platform -> Bool -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp (DynFlags -> Platform
targetPlatform DynFlags
dflags) (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalDynamicRefs DynFlags
dflags) Module
this_mod DataCon
con [StgArg]
args)
  = 
    Bool -> SDoc -> (StgRhs, CollectedCCs) -> (StgRhs, CollectedCCs)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not (DataCon -> Bool
isUnboxedTupleDataCon DataCon
con Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
con))
              (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr SDoc -> SDoc -> SDoc
$$ DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
$$ [StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args)
    ( CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> StgRhs
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs pass
StgRhsCon CostCentreStack
dontCareCCS DataCon
con ConstructorNumber
mn [StgTickish]
ticks [StgArg]
args, CollectedCCs
ccs )
  
  | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AutoSccsOnIndividualCafs DynFlags
dflags
  = ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                    CostCentreStack
caf_ccs
                    UpdateFlag
upd_flag [] StgExpr
rhs
    , CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
collectCC CostCentre
caf_cc CostCentreStack
caf_ccs CollectedCCs
ccs )
  | Bool
otherwise
  = ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                    CostCentreStack
all_cafs_ccs
                    UpdateFlag
upd_flag [] StgExpr
rhs
    , CollectedCCs
ccs )
  where
    ([StgTickish]
ticks, StgExpr
unticked_rhs) = (StgTickish -> Bool) -> StgExpr -> ([StgTickish], StgExpr)
forall (p :: StgPass).
(StgTickish -> Bool)
-> GenStgExpr p -> ([StgTickish], GenStgExpr p)
stripStgTicksTop (Bool -> Bool
not (Bool -> Bool) -> (StgTickish -> Bool) -> StgTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode) StgExpr
rhs
    upd_flag :: UpdateFlag
upd_flag | Demand -> Bool
isUsedOnceDmd (Id -> Demand
idDemandInfo Id
bndr) = UpdateFlag
SingleEntry
             | Bool
otherwise                         = UpdateFlag
Updatable
    
    caf_cc :: CostCentre
caf_cc = Id -> Module -> CostCentre
mkAutoCC Id
bndr Module
modl
    caf_ccs :: CostCentreStack
caf_ccs = CostCentre -> CostCentreStack
mkSingletonCCS CostCentre
caf_cc
           
           
           
    modl :: Module
modl | Just Module
m <- Name -> Maybe Module
nameModule_maybe (Id -> Name
idName Id
bndr) = Module
m
         | Bool
otherwise = Module
this_mod
    
    (CostCentre
_, CostCentreStack
all_cafs_ccs) = Module -> (CostCentre, CostCentreStack)
getAllCAFsCC Module
this_mod
mkStgRhs :: Id -> PreStgRhs -> StgRhs
mkStgRhs :: Id -> PreStgRhs -> StgRhs
mkStgRhs Id
bndr (PreStgRhs [Id]
bndrs StgExpr
rhs)
  | Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bndrs)
  = XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                  CostCentreStack
currentCCS
                  UpdateFlag
ReEntrant
                  [Id]
[BinderP 'Vanilla]
bndrs StgExpr
rhs
  
  
  | Id -> Bool
isJoinId Id
bndr 
  = 
    
    XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                  CostCentreStack
currentCCS
                  UpdateFlag
ReEntrant 
                  [] StgExpr
rhs
  | StgConApp DataCon
con ConstructorNumber
mn [StgArg]
args [Type]
_ <- StgExpr
unticked_rhs
  = CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> StgRhs
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> GenStgRhs pass
StgRhsCon CostCentreStack
currentCCS DataCon
con ConstructorNumber
mn [StgTickish]
ticks [StgArg]
args
  | Bool
otherwise
  = XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                  CostCentreStack
currentCCS
                  UpdateFlag
upd_flag [] StgExpr
rhs
  where
    ([StgTickish]
ticks, StgExpr
unticked_rhs) = (StgTickish -> Bool) -> StgExpr -> ([StgTickish], StgExpr)
forall (p :: StgPass).
(StgTickish -> Bool)
-> GenStgExpr p -> ([StgTickish], GenStgExpr p)
stripStgTicksTop (Bool -> Bool
not (Bool -> Bool) -> (StgTickish -> Bool) -> StgTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode) StgExpr
rhs
    upd_flag :: UpdateFlag
upd_flag | Demand -> Bool
isUsedOnceDmd (Id -> Demand
idDemandInfo Id
bndr) = UpdateFlag
SingleEntry
             | Bool
otherwise                         = UpdateFlag
Updatable
  
newtype CtsM a = CtsM
    { forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
unCtsM :: DynFlags 
             -> IdEnv HowBound
             -> a
    }
    deriving ((forall a b. (a -> b) -> CtsM a -> CtsM b)
-> (forall a b. a -> CtsM b -> CtsM a) -> Functor CtsM
forall a b. a -> CtsM b -> CtsM a
forall a b. (a -> b) -> CtsM a -> CtsM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> CtsM a -> CtsM b
fmap :: forall a b. (a -> b) -> CtsM a -> CtsM b
$c<$ :: forall a b. a -> CtsM b -> CtsM a
<$ :: forall a b. a -> CtsM b -> CtsM a
Functor)
data HowBound
  = ImportBound         
                        
  | LetBound            
        LetInfo         
        Arity           
  | LambdaBound         
  deriving (HowBound -> HowBound -> Bool
(HowBound -> HowBound -> Bool)
-> (HowBound -> HowBound -> Bool) -> Eq HowBound
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HowBound -> HowBound -> Bool
== :: HowBound -> HowBound -> Bool
$c/= :: HowBound -> HowBound -> Bool
/= :: HowBound -> HowBound -> Bool
Eq)
data LetInfo
  = TopLet              
  | NestedLet
  deriving (LetInfo -> LetInfo -> Bool
(LetInfo -> LetInfo -> Bool)
-> (LetInfo -> LetInfo -> Bool) -> Eq LetInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LetInfo -> LetInfo -> Bool
== :: LetInfo -> LetInfo -> Bool
$c/= :: LetInfo -> LetInfo -> Bool
/= :: LetInfo -> LetInfo -> Bool
Eq)
initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a
initCts :: forall a. DynFlags -> IdEnv HowBound -> CtsM a -> a
initCts DynFlags
dflags IdEnv HowBound
env CtsM a
m = CtsM a -> DynFlags -> IdEnv HowBound -> a
forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
unCtsM CtsM a
m DynFlags
dflags IdEnv HowBound
env
{-# INLINE thenCts #-}
{-# INLINE returnCts #-}
returnCts :: a -> CtsM a
returnCts :: forall a. a -> CtsM a
returnCts a
e = (DynFlags -> IdEnv HowBound -> a) -> CtsM a
forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
CtsM ((DynFlags -> IdEnv HowBound -> a) -> CtsM a)
-> (DynFlags -> IdEnv HowBound -> a) -> CtsM a
forall a b. (a -> b) -> a -> b
$ \DynFlags
_ IdEnv HowBound
_ -> a
e
thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
thenCts :: forall a b. CtsM a -> (a -> CtsM b) -> CtsM b
thenCts CtsM a
m a -> CtsM b
k = (DynFlags -> IdEnv HowBound -> b) -> CtsM b
forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
CtsM ((DynFlags -> IdEnv HowBound -> b) -> CtsM b)
-> (DynFlags -> IdEnv HowBound -> b) -> CtsM b
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags IdEnv HowBound
env
  -> CtsM b -> DynFlags -> IdEnv HowBound -> b
forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
unCtsM (a -> CtsM b
k (CtsM a -> DynFlags -> IdEnv HowBound -> a
forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
unCtsM CtsM a
m DynFlags
dflags IdEnv HowBound
env)) DynFlags
dflags IdEnv HowBound
env
instance Applicative CtsM where
    pure :: forall a. a -> CtsM a
pure = a -> CtsM a
forall a. a -> CtsM a
returnCts
    <*> :: forall a b. CtsM (a -> b) -> CtsM a -> CtsM b
(<*>) = CtsM (a -> b) -> CtsM a -> CtsM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad CtsM where
    >>= :: forall a b. CtsM a -> (a -> CtsM b) -> CtsM b
(>>=)  = CtsM a -> (a -> CtsM b) -> CtsM b
forall a b. CtsM a -> (a -> CtsM b) -> CtsM b
thenCts
instance HasDynFlags CtsM where
    getDynFlags :: CtsM DynFlags
getDynFlags = (DynFlags -> IdEnv HowBound -> DynFlags) -> CtsM DynFlags
forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
CtsM ((DynFlags -> IdEnv HowBound -> DynFlags) -> CtsM DynFlags)
-> (DynFlags -> IdEnv HowBound -> DynFlags) -> CtsM DynFlags
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags IdEnv HowBound
_ -> DynFlags
dflags
extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts :: forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Id, HowBound)]
ids_w_howbound CtsM a
expr
   =    (DynFlags -> IdEnv HowBound -> a) -> CtsM a
forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
CtsM ((DynFlags -> IdEnv HowBound -> a) -> CtsM a)
-> (DynFlags -> IdEnv HowBound -> a) -> CtsM a
forall a b. (a -> b) -> a -> b
$   \DynFlags
dflags IdEnv HowBound
env
   -> CtsM a -> DynFlags -> IdEnv HowBound -> a
forall a. CtsM a -> DynFlags -> IdEnv HowBound -> a
unCtsM CtsM a
expr DynFlags
dflags (IdEnv HowBound -> [(Id, HowBound)] -> IdEnv HowBound
forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList IdEnv HowBound
env [(Id, HowBound)]
ids_w_howbound)
lookupVarCts :: Id -> CtsM HowBound
lookupVarCts :: Id -> CtsM HowBound
lookupVarCts Id
v = (DynFlags -> IdEnv HowBound -> HowBound) -> CtsM HowBound
forall a. (DynFlags -> IdEnv HowBound -> a) -> CtsM a
CtsM ((DynFlags -> IdEnv HowBound -> HowBound) -> CtsM HowBound)
-> (DynFlags -> IdEnv HowBound -> HowBound) -> CtsM HowBound
forall a b. (a -> b) -> a -> b
$ \DynFlags
_ IdEnv HowBound
env -> IdEnv HowBound -> Id -> HowBound
lookupBinding IdEnv HowBound
env Id
v
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding IdEnv HowBound
env Id
v = case IdEnv HowBound -> Id -> Maybe HowBound
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdEnv HowBound
env Id
v of
                        Just HowBound
xx -> HowBound
xx
                        Maybe HowBound
Nothing -> Bool -> SDoc -> HowBound -> HowBound
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isGlobalId Id
v) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v) HowBound
ImportBound
getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
getAllCAFsCC Module
this_mod =
    let
      span :: SrcSpan
span = CLabelString -> SrcSpan
mkGeneralSrcSpan (String -> CLabelString
mkFastString String
"<entire-module>") 
      all_cafs_cc :: CostCentre
all_cafs_cc  = Module -> SrcSpan -> CostCentre
mkAllCafsCC Module
this_mod SrcSpan
span
      all_cafs_ccs :: CostCentreStack
all_cafs_ccs = CostCentre -> CostCentreStack
mkSingletonCCS CostCentre
all_cafs_cc
    in
      (CostCentre
all_cafs_cc, CostCentreStack
all_cafs_ccs)
filterStgBinders :: [Var] -> [Var]
filterStgBinders :: [Id] -> [Id]
filterStgBinders [Id]
bndrs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isId [Id]
bndrs
myCollectBinders :: Expr Var -> ([Var], Expr Var)
myCollectBinders :: CoreArg -> ([Id], CoreArg)
myCollectBinders CoreArg
expr
  = [Id] -> CoreArg -> ([Id], CoreArg)
forall {a}. [a] -> Expr a -> ([a], Expr a)
go [] CoreArg
expr
  where
    go :: [a] -> Expr a -> ([a], Expr a)
go [a]
bs (Lam a
b Expr a
e)          = [a] -> Expr a -> ([a], Expr a)
go (a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
bs) Expr a
e
    go [a]
bs (Cast Expr a
e Coercion
_)         = [a] -> Expr a -> ([a], Expr a)
go [a]
bs Expr a
e
    go [a]
bs Expr a
e                  = ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
bs, Expr a
e)
myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish])
myCollectArgs :: (() :: Constraint) =>
CoreArg -> (CoreArg, [CoreArg], [CoreTickish])
myCollectArgs CoreArg
expr
  = CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
expr [] []
  where
    go :: CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go h :: CoreArg
h@(Var Id
_v)       [CoreArg]
as [CoreTickish]
ts = (CoreArg
h, [CoreArg]
as, [CoreTickish]
ts)
    go (App CoreArg
f CoreArg
a)        [CoreArg]
as [CoreTickish]
ts = CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
f (CoreArg
aCoreArg -> [CoreArg] -> [CoreArg]
forall a. a -> [a] -> [a]
:[CoreArg]
as) [CoreTickish]
ts
    go (Tick CoreTickish
t CoreArg
e)       [CoreArg]
as [CoreTickish]
ts = Bool
-> SDoc
-> (CoreArg, [CoreArg], [CoreTickish])
-> (CoreArg, [CoreArg], [CoreTickish])
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t) Bool -> Bool -> Bool
|| (CoreArg -> Bool) -> [CoreArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CoreArg -> Bool
forall b. Expr b -> Bool
isTypeArg [CoreArg]
as)
                                          (CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
e SDoc -> SDoc -> SDoc
$$ [CoreArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreArg]
as SDoc -> SDoc -> SDoc
$$ [CoreTickish] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreTickish]
ts) ((CoreArg, [CoreArg], [CoreTickish])
 -> (CoreArg, [CoreArg], [CoreTickish]))
-> (CoreArg, [CoreArg], [CoreTickish])
-> (CoreArg, [CoreArg], [CoreTickish])
forall a b. (a -> b) -> a -> b
$
                                
                                CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
e [CoreArg]
as (CoreTickish
tCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
ts) 
    go (Cast CoreArg
e Coercion
_)       [CoreArg]
as [CoreTickish]
ts = CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
e [CoreArg]
as [CoreTickish]
ts
    go (Lam Id
b CoreArg
e)        [CoreArg]
as [CoreTickish]
ts
       | Id -> Bool
isTyVar Id
b            = CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
e [CoreArg]
as [CoreTickish]
ts 
    go CoreArg
e                [CoreArg]
as [CoreTickish]
ts = (CoreArg
e, [CoreArg]
as, [CoreTickish]
ts)
stgArity :: Id -> HowBound -> Arity
stgArity :: Id -> HowBound -> Arity
stgArity Id
_ (LetBound LetInfo
_ Arity
arity) = Arity
arity
stgArity Id
f HowBound
ImportBound        = Id -> Arity
idArity Id
f
stgArity Id
_ HowBound
LambdaBound        = Arity
0