{-# LANGUAGE CPP, DeriveFunctor #-}

--
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
--

--------------------------------------------------------------
-- Converting Core to STG Syntax
--------------------------------------------------------------

-- And, as we have the info in hand, we may convert some lets to
-- let-no-escapes.

module GHC.CoreToStg ( coreToStg ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Core
import GHC.Core.Utils   ( exprType, findDefault, isJoinBind
                        , exprIsTickedString_maybe )
import GHC.Core.Opt.Arity   ( manifestArity )
import GHC.Stg.Syntax

import GHC.Core.Type
import GHC.Types.RepType
import GHC.Core.TyCon
import GHC.Types.Id.Make ( coercionTokenId )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.DataCon
import GHC.Types.CostCentre
import GHC.Types.Var.Env
import GHC.Unit.Module
import GHC.Types.Name   ( isExternalName, nameModule_maybe )
import GHC.Types.Basic  ( Arity )
import GHC.Builtin.Types ( unboxedUnitDataCon, unitDataConId )
import GHC.Types.Literal
import GHC.Utils.Outputable
import GHC.Utils.Monad
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Driver.Session
import GHC.Driver.Ways
import GHC.Types.ForeignCall
import GHC.Types.Demand    ( isUsedOnce )
import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )
import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )
import GHC.Builtin.Names   ( unsafeEqualityProofName )

import Data.List.NonEmpty (nonEmpty, toList)
import Data.Maybe    (fromMaybe)
import Control.Monad (ap)
import qualified Data.Set as Set

-- Note [Live vs free]
-- ~~~~~~~~~~~~~~~~~~~
--
-- The two are not the same. Liveness is an operational property rather
-- than a semantic one. A variable is live at a particular execution
-- point if it can be referred to directly again. In particular, a dead
-- variable's stack slot (if it has one):
--
--           - should be stubbed to avoid space leaks, and
--           - may be reused for something else.
--
-- There ought to be a better way to say this. Here are some examples:
--
--         let v = [q] \[x] -> e
--         in
--         ...v...  (but no q's)
--
-- Just after the `in', v is live, but q is dead. If the whole of that
-- let expression was enclosed in a case expression, thus:
--
--         case (let v = [q] \[x] -> e in ...v...) of
--                 alts[...q...]
--
-- (ie `alts' mention `q'), then `q' is live even after the `in'; because
-- we'll return later to the `alts' and need it.
--
-- Let-no-escapes make this a bit more interesting:
--
--         let-no-escape v = [q] \ [x] -> e
--         in
--         ...v...
--
-- Here, `q' is still live at the `in', because `v' is represented not by
-- a closure but by the current stack state.  In other words, if `v' is
-- live then so is `q'. Furthermore, if `e' mentions an enclosing
-- let-no-escaped variable, then its free variables are also live if `v' is.

-- Note [What are these SRTs all about?]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Consider the Core program,
--
--     fibs = go 1 1
--       where go a b = let c = a + c
--                      in c : go b c
--     add x = map (\y -> x*y) fibs
--
-- In this case we have a CAF, 'fibs', which is quite large after evaluation and
-- has only one possible user, 'add'. Consequently, we want to ensure that when
-- all references to 'add' die we can garbage collect any bit of 'fibs' that we
-- have evaluated.
--
-- However, how do we know whether there are any references to 'fibs' still
-- around? Afterall, the only reference to it is buried in the code generated
-- for 'add'. The answer is that we record the CAFs referred to by a definition
-- in its info table, namely a part of it known as the Static Reference Table
-- (SRT).
--
-- Since SRTs are so common, we use a special compact encoding for them in: we
-- produce one table containing a list of CAFs in a module and then include a
-- bitmap in each info table describing which entries of this table the closure
-- references.
--
-- See also: commentary/rts/storage/gc/CAFs on the GHC Wiki.

-- Note [What is a non-escaping let]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- NB: Nowadays this is recognized by the occurrence analyser by turning a
-- "non-escaping let" into a join point. The following is then an operational
-- account of join points.
--
-- Consider:
--
--     let x = fvs \ args -> e
--     in
--         if ... then x else
--            if ... then x else ...
--
-- `x' is used twice (so we probably can't unfold it), but when it is
-- entered, the stack is deeper than it was when the definition of `x'
-- happened.  Specifically, if instead of allocating a closure for `x',
-- we saved all `x's fvs on the stack, and remembered the stack depth at
-- that moment, then whenever we enter `x' we can simply set the stack
-- pointer(s) to these remembered (compile-time-fixed) values, and jump
-- to the code for `x'.
--
-- All of this is provided x is:
--   1. non-updatable;
--   2. guaranteed to be entered before the stack retreats -- ie x is not
--      buried in a heap-allocated closure, or passed as an argument to
--      something;
--   3. all the enters have exactly the right number of arguments,
--      no more no less;
--   4. all the enters are tail calls; that is, they return to the
--      caller enclosing the definition of `x'.
--
-- Under these circumstances we say that `x' is non-escaping.
--
-- An example of when (4) does not hold:
--
--     let x = ...
--     in case x of ...alts...
--
-- Here, `x' is certainly entered only when the stack is deeper than when
-- `x' is defined, but here it must return to ...alts... So we can't just
-- adjust the stack down to `x''s recalled points, because that would lost
-- alts' context.
--
-- Things can get a little more complicated.  Consider:
--
--     let y = ...
--     in let x = fvs \ args -> ...y...
--     in ...x...
--
-- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a
-- non-escaping way in ...y..., then `y' is non-escaping.
--
-- `x' can even be recursive!  Eg:
--
--     letrec x = [y] \ [v] -> if v then x True else ...
--     in
--         ...(x b)...

-- Note [Cost-centre initialization plan]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`,
-- and the fields were then fixed by a separate pass `stgMassageForProfiling`.
-- We now initialize these correctly. The initialization works like this:
--
--   - For non-top level bindings always use `currentCCS`.
--
--   - For top-level bindings, check if the binding is a CAF
--
--     - CAF:      If -fcaf-all is enabled, create a new CAF just for this CAF
--                 and use it. Note that these new cost centres need to be
--                 collected to be able to generate cost centre initialization
--                 code, so `coreToTopStgRhs` now returns `CollectedCCs`.
--
--                 If -fcaf-all is not enabled, use "all CAFs" cost centre.
--
--     - Non-CAF:  Top-level (static) data is not counted in heap profiles; nor
--                 do we set CCCS from it; so we just slam in
--                 dontCareCostCentre.

-- Note [Coercion tokens]
-- ~~~~~~~~~~~~~~~~~~~~~~
-- In coreToStgArgs, we drop type arguments completely, but we replace
-- coercions with a special coercionToken# placeholder. Why? Consider:
--
--   f :: forall a. Int ~# Bool -> a
--   f = /\a. \(co :: Int ~# Bool) -> error "impossible"
--
-- If we erased the coercion argument completely, we’d end up with just
-- f = error "impossible", but then f `seq` () would be ⊥!
--
-- This is an artificial example, but back in the day we *did* treat
-- coercion lambdas like type lambdas, and we had bug reports as a
-- result. So now we treat coercion lambdas like value lambdas, but we
-- treat coercions themselves as zero-width arguments — coercionToken#
-- has representation VoidRep — which gets the best of both worlds.
--
-- (For the gory details, see also the (unpublished) paper, “Practical
-- aspects of evidence-based compilation in System FC.”)

-- --------------------------------------------------------------
-- Setting variable info: top-level, binds, RHSs
-- --------------------------------------------------------------

coreToStg :: DynFlags -> Module -> CoreProgram
          -> ([StgTopBinding], CollectedCCs)
coreToStg :: DynFlags
-> Module -> CoreProgram -> ([StgTopBinding], CollectedCCs)
coreToStg DynFlags
dflags Module
this_mod CoreProgram
pgm
  = ([StgTopBinding]
pgm', 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

    prof :: Bool
prof = Way
WayProf Way -> Set Way -> Bool
forall a. Ord a => a -> Set a -> Bool
External instance of the constraint type Ord Way
`Set.member` DynFlags -> Set Way
ways DynFlags
dflags

    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)  -- don't need "all CAFs" CC
      | 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           -- environment for the bindings
    -> 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)
  = (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
  -- top-level string literal
  -- See Note [Core top-level string literals] in GHC.Core
  = 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 -> JoinArity -> HowBound
LetBound LetInfo
TopLet JoinArity
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 -> JoinArity -> HowBound
LetBound LetInfo
TopLet (JoinArity -> HowBound) -> JoinArity -> HowBound
forall a b. (a -> b) -> a -> b
$! CoreArg -> JoinArity
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
      -- NB: previously the assertion printed 'rhs' and 'bind'
      --     as well as 'id', but that led to a black hole
      --     where printing the assertion error tripped the
      --     assertion again!
    (IdEnv HowBound
env', CollectedCCs
ccs', StgTopBinding
bind)

coreTopBindToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env CollectedCCs
ccs (Rec [(Id, CoreArg)]
pairs)
  = ASSERT( not (null 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

        extra_env' :: [(Id, HowBound)]
extra_env' = [ (Id
b, LetInfo -> JoinArity -> HowBound
LetBound LetInfo
TopLet (JoinArity -> HowBound) -> JoinArity -> HowBound
forall a b. (a -> b) -> a -> b
$! CoreArg -> JoinArity
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'

        -- generate StgTopBindings and CAF cost centres created for CAFs
        (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
$ do
               (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])
Instance of class: Monad of the constraint type Monad CtsM
mapAccumLM (\CollectedCCs
ccs (Id, CoreArg)
rhs -> do
                            (StgRhs
rhs', CollectedCCs
ccs') <-
                              DynFlags
-> CollectedCCs
-> Module
-> (Id, CoreArg)
-> CtsM (StgRhs, CollectedCCs)
coreToTopStgRhs DynFlags
dflags CollectedCCs
ccs Module
this_mod (Id, CoreArg)
rhs
                            (CollectedCCs, StgRhs) -> CtsM (CollectedCCs, StgRhs)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return (CollectedCCs
ccs', StgRhs
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 { GenStgExpr 'Vanilla
new_rhs <- CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgExpr CoreArg
rhs

       ; let (StgRhs
stg_rhs, CollectedCCs
ccs') =
               DynFlags
-> Module
-> CollectedCCs
-> Id
-> GenStgExpr 'Vanilla
-> (StgRhs, CollectedCCs)
mkTopStgRhs DynFlags
dflags Module
this_mod CollectedCCs
ccs Id
bndr GenStgExpr 'Vanilla
new_rhs
             stg_arity :: JoinArity
stg_arity =
               StgRhs -> JoinArity
stgRhsArity StgRhs
stg_rhs

       ; (StgRhs, CollectedCCs) -> CtsM (StgRhs, CollectedCCs)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
                 CollectedCCs
ccs') }
  where
        -- It's vital that the arity on a top-level Id matches
        -- the arity of the generated STG binding, else an importing
        -- module will use the wrong calling convention
        --      (#2844 was an example where this happened)
        -- NB1: we can't move the assertion further out without
        --      blocking the "knot" tied in coreTopBindsToStg
        -- NB2: the arity check is only needed for Ids with External
        --      Names, because they are externally visible.  The CorePrep
        --      pass introduces "sat" things with Local Names and does
        --      not bother to set their Arity info, so don't fail for those
    arity_ok :: JoinArity -> Bool
arity_ok JoinArity
stg_arity
       | Name -> Bool
isExternalName (Id -> Name
idName Id
bndr) = JoinArity
id_arity JoinArity -> JoinArity -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq JoinArity
== JoinArity
stg_arity
       | Bool
otherwise                    = Bool
True
    id_arity :: JoinArity
id_arity  = Id -> JoinArity
idArity Id
bndr
    mk_arity_msg :: a -> SDoc
mk_arity_msg a
stg_arity
        = [SDoc] -> SDoc
vcat [Id -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type Outputable Id
ppr Id
bndr,
                String -> SDoc
text String
"Id arity:" SDoc -> SDoc -> SDoc
<+> JoinArity -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type Outputable JoinArity
ppr JoinArity
id_arity,
                String -> SDoc
text String
"STG arity:" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall {a}. Outputable a => a -> SDoc
Evidence bound by a type signature of the constraint type Outputable a
ppr a
stg_arity]

-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------

coreToStgExpr
        :: CoreExpr
        -> CtsM StgExpr

-- The second and third components can be derived in a simple bottom up pass, not
-- dependent on any decisions about which variables will be let-no-escaped or
-- not.  The first component, that is, the decorated expression, may then depend
-- on these components, but it in turn is not scrutinised as the basis for any
-- decisions.  Hence no black holes.

-- No LitInteger's or LitNatural's should be left by the time this is called.
-- CorePrep should have converted them all to a real core representation.
coreToStgExpr :: CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgExpr (Lit (LitNumber LitNumType
LitNumInteger Integer
_ Type
_)) = String -> CtsM (GenStgExpr 'Vanilla)
forall a. String -> a
panic String
"coreToStgExpr: LitInteger"
coreToStgExpr (Lit (LitNumber LitNumType
LitNumNatural Integer
_ Type
_)) = String -> CtsM (GenStgExpr 'Vanilla)
forall a. String -> a
panic String
"coreToStgExpr: LitNatural"
coreToStgExpr (Lit Literal
l)      = GenStgExpr 'Vanilla -> CtsM (GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return (Literal -> GenStgExpr 'Vanilla
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit Literal
l)
coreToStgExpr (App (Lit Literal
LitRubbish) CoreArg
_some_unlifted_type)
  -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in
  -- a STG to Cmm pass.
  = CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgExpr (Id -> CoreArg
forall b. Id -> Expr b
Var Id
unitDataConId)
coreToStgExpr (Var Id
v) = Id -> [CoreArg] -> [Tickish Id] -> CtsM (GenStgExpr 'Vanilla)
coreToStgApp Id
v [] []
coreToStgExpr (Coercion Coercion
_)
  -- See Note [Coercion tokens]
  = Id -> [CoreArg] -> [Tickish Id] -> CtsM (GenStgExpr 'Vanilla)
coreToStgApp Id
coercionTokenId [] []

coreToStgExpr expr :: CoreArg
expr@(App CoreArg
_ CoreArg
_)
  = Id -> [CoreArg] -> [Tickish Id] -> CtsM (GenStgExpr 'Vanilla)
coreToStgApp Id
f [CoreArg]
args [Tickish Id]
ticks
  where
    (Id
f, [CoreArg]
args, [Tickish Id]
ticks) = CoreArg -> (Id, [CoreArg], [Tickish Id])
myCollectArgs CoreArg
expr

coreToStgExpr 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 (GenStgExpr 'Vanilla) -> CtsM (GenStgExpr 'Vanilla)
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [ (Id
a, HowBound
LambdaBound) | Id
a <- [Id]
args' ] (CtsM (GenStgExpr 'Vanilla) -> CtsM (GenStgExpr 'Vanilla))
-> CtsM (GenStgExpr 'Vanilla) -> CtsM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ do
    GenStgExpr 'Vanilla
body' <- CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgExpr CoreArg
body
    let
        result_expr :: GenStgExpr 'Vanilla
result_expr = case [Id] -> Maybe (NonEmpty Id)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Id]
args' of
          Maybe (NonEmpty Id)
Nothing     -> GenStgExpr 'Vanilla
body'
          Just NonEmpty Id
args'' -> NonEmpty (BinderP 'Vanilla)
-> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
NonEmpty (BinderP pass) -> GenStgExpr 'Vanilla -> GenStgExpr pass
StgLam NonEmpty Id
NonEmpty (BinderP 'Vanilla)
args'' GenStgExpr 'Vanilla
body'

    GenStgExpr 'Vanilla -> CtsM (GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return GenStgExpr 'Vanilla
result_expr

coreToStgExpr (Tick Tickish Id
tick CoreArg
expr)
  = do case Tickish Id
tick of
         HpcTick{}    -> () -> CtsM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return ()
         ProfNote{}   -> () -> CtsM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return ()
         SourceNote{} -> () -> CtsM ()
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return ()
         Breakpoint{} -> String -> CtsM ()
forall a. String -> a
panic String
"coreToStgExpr: breakpoint should not happen"
       GenStgExpr 'Vanilla
expr2 <- CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgExpr CoreArg
expr
       GenStgExpr 'Vanilla -> CtsM (GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return (Tickish Id -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass).
Tickish Id -> GenStgExpr pass -> GenStgExpr pass
StgTick Tickish Id
tick GenStgExpr 'Vanilla
expr2)

coreToStgExpr (Cast CoreArg
expr Coercion
_)
  = CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgExpr CoreArg
expr

-- Cases require a little more real work.

coreToStgExpr (Case CoreArg
scrut Id
_ Type
_ [])
  = CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgExpr CoreArg
scrut
    -- See Note [Empty case alternatives] in GHC.Core If the case
    -- alternatives are empty, the scrutinee must diverge or raise an
    -- exception, so we can just dive into it.
    --
    -- Of course this may seg-fault if the scrutinee *does* return.  A
    -- belt-and-braces approach would be to move this case into the
    -- code generator, and put a return point anyway that calls a
    -- runtime system error function.


coreToStgExpr e0 :: CoreArg
e0@(Case CoreArg
scrut Id
bndr Type
_ [Alt Id]
alts) = do
    [(AltCon, [Id], GenStgExpr 'Vanilla)]
alts2 <- [(Id, HowBound)]
-> CtsM [(AltCon, [Id], GenStgExpr 'Vanilla)]
-> CtsM [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Id
bndr, HowBound
LambdaBound)] ((Alt Id -> CtsM (AltCon, [Id], GenStgExpr 'Vanilla))
-> [Alt Id] -> CtsM [(AltCon, [Id], GenStgExpr 'Vanilla)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
Instance of class: Monad of the constraint type Monad CtsM
External instance of the constraint type Traversable []
mapM Alt Id -> CtsM (AltCon, [Id], GenStgExpr 'Vanilla)
vars_alt [Alt Id]
alts)
    GenStgExpr 'Vanilla
scrut2 <- CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgExpr CoreArg
scrut
    let stg :: GenStgExpr 'Vanilla
stg = GenStgExpr 'Vanilla
-> BinderP 'Vanilla
-> AltType
-> [GenStgAlt 'Vanilla]
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase GenStgExpr 'Vanilla
scrut2 Id
BinderP 'Vanilla
bndr (Id -> [Alt Id] -> AltType
mkStgAltType Id
bndr [Alt Id]
alts) [(AltCon, [Id], GenStgExpr 'Vanilla)]
[GenStgAlt 'Vanilla]
alts2
    -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
    case GenStgExpr 'Vanilla
scrut2 of
      StgApp Id
id [] | Id -> Name
idName Id
id Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Name
== Name
unsafeEqualityProofName ->
        case [(AltCon, [Id], GenStgExpr 'Vanilla)]
alts2 of
          [(AltCon
_, [Id
_co], GenStgExpr 'Vanilla
rhs)] ->
            GenStgExpr 'Vanilla -> CtsM (GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return GenStgExpr 'Vanilla
rhs
          [(AltCon, [Id], GenStgExpr 'Vanilla)]
_ ->
            String -> SDoc -> CtsM (GenStgExpr 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStgExpr" (SDoc -> CtsM (GenStgExpr 'Vanilla))
-> SDoc -> CtsM (GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$
              String -> SDoc
text String
"Unexpected unsafe equality case expression:" SDoc -> SDoc -> SDoc
$$ CoreArg -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Id
ppr CoreArg
e0 SDoc -> SDoc -> SDoc
$$
              String -> SDoc
text String
"STG:" SDoc -> SDoc -> SDoc
$$ GenStgExpr 'Vanilla -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall (pass :: StgPass).
OutputablePass pass =>
Outputable (GenStgExpr pass)
External instance of the constraint type Outputable NoExtFieldSilent
External instance of the constraint type Outputable NoExtFieldSilent
External instance of the constraint type Outputable NoExtFieldSilent
External instance of the constraint type OutputableBndr Id
ppr GenStgExpr 'Vanilla
stg
      GenStgExpr 'Vanilla
_ -> GenStgExpr 'Vanilla -> CtsM (GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return GenStgExpr 'Vanilla
stg
  where
    vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], StgExpr)
    vars_alt :: Alt Id -> CtsM (AltCon, [Id], GenStgExpr 'Vanilla)
vars_alt (AltCon
con, [Id]
binders, CoreArg
rhs)
      | DataAlt DataCon
c <- AltCon
con, DataCon
c DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq DataCon
== DataCon
unboxedUnitDataCon
      = -- This case is a bit smelly.
        -- See Note [Nullary unboxed tuple] in GHC.Core.Type
        -- where a nullary tuple is mapped to (State# World#)
        ASSERT( null binders )
        do { GenStgExpr 'Vanilla
rhs2 <- CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgExpr CoreArg
rhs
           ; (AltCon, [Id], GenStgExpr 'Vanilla)
-> CtsM (AltCon, [Id], GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return (AltCon
DEFAULT, [], GenStgExpr 'Vanilla
rhs2)  }
      | Bool
otherwise
      = let     -- Remove type variables
            binders' :: [Id]
binders' = [Id] -> [Id]
filterStgBinders [Id]
binders
        in
        [(Id, HowBound)]
-> CtsM (AltCon, [Id], GenStgExpr 'Vanilla)
-> CtsM (AltCon, [Id], GenStgExpr 'Vanilla)
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Id
b, HowBound
LambdaBound) | Id
b <- [Id]
binders'] (CtsM (AltCon, [Id], GenStgExpr 'Vanilla)
 -> CtsM (AltCon, [Id], GenStgExpr 'Vanilla))
-> CtsM (AltCon, [Id], GenStgExpr 'Vanilla)
-> CtsM (AltCon, [Id], GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ do
        GenStgExpr 'Vanilla
rhs2 <- CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgExpr CoreArg
rhs
        (AltCon, [Id], GenStgExpr 'Vanilla)
-> CtsM (AltCon, [Id], GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return (AltCon
con, [Id]
binders', GenStgExpr 'Vanilla
rhs2)

coreToStgExpr (Let CoreBind
bind CoreArg
body) = do
    CoreBind -> CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgLet CoreBind
bind CoreArg
body

coreToStgExpr CoreArg
e = String -> SDoc -> CtsM (GenStgExpr 'Vanilla)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStgExpr" (CoreArg -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Id
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
  = JoinArity -> AltType
MultiValAlt ([PrimRep] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
External instance of the constraint type Foldable []
length [PrimRep]
prim_reps)  -- always use MultiValAlt for unboxed tuples

  | Bool
otherwise
  = case [PrimRep]
prim_reps of
      [PrimRep
LiftedRep] -> 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          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
                                  AltType
PolyAlt
        Maybe TyCon
Nothing                -> AltType
PolyAlt
      [PrimRep
unlifted] -> PrimRep -> AltType
PrimAlt PrimRep
unlifted
      [PrimRep]
not_unary  -> JoinArity -> AltType
MultiValAlt ([PrimRep] -> JoinArity
forall (t :: * -> *) a. Foldable t => t a -> JoinArity
External instance of the constraint type Foldable []
length [PrimRep]
not_unary)
  where
   bndr_ty :: Type
bndr_ty   = Id -> Type
idType Id
bndr
   prim_reps :: [PrimRep]
prim_reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
External instance of the constraint type HasDebugCallStack
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   -- "Any" is lifted but primitive
        Bool -> Bool -> Bool
|| TyCon -> Bool
isFamilyTyCon TyCon
tc -- Type family; e.g. Any, or arising from strict
                            -- function application where argument has a
                            -- type-family type

   -- Sometimes, the TyCon is a AbstractTyCon which may not have any
   -- constructors inside it.  Then we may get a better TyCon by
   -- grabbing the one from a constructor alternative
   -- if one exists.
   look_for_better_tycon :: AltType
look_for_better_tycon
        | ((DataAlt DataCon
con, [Id]
_, CoreArg
_) : [Alt Id]
_) <- [Alt Id]
data_alts =
                TyCon -> AltType
AlgAlt (DataCon -> TyCon
dataConTyCon DataCon
con)
        | Bool
otherwise =
                ASSERT(null data_alts)
                AltType
PolyAlt
        where
                ([Alt Id]
data_alts, Maybe CoreArg
_deflt) = [Alt Id] -> ([Alt Id], Maybe CoreArg)
forall a b. [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
findDefault [Alt Id]
alts

-- ---------------------------------------------------------------------------
-- Applications
-- ---------------------------------------------------------------------------

coreToStgApp :: Id            -- Function
             -> [CoreArg]     -- Arguments
             -> [Tickish Id]  -- Debug ticks
             -> CtsM StgExpr
coreToStgApp :: Id -> [CoreArg] -> [Tickish Id] -> CtsM (GenStgExpr 'Vanilla)
coreToStgApp Id
f [CoreArg]
args [Tickish Id]
ticks = do
    ([StgArg]
args', [Tickish Id]
ticks') <- [CoreArg] -> CtsM ([StgArg], [Tickish Id])
coreToStgArgs [CoreArg]
args
    HowBound
how_bound <- Id -> CtsM HowBound
lookupVarCts Id
f

    let
        n_val_args :: JoinArity
n_val_args       = [CoreArg] -> JoinArity
forall b. [Arg b] -> JoinArity
valArgCount [CoreArg]
args

        -- Mostly, the arity info of a function is in the fn's IdInfo
        -- But new bindings introduced by CoreSat may not have no
        -- arity info; it would do us no good anyway.  For example:
        --      let f = \ab -> e in f
        -- No point in having correct arity info for f!
        -- Hence the hasArity stuff below.
        -- NB: f_arity is only consulted for LetBound things
        f_arity :: JoinArity
f_arity   = Id -> HowBound -> JoinArity
stgArity Id
f HowBound
how_bound
        saturated :: Bool
saturated = JoinArity
f_arity JoinArity -> JoinArity -> Bool
forall a. Ord a => a -> a -> Bool
External instance of the constraint type Ord JoinArity
<= JoinArity
n_val_args

        res_ty :: Type
res_ty = 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 :: GenStgExpr pass
app = case Id -> IdDetails
idDetails Id
f of
                DataConWorkId DataCon
dc
                  | Bool
saturated    -> DataCon -> [StgArg] -> [Type] -> GenStgExpr pass
forall (pass :: StgPass).
DataCon -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
dc [StgArg]
args'
                                      ([Type] -> [Type]
dropRuntimeRepArgs ([Type] -> Maybe [Type] -> [Type]
forall a. a -> Maybe a -> a
fromMaybe [] (Type -> Maybe [Type]
tyConAppArgs_maybe Type
res_ty)))

                -- Some primitive operator that might be implemented as a library call.
                -- As described in Note [Primop wrappers] in GHC.Builtin.PrimOps, here we
                -- turn unsaturated primop applications into applications of
                -- the primop's wrapper.
                PrimOpId PrimOp
op
                  | Bool
saturated    -> StgOp -> [StgArg] -> Type -> GenStgExpr pass
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (PrimOp -> StgOp
StgPrimOp PrimOp
op) [StgArg]
args' Type
res_ty
                  | Bool
otherwise    -> Id -> [StgArg] -> GenStgExpr pass
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp (PrimOp -> Id
primOpWrapperId PrimOp
op) [StgArg]
args'

                -- A call to some primitive Cmm function.
                FCallId (CCall (CCallSpec (StaticTarget SourceText
_ CLabelString
lbl (Just Unit
pkgId) Bool
True)
                                          CCallConv
PrimCallConv Safety
_))
                                 -> ASSERT( saturated )
                                    StgOp -> [StgArg] -> Type -> GenStgExpr pass
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

                -- A regular foreign call.
                FCallId ForeignCall
call     -> ASSERT( saturated )
                                    StgOp -> [StgArg] -> Type -> GenStgExpr pass
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 -> GenStgExpr pass
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStg TickBox" (SDoc -> GenStgExpr pass) -> SDoc -> GenStgExpr pass
forall a b. (a -> b) -> a -> b
$ (Id, [StgArg]) -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall a b. (Outputable a, Outputable b) => Outputable (a, b)
External instance of the constraint type Outputable Id
External instance of the constraint type forall a. Outputable a => Outputable [a]
External instance of the constraint type Outputable StgArg
ppr (Id
f,[StgArg]
args')
                IdDetails
_other           -> Id -> [StgArg] -> GenStgExpr pass
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
f [StgArg]
args'

        tapp :: GenStgExpr pass
tapp = (Tickish Id -> GenStgExpr pass -> GenStgExpr pass)
-> GenStgExpr pass -> [Tickish Id] -> GenStgExpr pass
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
External instance of the constraint type Foldable []
foldr Tickish Id -> GenStgExpr pass -> GenStgExpr pass
forall (pass :: StgPass).
Tickish Id -> GenStgExpr pass -> GenStgExpr pass
StgTick GenStgExpr pass
forall {pass :: StgPass}. GenStgExpr pass
app ([Tickish Id]
ticks [Tickish Id] -> [Tickish Id] -> [Tickish Id]
forall a. [a] -> [a] -> [a]
++ [Tickish Id]
ticks')

    -- Forcing these fixes a leak in the code generator, noticed while
    -- profiling for trac #4367
    GenStgExpr Any
forall {pass :: StgPass}. GenStgExpr pass
app GenStgExpr Any
-> CtsM (GenStgExpr 'Vanilla) -> CtsM (GenStgExpr 'Vanilla)
`seq` GenStgExpr 'Vanilla -> CtsM (GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return GenStgExpr 'Vanilla
forall {pass :: StgPass}. GenStgExpr pass
tapp

-- ---------------------------------------------------------------------------
-- Argument lists
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------

coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])
coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])
coreToStgArgs []
  = ([StgArg], [Tickish Id]) -> CtsM ([StgArg], [Tickish Id])
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return ([], [])

coreToStgArgs (Type Type
_ : [CoreArg]
args) = do     -- Type argument
    ([StgArg]
args', [Tickish Id]
ts) <- [CoreArg] -> CtsM ([StgArg], [Tickish Id])
coreToStgArgs [CoreArg]
args
    ([StgArg], [Tickish Id]) -> CtsM ([StgArg], [Tickish Id])
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return ([StgArg]
args', [Tickish Id]
ts)

coreToStgArgs (Coercion Coercion
_ : [CoreArg]
args) -- Coercion argument; See Note [Coercion tokens]
  = do { ([StgArg]
args', [Tickish Id]
ts) <- [CoreArg] -> CtsM ([StgArg], [Tickish Id])
coreToStgArgs [CoreArg]
args
       ; ([StgArg], [Tickish Id]) -> CtsM ([StgArg], [Tickish Id])
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return (Id -> StgArg
StgVarArg Id
coercionTokenId StgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
: [StgArg]
args', [Tickish Id]
ts) }

coreToStgArgs (Tick Tickish Id
t CoreArg
e : [CoreArg]
args)
  = ASSERT( not (tickishIsCode t) )
    do { ([StgArg]
args', [Tickish Id]
ts) <- [CoreArg] -> CtsM ([StgArg], [Tickish Id])
coreToStgArgs (CoreArg
e CoreArg -> [CoreArg] -> [CoreArg]
forall a. a -> [a] -> [a]
: [CoreArg]
args)
       ; ([StgArg], [Tickish Id]) -> CtsM ([StgArg], [Tickish Id])
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return ([StgArg]
args', Tickish Id
tTickish Id -> [Tickish Id] -> [Tickish Id]
forall a. a -> [a] -> [a]
:[Tickish Id]
ts) }

coreToStgArgs (CoreArg
arg : [CoreArg]
args) = do         -- Non-type argument
    ([StgArg]
stg_args, [Tickish Id]
ticks) <- [CoreArg] -> CtsM ([StgArg], [Tickish Id])
coreToStgArgs [CoreArg]
args
    GenStgExpr 'Vanilla
arg' <- CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgExpr CoreArg
arg
    let
        ([Tickish Id]
aticks, GenStgExpr 'Vanilla
arg'') = (Tickish Id -> Bool)
-> GenStgExpr 'Vanilla -> ([Tickish Id], GenStgExpr 'Vanilla)
forall (p :: StgPass).
(Tickish Id -> Bool)
-> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
stripStgTicksTop Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable GenStgExpr 'Vanilla
arg'
        stg_arg :: StgArg
stg_arg = case GenStgExpr 'Vanilla
arg'' of
                       StgApp Id
v []        -> Id -> StgArg
StgVarArg Id
v
                       StgConApp DataCon
con [] [Type]
_ -> Id -> StgArg
StgVarArg (DataCon -> Id
dataConWorkId DataCon
con)
                       StgLit Literal
lit         -> Literal -> StgArg
StgLitArg Literal
lit
                       GenStgExpr 'Vanilla
_                  -> String -> SDoc -> StgArg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStgArgs" (CoreArg -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Id
ppr CoreArg
arg)

        -- WARNING: what if we have an argument like (v `cast` co)
        --          where 'co' changes the representation type?
        --          (This really only happens if co is unsafe.)
        -- Then all the getArgAmode stuff in CgBindery will set the
        -- cg_rep of the CgIdInfo based on the type of v, rather
        -- than the type of 'co'.
        -- This matters particularly when the function is a primop
        -- or foreign call.
        -- Wanted: a better solution than this hacky warning

    Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> CtsM DynFlags -> CtsM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Instance of class: Functor of the constraint type Functor CtsM
<$> CtsM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
Instance of class: HasDynFlags of the constraint type HasDynFlags CtsM
getDynFlags
    let
        arg_rep :: [PrimRep]
arg_rep = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
External instance of the constraint type HasDebugCallStack
typePrimRep (CoreArg -> Type
exprType CoreArg
arg)
        stg_arg_rep :: [PrimRep]
stg_arg_rep = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
External instance of the constraint type HasDebugCallStack
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)

    WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
     ([StgArg], [Tickish Id]) -> CtsM ([StgArg], [Tickish Id])
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return (StgArg
stg_arg StgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
: [StgArg]
stg_args, [Tickish Id]
ticks [Tickish Id] -> [Tickish Id] -> [Tickish Id]
forall a. [a] -> [a] -> [a]
++ [Tickish Id]
aticks)


-- ---------------------------------------------------------------------------
-- The magic for lets:
-- ---------------------------------------------------------------------------

coreToStgLet
         :: CoreBind     -- bindings
         -> CoreExpr     -- body
         -> CtsM StgExpr -- new let

coreToStgLet :: CoreBind -> CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgLet CoreBind
bind CoreArg
body = do
    (GenStgBinding 'Vanilla
bind2, GenStgExpr 'Vanilla
body2)
       <- do

          ( GenStgBinding 'Vanilla
bind2, [(Id, HowBound)]
env_ext)
                <- CoreBind -> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
vars_bind CoreBind
bind

          -- Do the body
          [(Id, HowBound)]
-> CtsM (GenStgBinding 'Vanilla, GenStgExpr 'Vanilla)
-> CtsM (GenStgBinding 'Vanilla, GenStgExpr 'Vanilla)
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(Id, HowBound)]
env_ext (CtsM (GenStgBinding 'Vanilla, GenStgExpr 'Vanilla)
 -> CtsM (GenStgBinding 'Vanilla, GenStgExpr 'Vanilla))
-> CtsM (GenStgBinding 'Vanilla, GenStgExpr 'Vanilla)
-> CtsM (GenStgBinding 'Vanilla, GenStgExpr 'Vanilla)
forall a b. (a -> b) -> a -> b
$ do
             GenStgExpr 'Vanilla
body2 <- CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgExpr CoreArg
body

             (GenStgBinding 'Vanilla, GenStgExpr 'Vanilla)
-> CtsM (GenStgBinding 'Vanilla, GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return (GenStgBinding 'Vanilla
bind2, GenStgExpr 'Vanilla
body2)

        -- Compute the new let-expression
    let
        new_let :: GenStgExpr 'Vanilla
new_let | CoreBind -> Bool
isJoinBind CoreBind
bind = XLetNoEscape 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape 'Vanilla
NoExtFieldSilent
noExtFieldSilent GenStgBinding 'Vanilla
bind2 GenStgExpr 'Vanilla
body2
                | Bool
otherwise       = XLet 'Vanilla
-> GenStgBinding 'Vanilla
-> GenStgExpr 'Vanilla
-> GenStgExpr 'Vanilla
forall (pass :: StgPass).
XLet pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLet XLet 'Vanilla
NoExtFieldSilent
noExtFieldSilent GenStgBinding 'Vanilla
bind2 GenStgExpr 'Vanilla
body2

    GenStgExpr 'Vanilla -> CtsM (GenStgExpr 'Vanilla)
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return GenStgExpr 'Vanilla
new_let
  where
    mk_binding :: a -> CoreArg -> (a, HowBound)
mk_binding a
binder CoreArg
rhs
        = (a
binder, LetInfo -> JoinArity -> HowBound
LetBound LetInfo
NestedLet (CoreArg -> JoinArity
manifestArity CoreArg
rhs))

    vars_bind :: CoreBind
              -> CtsM (StgBinding,
                       [(Id, HowBound)])  -- extension to environment

    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 (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
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)
Instance of class: Monad of the constraint type Monad CtsM
External instance of the constraint type Traversable []
mapM (Id, CoreArg) -> CtsM StgRhs
coreToStgRhs [(Id, CoreArg)]
pairs
              (GenStgBinding 'Vanilla, [(Id, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
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
    GenStgExpr 'Vanilla
new_rhs <- CoreArg -> CtsM (GenStgExpr 'Vanilla)
coreToStgExpr CoreArg
rhs
    StgRhs -> CtsM StgRhs
forall (m :: * -> *) a. Monad m => a -> m a
Instance of class: Monad of the constraint type Monad CtsM
return (Id -> GenStgExpr 'Vanilla -> StgRhs
mkStgRhs Id
bndr GenStgExpr 'Vanilla
new_rhs)

-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
-- appended to `CollectedCCs` argument.
mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
            -> Id -> StgExpr -> (StgRhs, CollectedCCs)

mkTopStgRhs :: DynFlags
-> Module
-> CollectedCCs
-> Id
-> GenStgExpr 'Vanilla
-> (StgRhs, CollectedCCs)
mkTopStgRhs DynFlags
dflags Module
this_mod CollectedCCs
ccs Id
bndr GenStgExpr 'Vanilla
rhs
  | StgLam NonEmpty (BinderP 'Vanilla)
bndrs GenStgExpr 'Vanilla
body <- GenStgExpr 'Vanilla
rhs
  = -- StgLam can't have empty arguments, so not CAF
    ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                    CostCentreStack
dontCareCCS
                    UpdateFlag
ReEntrant
                    (NonEmpty Id -> [Id]
forall a. NonEmpty a -> [a]
toList NonEmpty Id
NonEmpty (BinderP 'Vanilla)
bndrs) GenStgExpr 'Vanilla
body
    , CollectedCCs
ccs )

  | StgConApp DataCon
con [StgArg]
args [Type]
_ <- GenStgExpr 'Vanilla
unticked_rhs
  , -- Dynamic StgConApps are updatable
    Bool -> Bool
not (DynFlags -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp DynFlags
dflags Module
this_mod DataCon
con [StgArg]
args)
  = -- CorePrep does this right, but just to make sure
    ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)
           , ppr bndr $$ ppr con $$ ppr args)
    ( CostCentreStack -> DataCon -> [StgArg] -> StgRhs
forall (pass :: StgPass).
CostCentreStack -> DataCon -> [StgArg] -> GenStgRhs pass
StgRhsCon CostCentreStack
dontCareCCS DataCon
con [StgArg]
args, CollectedCCs
ccs )

  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
  | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AutoSccsOnIndividualCafs DynFlags
dflags
  = ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> 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 [] GenStgExpr 'Vanilla
rhs
    , CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
collectCC CostCentre
caf_cc CostCentreStack
caf_ccs CollectedCCs
ccs )

  | Bool
otherwise
  = ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> 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 [] GenStgExpr 'Vanilla
rhs
    , CollectedCCs
ccs )

  where
    unticked_rhs :: GenStgExpr 'Vanilla
unticked_rhs = (Tickish Id -> Bool) -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (p :: StgPass).
(Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p
stripStgTicksTopE (Bool -> Bool
not (Bool -> Bool) -> (Tickish Id -> Bool) -> Tickish Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode) GenStgExpr 'Vanilla
rhs

    upd_flag :: UpdateFlag
upd_flag | JointDmd (Str StrDmd) (Use UseDmd) -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isUsedOnce (Id -> JointDmd (Str StrDmd) (Use UseDmd)
idDemandInfo Id
bndr) = UpdateFlag
SingleEntry
             | Bool
otherwise                      = UpdateFlag
Updatable

    -- CAF cost centres generated for -fcaf-all
    caf_cc :: CostCentre
caf_cc = Id -> Module -> CostCentre
mkAutoCC Id
bndr Module
modl
    caf_ccs :: CostCentreStack
caf_ccs = CostCentre -> CostCentreStack
mkSingletonCCS CostCentre
caf_cc
           -- careful: the binder might be :Main.main,
           -- which doesn't belong to module mod_name.
           -- bug #249, tests prof001, prof002
    modl :: Module
modl | Just Module
m <- Name -> Maybe Module
nameModule_maybe (Id -> Name
idName Id
bndr) = Module
m
         | Bool
otherwise = Module
this_mod

    -- default CAF cost centre
    (CostCentre
_, CostCentreStack
all_cafs_ccs) = Module -> (CostCentre, CostCentreStack)
getAllCAFsCC Module
this_mod

-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
-- see Note [Cost-centre initialization plan].
mkStgRhs :: Id -> StgExpr -> StgRhs
mkStgRhs :: Id -> GenStgExpr 'Vanilla -> StgRhs
mkStgRhs Id
bndr GenStgExpr 'Vanilla
rhs
  | StgLam NonEmpty (BinderP 'Vanilla)
bndrs GenStgExpr 'Vanilla
body <- GenStgExpr 'Vanilla
rhs
  = XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                  CostCentreStack
currentCCS
                  UpdateFlag
ReEntrant
                  (NonEmpty Id -> [Id]
forall a. NonEmpty a -> [a]
toList NonEmpty Id
NonEmpty (BinderP 'Vanilla)
bndrs) GenStgExpr 'Vanilla
body

  | Id -> Bool
isJoinId Id
bndr -- must be a nullary join point
  = ASSERT(idJoinArity bndr == 0)
    XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                  CostCentreStack
currentCCS
                  UpdateFlag
ReEntrant -- ignored for LNE
                  [] GenStgExpr 'Vanilla
rhs

  | StgConApp DataCon
con [StgArg]
args [Type]
_ <- GenStgExpr 'Vanilla
unticked_rhs
  = CostCentreStack -> DataCon -> [StgArg] -> StgRhs
forall (pass :: StgPass).
CostCentreStack -> DataCon -> [StgArg] -> GenStgRhs pass
StgRhsCon CostCentreStack
currentCCS DataCon
con [StgArg]
args

  | Bool
otherwise
  = XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> GenStgExpr 'Vanilla
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                  CostCentreStack
currentCCS
                  UpdateFlag
upd_flag [] GenStgExpr 'Vanilla
rhs
  where
    unticked_rhs :: GenStgExpr 'Vanilla
unticked_rhs = (Tickish Id -> Bool) -> GenStgExpr 'Vanilla -> GenStgExpr 'Vanilla
forall (p :: StgPass).
(Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p
stripStgTicksTopE (Bool -> Bool
not (Bool -> Bool) -> (Tickish Id -> Bool) -> Tickish Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode) GenStgExpr 'Vanilla
rhs

    upd_flag :: UpdateFlag
upd_flag | JointDmd (Str StrDmd) (Use UseDmd) -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
isUsedOnce (Id -> JointDmd (Str StrDmd) (Use UseDmd)
idDemandInfo Id
bndr) = UpdateFlag
SingleEntry
             | Bool
otherwise                      = UpdateFlag
Updatable

  {-
    SDM: disabled.  Eval/Apply can't handle functions with arity zero very
    well; and making these into simple non-updatable thunks breaks other
    assumptions (namely that they will be entered only once).

    upd_flag | isPAP env rhs  = ReEntrant
             | otherwise      = Updatable

-- Detect thunks which will reduce immediately to PAPs, and make them
-- non-updatable.  This has several advantages:
--
--         - the non-updatable thunk behaves exactly like the PAP,
--
--         - the thunk is more efficient to enter, because it is
--           specialised to the task.
--
--         - we save one update frame, one stg_update_PAP, one update
--           and lots of PAP_enters.
--
--         - in the case where the thunk is top-level, we save building
--           a black hole and furthermore the thunk isn't considered to
--           be a CAF any more, so it doesn't appear in any SRTs.
--
-- We do it here, because the arity information is accurate, and we need
-- to do it before the SRT pass to save the SRT entries associated with
-- any top-level PAPs.

isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
                              where
                                 arity = stgArity f (lookupBinding env f)
isPAP env _               = False

-}

{- ToDo:
          upd = if isOnceDem dem
                    then (if isNotTop toplev
                            then SingleEntry    -- HA!  Paydirt for "dem"
                            else
                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
                     Updatable)
                else Updatable
        -- For now we forbid SingleEntry CAFs; they tickle the
        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
        -- and I don't understand why.  There's only one SE_CAF (well,
        -- only one that tickled a great gaping bug in an earlier attempt
        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
        -- specifically Main.lvl6 in spectral/cryptarithm2.
        -- So no great loss.  KSW 2000-07.
-}

-- ---------------------------------------------------------------------------
-- A monad for the core-to-STG pass
-- ---------------------------------------------------------------------------

-- There's a lot of stuff to pass around, so we use this CtsM
-- ("core-to-STG monad") monad to help.  All the stuff here is only passed
-- *down*.

newtype CtsM a = CtsM
    { CtsM a -> DynFlags -> IdEnv HowBound -> a
unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs
             -> IdEnv HowBound
             -> a
    }
    deriving (a -> CtsM b -> CtsM a
(a -> b) -> CtsM a -> CtsM b
(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
<$ :: a -> CtsM b -> CtsM a
$c<$ :: forall a b. a -> CtsM b -> CtsM a
fmap :: (a -> b) -> CtsM a -> CtsM b
$cfmap :: forall a b. (a -> b) -> CtsM a -> CtsM b
Functor)

data HowBound
  = ImportBound         -- Used only as a response to lookupBinding; never
                        -- exists in the range of the (IdEnv HowBound)

  | LetBound            -- A let(rec) in this module
        LetInfo         -- Whether top level or nested
        Arity           -- Its arity (local Ids don't have arity info at this point)

  | LambdaBound         -- Used for both lambda and case
  deriving (HowBound -> HowBound -> Bool
(HowBound -> HowBound -> Bool)
-> (HowBound -> HowBound -> Bool) -> Eq HowBound
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HowBound -> HowBound -> Bool
$c/= :: HowBound -> HowBound -> Bool
== :: HowBound -> HowBound -> Bool
$c== :: HowBound -> HowBound -> Bool
External instance of the constraint type Eq JoinArity
Instance of class: Eq of the constraint type Eq LetInfo
Eq)

data LetInfo
  = TopLet              -- top level things
  | NestedLet
  deriving (LetInfo -> LetInfo -> Bool
(LetInfo -> LetInfo -> Bool)
-> (LetInfo -> LetInfo -> Bool) -> Eq LetInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LetInfo -> LetInfo -> Bool
$c/= :: LetInfo -> LetInfo -> Bool
== :: LetInfo -> LetInfo -> Bool
$c== :: LetInfo -> LetInfo -> Bool
Eq)

-- For a let(rec)-bound variable, x, we record LiveInfo, the set of
-- variables that are live if x is live.  This LiveInfo comprises
--         (a) dynamic live variables (ones with a non-top-level binding)
--         (b) static live variables (CAFs or things that refer to CAFs)
--
-- For "normal" variables (a) is just x alone.  If x is a let-no-escaped
-- variable then x is represented by a code pointer and a stack pointer
-- (well, one for each stack).  So all of the variables needed in the
-- execution of x are live if x is, and are therefore recorded in the
-- LetBound constructor; x itself *is* included.
--
-- The set of dynamic live variables is guaranteed ot have no further
-- let-no-escaped variables in it.

-- The std monad functions:

initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a
initCts :: 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 :: 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 :: 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 :: a -> CtsM a
pure = a -> CtsM a
forall a. a -> CtsM a
returnCts
    <*> :: 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
Instance of class: Monad of the constraint type Monad CtsM
ap

instance Monad CtsM where
    >>= :: 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

-- Functions specific to this monad:

extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts :: [(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 -> ASSERT2( isGlobalId v, ppr v ) 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>") -- XXX do better
      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)

-- Misc.

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)

-- | Precondition: argument expression is an 'App', and there is a 'Var' at the
-- head of the 'App' chain.
myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id])
myCollectArgs :: CoreArg -> (Id, [CoreArg], [Tickish Id])
myCollectArgs CoreArg
expr
  = CoreArg
-> [CoreArg] -> [Tickish Id] -> (Id, [CoreArg], [Tickish Id])
go CoreArg
expr [] []
  where
    go :: CoreArg
-> [CoreArg] -> [Tickish Id] -> (Id, [CoreArg], [Tickish Id])
go (Var Id
v)          [CoreArg]
as [Tickish Id]
ts = (Id
v, [CoreArg]
as, [Tickish Id]
ts)
    go (App CoreArg
f CoreArg
a)        [CoreArg]
as [Tickish Id]
ts = CoreArg
-> [CoreArg] -> [Tickish Id] -> (Id, [CoreArg], [Tickish Id])
go CoreArg
f (CoreArg
aCoreArg -> [CoreArg] -> [CoreArg]
forall a. a -> [a] -> [a]
:[CoreArg]
as) [Tickish Id]
ts
    go (Tick Tickish Id
t CoreArg
e)       [CoreArg]
as [Tickish Id]
ts = ASSERT( all isTypeArg as )
                                CoreArg
-> [CoreArg] -> [Tickish Id] -> (Id, [CoreArg], [Tickish Id])
go CoreArg
e [CoreArg]
as (Tickish Id
tTickish Id -> [Tickish Id] -> [Tickish Id]
forall a. a -> [a] -> [a]
:[Tickish Id]
ts) -- ticks can appear in type apps
    go (Cast CoreArg
e Coercion
_)       [CoreArg]
as [Tickish Id]
ts = CoreArg
-> [CoreArg] -> [Tickish Id] -> (Id, [CoreArg], [Tickish Id])
go CoreArg
e [CoreArg]
as [Tickish Id]
ts
    go (Lam Id
b CoreArg
e)        [CoreArg]
as [Tickish Id]
ts
       | Id -> Bool
isTyVar Id
b            = CoreArg
-> [CoreArg] -> [Tickish Id] -> (Id, [CoreArg], [Tickish Id])
go CoreArg
e [CoreArg]
as [Tickish Id]
ts -- Note [Collect args]
    go CoreArg
_                [CoreArg]
_  [Tickish Id]
_  = String -> SDoc -> (Id, [CoreArg], [Tickish Id])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"CoreToStg.myCollectArgs" (CoreArg -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Id
ppr CoreArg
expr)

-- Note [Collect args]
-- ~~~~~~~~~~~~~~~~~~~
--
-- This big-lambda case occurred following a rather obscure eta expansion.
-- It all seems a bit yukky to me.

stgArity :: Id -> HowBound -> Arity
stgArity :: Id -> HowBound -> JoinArity
stgArity Id
_ (LetBound LetInfo
_ JoinArity
arity) = JoinArity
arity
stgArity Id
f HowBound
ImportBound        = Id -> JoinArity
idArity Id
f
stgArity Id
_ HowBound
LambdaBound        = JoinArity
0