{-# LANGUAGE DataKinds #-}

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}

--
-- (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 ( CoreToStgOpts (..), coreToStg ) where

import GHC.Prelude

import GHC.Core
import GHC.Core.Utils
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, TypeOrConstraint(..) )
import GHC.Types.Literal
import GHC.Types.ForeignCall
import GHC.Types.IPE
import GHC.Types.Demand    ( isAtMostOnceDmd )
import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )

import GHC.Unit.Module
import GHC.Data.FastString
import GHC.Platform        ( Platform )
import GHC.Platform.Ways
import GHC.Builtin.PrimOps

import GHC.Utils.Outputable
import GHC.Utils.Monad
import GHC.Utils.Misc (HasDebugCallStack)
import GHC.Utils.Panic

import Control.Monad (ap)

-- 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 :: CoreToStgOpts -> Module -> ModLocation -> CoreProgram
          -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg :: CoreToStgOpts
-> Module
-> ModLocation
-> CoreProgram
-> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg opts :: CoreToStgOpts
opts@CoreToStgOpts
  { coreToStg_ways :: CoreToStgOpts -> Ways
coreToStg_ways = Ways
ways
  , coreToStg_AutoSccsOnIndividualCafs :: CoreToStgOpts -> Bool
coreToStg_AutoSccsOnIndividualCafs = Bool
opt_AutoSccsOnIndividualCafs
  , coreToStg_InfoTableMap :: CoreToStgOpts -> Bool
coreToStg_InfoTableMap = Bool
opt_InfoTableMap
  , coreToStg_stgDebugOpts :: CoreToStgOpts -> StgDebugOpts
coreToStg_stgDebugOpts = StgDebugOpts
stgDebugOpts
  } 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')
      = CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg CoreToStgOpts
opts Module
this_mod IdEnv HowBound
forall a. VarEnv a
emptyVarEnv CollectedCCs
emptyCollectedCCs CoreProgram
pgm

    -- See Note [Mapping Info Tables to Source Positions]
    (![StgTopBinding]
pgm'', !InfoTableProvMap
denv)
      | Bool
opt_InfoTableMap
      = StgDebugOpts
-> ModLocation
-> [StgTopBinding]
-> ([StgTopBinding], InfoTableProvMap)
collectDebugInformation StgDebugOpts
stgDebugOpts ModLocation
ml [StgTopBinding]
pgm'
      | Bool
otherwise = ([StgTopBinding]
pgm', InfoTableProvMap
emptyInfoTableProvMap)

    prof :: Bool
prof = Ways -> Way -> Bool
hasWay Ways
ways Way
WayProf

    final_ccs :: CollectedCCs
final_ccs
      | Bool
prof Bool -> Bool -> Bool
&& Bool
opt_AutoSccsOnIndividualCafs
      = ([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
    :: CoreToStgOpts
    -> Module
    -> IdEnv HowBound           -- environment for the bindings
    -> CollectedCCs
    -> CoreProgram
    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])

coreTopBindsToStg :: CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg CoreToStgOpts
_      Module
_        IdEnv HowBound
env CollectedCCs
ccs []
  = (IdEnv HowBound
env, CollectedCCs
ccs, [])
coreTopBindsToStg CoreToStgOpts
opts 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
  = CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg CoreToStgOpts
opts 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' ) = CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreBind
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg CoreToStgOpts
opts Module
this_mod IdEnv HowBound
env CollectedCCs
ccs CoreBind
b
    (IdEnv HowBound
env2, CollectedCCs
ccs2, [StgTopBinding]
bs') = CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg CoreToStgOpts
opts Module
this_mod IdEnv HowBound
env1 CollectedCCs
ccs1 CoreProgram
bs

coreTopBindToStg
        :: CoreToStgOpts
        -> Module
        -> IdEnv HowBound
        -> CollectedCCs
        -> CoreBind
        -> (IdEnv HowBound, CollectedCCs, StgTopBinding)

coreTopBindToStg :: CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreBind
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg CoreToStgOpts
_ 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 -> Int -> HowBound
LetBound LetInfo
TopLet Int
0
    in (IdEnv HowBound
env', CollectedCCs
ccs, Id -> ByteString -> StgTopBinding
forall (pass :: StgPass). Id -> ByteString -> GenStgTopBinding pass
StgTopStringLit Id
id ByteString
str)

coreTopBindToStg opts :: CoreToStgOpts
opts@CoreToStgOpts
  { coreToStg_platform :: CoreToStgOpts -> Platform
coreToStg_platform = Platform
platform
  } 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 -> Int -> HowBound
LetBound LetInfo
TopLet (Int -> HowBound) -> Int -> HowBound
forall a b. (a -> b) -> a -> b
$! CoreArg -> Int
manifestArity CoreArg
rhs

        (CollectedCCs
ccs', (Id
id', StgRhs
stg_rhs)) =
            Platform
-> IdEnv HowBound
-> CtsM (CollectedCCs, (Id, StgRhs))
-> (CollectedCCs, (Id, StgRhs))
forall a. Platform -> IdEnv HowBound -> CtsM a -> a
initCts Platform
platform IdEnv HowBound
env (CtsM (CollectedCCs, (Id, StgRhs)) -> (CollectedCCs, (Id, StgRhs)))
-> CtsM (CollectedCCs, (Id, StgRhs))
-> (CollectedCCs, (Id, StgRhs))
forall a b. (a -> b) -> a -> b
$
              CoreToStgOpts
-> Module
-> CollectedCCs
-> (Id, CoreArg)
-> CtsM (CollectedCCs, (Id, StgRhs))
coreToTopStgRhs CoreToStgOpts
opts Module
this_mod CollectedCCs
ccs (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 opts :: CoreToStgOpts
opts@CoreToStgOpts
  { coreToStg_platform :: CoreToStgOpts -> Platform
coreToStg_platform = Platform
platform
  } 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
        extra_env' :: [(Id, HowBound)]
extra_env' = [ (Id
b, LetInfo -> Int -> HowBound
LetBound LetInfo
TopLet (Int -> HowBound) -> Int -> HowBound
forall a b. (a -> b) -> a -> b
$! CoreArg -> Int
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', [(Id, StgRhs)]
stg_rhss)
          = Platform
-> IdEnv HowBound
-> CtsM (CollectedCCs, [(Id, StgRhs)])
-> (CollectedCCs, [(Id, StgRhs)])
forall a. Platform -> IdEnv HowBound -> CtsM a -> a
initCts Platform
platform IdEnv HowBound
env' (CtsM (CollectedCCs, [(Id, StgRhs)])
 -> (CollectedCCs, [(Id, StgRhs)]))
-> CtsM (CollectedCCs, [(Id, StgRhs)])
-> (CollectedCCs, [(Id, StgRhs)])
forall a b. (a -> b) -> a -> b
$ (CollectedCCs
 -> (Id, CoreArg) -> CtsM (CollectedCCs, (Id, StgRhs)))
-> CollectedCCs
-> [(Id, CoreArg)]
-> CtsM (CollectedCCs, [(Id, StgRhs)])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM (CoreToStgOpts
-> Module
-> CollectedCCs
-> (Id, CoreArg)
-> CtsM (CollectedCCs, (Id, StgRhs))
coreToTopStgRhs CoreToStgOpts
opts Module
this_mod) 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)]
[(BinderP 'Vanilla, StgRhs)]
stg_rhss
    in
    (IdEnv HowBound
env', CollectedCCs
ccs', StgTopBinding
bind)

coreToTopStgRhs
        :: CoreToStgOpts
        -> Module
        -> CollectedCCs
        -> (Id,CoreExpr)
        -> CtsM (CollectedCCs, (Id, StgRhs))

coreToTopStgRhs :: CoreToStgOpts
-> Module
-> CollectedCCs
-> (Id, CoreArg)
-> CtsM (CollectedCCs, (Id, StgRhs))
coreToTopStgRhs CoreToStgOpts
opts Module
this_mod CollectedCCs
ccs (Id
bndr, CoreArg
rhs)
  = do { new_rhs <- HasDebugCallStack => CoreArg -> CtsM PreStgRhs
CoreArg -> CtsM PreStgRhs
coreToPreStgRhs CoreArg
rhs

       ; let (stg_rhs, ccs') =
               mkTopStgRhs opts this_mod ccs bndr new_rhs
             stg_arity =
               StgRhs -> Int
stgRhsArity StgRhs
stg_rhs

       ; pure (ccs', (bndr, assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs)) }
  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 :: Int -> Bool
arity_ok Int
stg_arity
       | Name -> Bool
isExternalName (Id -> Name
idName Id
bndr) = Int
id_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
stg_arity
       | Bool
otherwise                    = Bool
True
    id_arity :: Int
id_arity  = Id -> Int
idArity Id
bndr
    mk_arity_msg :: Int -> SDoc
mk_arity_msg Int
stg_arity
        = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr,
                String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Id arity:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
id_arity,
                String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"STG arity:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
stg_arity]

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

-- coreToStgExpr panics if the input expression is a value lambda. CorePrep
-- ensures that value lambdas only exist as the RHS of bindings, which we
-- handle with the function coreToPreStgRhs.

coreToStgExpr
        :: HasDebugCallStack => 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 bignum literal should be left by the time this is called.
-- CorePrep should have converted them all to a real core representation.
coreToStgExpr :: HasDebugCallStack => CoreArg -> CtsM StgExpr
coreToStgExpr (Lit (LitNumber LitNumType
LitNumBigNat Integer
_))  = String -> CtsM StgExpr
forall a. HasCallStack => 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
_)
  -- See Note [Coercion tokens]
  = 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 -- Regular application
      Lit Literal
l | Literal -> Bool
isLitRubbish Literal
l             -- If there is LitRubbish at the head,
                                         --    discard the arguments
                                         --    Recompute representation, because in
                                         --    '(RUBBISH[rep] x) :: (T :: TYPE rep2)'
                                         --    rep might not be equal to rep2
            -> 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 -> StgExpr) -> Literal -> StgExpr
forall a b. (a -> b) -> a -> b
$ TypeOrConstraint -> RuntimeRepType -> Literal
LitRubbish TypeOrConstraint
TypeLike (RuntimeRepType -> Literal) -> RuntimeRepType -> Literal
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => RuntimeRepType -> RuntimeRepType
RuntimeRepType -> RuntimeRepType
getRuntimeRep (HasDebugCallStack => CoreArg -> RuntimeRepType
CoreArg -> RuntimeRepType
exprType CoreArg
expr))

      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) = HasDebugCallStack => 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

      [] -> HasDebugCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"Unexpected value lambda:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
expr

coreToStgExpr (Tick CoreTickish
tick CoreArg
expr)
  = do
       let !stg_tick :: StgTickish
stg_tick = RuntimeRepType -> CoreTickish -> StgTickish
coreToStgTick (HasDebugCallStack => CoreArg -> RuntimeRepType
CoreArg -> RuntimeRepType
exprType CoreArg
expr) CoreTickish
tick
       !expr2 <- HasDebugCallStack => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
expr
       return (StgTick stg_tick expr2)

coreToStgExpr (Cast CoreArg
expr Coercion
_)
  = HasDebugCallStack => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
expr

-- Cases require a little more real work.
coreToStgExpr (Case CoreArg
scrut Id
bndr RuntimeRepType
_ [Alt Id]
alts)
  | [Alt Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
alts
  -- 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.
  = HasDebugCallStack => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
scrut

  | Just CoreArg
rhs <- CoreArg -> Id -> [Alt Id] -> Maybe CoreArg
isUnsafeEqualityCase CoreArg
scrut Id
bndr [Alt Id]
alts
  -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
  = HasDebugCallStack => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
rhs

  | Bool
otherwise
  = do { scrut2 <- HasDebugCallStack => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
scrut
       ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
       ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) }
  where
    vars_alt :: CoreAlt -> CtsM StgAlt
    vars_alt :: Alt Id -> CtsM StgAlt
vars_alt (Alt AltCon
con [Id]
binders CoreArg
rhs)
      = let     -- Remove type variables
            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
        rhs2 <- HasDebugCallStack => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
rhs
        return $! GenStgAlt{ alt_con   = con
                           , alt_bndrs = binders'
                           , alt_rhs   = 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
  | RuntimeRepType -> Bool
isUnboxedTupleType RuntimeRepType
bndr_ty Bool -> Bool -> Bool
|| RuntimeRepType -> Bool
isUnboxedSumType RuntimeRepType
bndr_ty
  = Int -> AltType
MultiValAlt ([PrimRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PrimRep]
prim_reps)  -- always use MultiValAlt for unboxed tuples

  | Bool
otherwise
  = case [PrimRep]
prim_reps of
      [PrimRep
rep] | PrimRep -> Bool
isGcPtrRep PrimRep
rep ->
        case RuntimeRepType -> Maybe TyCon
tyConAppTyCon_maybe (RuntimeRepType -> RuntimeRepType
unwrapType RuntimeRepType
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 -> Int -> AltType
MultiValAlt ([PrimRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PrimRep]
not_unary)
  where
   bndr_ty :: RuntimeRepType
bndr_ty   = Id -> RuntimeRepType
idType Id
bndr
   prim_reps :: [PrimRep]
prim_reps = HasDebugCallStack => RuntimeRepType -> [PrimRep]
RuntimeRepType -> [PrimRep]
typePrimRep RuntimeRepType
bndr_ty

   _is_poly_alt_tycon :: TyCon -> Bool
_is_poly_alt_tycon TyCon
tc
        =  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
        | ((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

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

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

    let
        n_val_args       = [CoreArg] -> Int
forall b. [Arg b] -> Int
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   = Id -> HowBound -> Int
stgArity Id
f HowBound
how_bound
        saturated = Int
f_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n_val_args

        res_ty = HasDebugCallStack => CoreArg -> RuntimeRepType
CoreArg -> RuntimeRepType
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 = case Id -> IdDetails
idDetails Id
f of
                DataConWorkId DataCon
dc
                  | Bool
saturated    -> if DataCon -> Bool
isUnboxedSumDataCon DataCon
dc then
                                      DataCon -> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> StgExpr
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
NoNumber [StgArg]
args' ([CoreArg] -> [[PrimRep]]
sumPrimReps [CoreArg]
args)
                                    else
                                      DataCon -> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> StgExpr
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
NoNumber [StgArg]
args' []

                -- Some primitive operator that might be implemented as a library call.
                -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps
                -- we require that primop applications be saturated.
                PrimOpId PrimOp
op ConcreteTyVars
_    -> -- assertPpr saturated (ppr f <+> ppr args) $
                                    StgOp -> [StgArg] -> RuntimeRepType -> StgExpr
forall (pass :: StgPass).
StgOp -> [StgArg] -> RuntimeRepType -> GenStgExpr pass
StgOpApp (PrimOp -> StgOp
StgPrimOp PrimOp
op) [StgArg]
args' RuntimeRepType
res_ty

                -- A call to some primitive Cmm function.
                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] -> RuntimeRepType -> StgExpr
forall (pass :: StgPass).
StgOp -> [StgArg] -> RuntimeRepType -> GenStgExpr pass
StgOpApp (PrimCall -> StgOp
StgPrimCallOp (CLabelString -> Unit -> PrimCall
PrimCall CLabelString
lbl Unit
pkgId)) [StgArg]
args' RuntimeRepType
res_ty

                -- A regular foreign call.
                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] -> RuntimeRepType -> StgExpr
forall (pass :: StgPass).
StgOp -> [StgArg] -> RuntimeRepType -> GenStgExpr pass
StgOpApp (ForeignCall -> RuntimeRepType -> StgOp
StgFCallOp ForeignCall
call (Id -> RuntimeRepType
idType Id
f)) [StgArg]
args' RuntimeRepType
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
t !GenStgExpr pass
e = StgTickish -> GenStgExpr pass -> GenStgExpr pass
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
t GenStgExpr pass
e
        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 (RuntimeRepType -> CoreTickish -> StgTickish
coreToStgTick RuntimeRepType
res_ty) [CoreTickish]
ticks [StgTickish] -> [StgTickish] -> [StgTickish]
forall a. [a] -> [a] -> [a]
++ [StgTickish]
ticks')

    -- Forcing these fixes a leak in the code generator, noticed while
    -- profiling for #4367
    app `seq` return tapp


-- Given Core arguments to an unboxed sum datacon, return the 'PrimRep's
-- of every alternative. For example, in (#_|#) @LiftedRep @IntRep @Int @Int# 0
-- the arguments are [Type LiftedRep, Type IntRep, Type Int, Type Int#, 0]
-- and we return the list [[LiftedRep], [IntRep]].
-- See Note [Representations in StgConApp] in GHC.Stg.Unarise.
sumPrimReps :: [CoreArg] -> [[PrimRep]]
sumPrimReps :: [CoreArg] -> [[PrimRep]]
sumPrimReps (Type RuntimeRepType
ty : [CoreArg]
args) | RuntimeRepType -> Bool
isRuntimeRepKindedTy RuntimeRepType
ty
  = HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep]
SDoc -> RuntimeRepType -> [PrimRep]
runtimeRepPrimRep (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sumPrimReps") RuntimeRepType
ty [PrimRep] -> [[PrimRep]] -> [[PrimRep]]
forall a. a -> [a] -> [a]
: [CoreArg] -> [[PrimRep]]
sumPrimReps [CoreArg]
args
sumPrimReps [CoreArg]
_ = []
-- ---------------------------------------------------------------------------
-- Argument lists
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------

getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg
-- A (non-erased) trivial CoreArg corresponds to an atomic StgArg.
-- CoreArgs may not immediately look trivial, e.g., `case e of {}` or
-- `case unsafeequalityProof of UnsafeRefl -> e` might intervene.
-- Good thing we can just call `trivial_expr_fold` here.
getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg
getStgArgFromTrivialArg CoreArg
e = (Id -> StgArg)
-> (Literal -> StgArg) -> StgArg -> StgArg -> CoreArg -> StgArg
forall r. (Id -> r) -> (Literal -> r) -> r -> r -> CoreArg -> r
trivial_expr_fold Id -> StgArg
StgVarArg Literal -> StgArg
StgLitArg StgArg
panic StgArg
panic CoreArg
e
  where
    panic :: StgArg
panic = String -> SDoc -> StgArg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getStgArgFromTrivialArg" (CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
e)

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 RuntimeRepType
_ : [CoreArg]
args) = do     -- Type argument
    (args', ts) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [CoreArg]
args
    return (args', ts)

coreToStgArgs (Coercion Coercion
_ : [CoreArg]
args) -- Coercion argument; See Note [Coercion tokens]
  = do { (args', ts) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [CoreArg]
args
       ; return (StgVarArg coercionTokenId : args', ts) }

coreToStgArgs (CoreArg
arg : [CoreArg]
args) = do         -- Non-type argument
    (stg_args, ticks) <- [CoreArg] -> CtsM ([StgArg], [StgTickish])
coreToStgArgs [CoreArg]
args
    -- We know that `arg` must be trivial, but it may contain Ticks.
    -- Example from test case `decodeMyStack`:
    --   $ @... ((src<decodeMyStack.hs:18:26-28> Data.Tuple.snd) @Int @[..])
    -- Note that unfortunately the Tick is not at the top.
    -- So we'll traverse the expression twice:
    --   * Once with `stripTicksT` (which collects *all* ticks from the expression)
    --   * and another time with `getStgArgFromTrivialArg`.
    -- Since the argument is trivial, the only place the Tick can occur is
    -- somehow wrapping a variable (give or take type args, as above).
    platform <- getPlatform
    let arg_ty = HasDebugCallStack => CoreArg -> RuntimeRepType
CoreArg -> RuntimeRepType
exprType CoreArg
arg
        ticks' = (CoreTickish -> StgTickish) -> [CoreTickish] -> [StgTickish]
forall a b. (a -> b) -> [a] -> [b]
map (RuntimeRepType -> CoreTickish -> StgTickish
coreToStgTick RuntimeRepType
arg_ty) ((CoreTickish -> Bool) -> CoreArg -> [CoreTickish]
forall b. (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
stripTicksT (Bool -> Bool
not (Bool -> Bool) -> (CoreTickish -> Bool) -> CoreTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode) CoreArg
arg)
        arg' = HasDebugCallStack => CoreArg -> StgArg
CoreArg -> StgArg
getStgArgFromTrivialArg CoreArg
arg
        arg_rep = HasDebugCallStack => RuntimeRepType -> [PrimRep]
RuntimeRepType -> [PrimRep]
typePrimRep RuntimeRepType
arg_ty
        stg_arg_rep = StgArg -> [PrimRep]
stgArgRep StgArg
arg'
        bad_args = Bool -> Bool
not (Platform -> [PrimRep] -> [PrimRep] -> Bool
primRepsCompatible Platform
platform [PrimRep]
arg_rep [PrimRep]
stg_arg_rep)

    massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg)
    warnPprTraceM bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg)

    return (arg' : stg_args, ticks' ++ ticks)

coreToStgTick :: Type -- type of the ticked expression
              -> CoreTickish
              -> StgTickish
coreToStgTick :: RuntimeRepType -> CoreTickish -> StgTickish
coreToStgTick RuntimeRepType
_ty (HpcTick Module
m Int
i)                = Module -> Int -> StgTickish
forall (pass :: TickishPass). Module -> Int -> GenTickish pass
HpcTick Module
m Int
i
coreToStgTick RuntimeRepType
_ty (SourceNote RealSrcSpan
span LexicalFastString
nm)         = RealSrcSpan -> LexicalFastString -> StgTickish
forall (pass :: TickishPass).
RealSrcSpan -> LexicalFastString -> GenTickish pass
SourceNote RealSrcSpan
span LexicalFastString
nm
coreToStgTick RuntimeRepType
_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 !RuntimeRepType
ty (Breakpoint XBreakpoint 'TickishPassCore
_ Int
bid [XTickishId 'TickishPassCore]
fvs Module
modl)  = XBreakpoint 'TickishPassStg
-> Int -> [XTickishId 'TickishPassStg] -> Module -> StgTickish
forall (pass :: TickishPass).
XBreakpoint pass
-> Int -> [XTickishId pass] -> Module -> GenTickish pass
Breakpoint RuntimeRepType
XBreakpoint 'TickishPassStg
ty Int
bid [XTickishId 'TickishPassCore]
[XTickishId 'TickishPassStg]
fvs Module
modl

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

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

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
  = HasDebugCallStack => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
body

  | Bool
otherwise
  = do { (bind2, env_ext) <- CoreBind -> CtsM (GenStgBinding 'Vanilla, [(Id, HowBound)])
vars_bind CoreBind
bind

          -- Do the body
         ; body2 <- extendVarEnvCts env_ext $
                    coreToStgExpr body

        -- Compute the new let-expression
        ; let 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

        ; return new_let }
  where
    mk_binding :: a -> CoreArg -> (a, HowBound)
mk_binding a
binder CoreArg
rhs
        = (a
binder, LetInfo -> Int -> HowBound
LetBound LetInfo
NestedLet (CoreArg -> Int
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
        rhs2 <- (Id, CoreArg) -> CtsM StgRhs
coreToStgRhs (Id
binder,CoreArg
rhs)
        let
            env_ext_item = Id -> CoreArg -> (Id, HowBound)
forall {a}. a -> CoreArg -> (a, HowBound)
mk_binding Id
binder CoreArg
rhs

        return (StgNonRec binder rhs2, [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
              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
              return (StgRec (binders `zip` rhss2), env_ext)

coreToStgRhs :: (Id,CoreExpr)
             -> CtsM StgRhs

coreToStgRhs :: (Id, CoreArg) -> CtsM StgRhs
coreToStgRhs (Id
bndr, CoreArg
rhs) = do
    new_rhs <- HasDebugCallStack => CoreArg -> CtsM PreStgRhs
CoreArg -> CtsM PreStgRhs
coreToPreStgRhs CoreArg
rhs
    return (mkStgRhs bndr new_rhs)

-- Represents the RHS of a binding for use with mk(Top)StgRhs.
data PreStgRhs = PreStgRhs [Id] StgExpr Type -- The [Id] is empty for thunks

-- Convert the RHS of a binding from Core to STG. This is a wrapper around
-- coreToStgExpr that can handle value lambdas.
coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs
coreToPreStgRhs :: HasDebugCallStack => CoreArg -> CtsM PreStgRhs
coreToPreStgRhs CoreArg
expr
  = [(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 { body' <- HasDebugCallStack => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
body
       ; return (PreStgRhs args' body' (exprType body)) }
  where
   ([Id]
args, CoreArg
body) = CoreArg -> ([Id], CoreArg)
myCollectBinders CoreArg
expr
   args' :: [Id]
args'        = [Id] -> [Id]
filterStgBinders [Id]
args

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

mkTopStgRhs :: CoreToStgOpts
-> Module
-> CollectedCCs
-> Id
-> PreStgRhs
-> (StgRhs, CollectedCCs)
mkTopStgRhs CoreToStgOpts
  { coreToStg_platform :: CoreToStgOpts -> Platform
coreToStg_platform = Platform
platform
  , coreToStg_ExternalDynamicRefs :: CoreToStgOpts -> Bool
coreToStg_ExternalDynamicRefs = Bool
opt_ExternalDynamicRefs
  , coreToStg_AutoSccsOnIndividualCafs :: CoreToStgOpts -> Bool
coreToStg_AutoSccsOnIndividualCafs = Bool
opt_AutoSccsOnIndividualCafs
  } Module
this_mod CollectedCCs
ccs Id
bndr (PreStgRhs [Id]
bndrs StgExpr
rhs RuntimeRepType
typ)
  | Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bndrs)
  = -- The list of arguments is non-empty, so not CAF
    ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> RuntimeRepType
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> RuntimeRepType
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                    CostCentreStack
dontCareCCS
                    UpdateFlag
ReEntrant
                    [Id]
[BinderP 'Vanilla]
bndrs StgExpr
rhs RuntimeRepType
typ
    , CollectedCCs
ccs )

  -- After this point we know that `bndrs` is empty,
  -- so this is not a function binding
  | StgConApp DataCon
con ConstructorNumber
mn [StgArg]
args [[PrimRep]]
_ <- StgExpr
unticked_rhs
  , -- Dynamic StgConApps are updatable
    Bool -> Bool
not (Platform -> Bool -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp Platform
platform Bool
opt_ExternalDynamicRefs Module
this_mod DataCon
con [StgArg]
args)
  = -- CorePrep does this right, but just to make sure
    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
forall doc. IsDoc doc => doc -> doc -> doc
$$ DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
args)
    ( CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> RuntimeRepType
-> StgRhs
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> RuntimeRepType
-> GenStgRhs pass
StgRhsCon CostCentreStack
dontCareCCS DataCon
con ConstructorNumber
mn [StgTickish]
ticks [StgArg]
args RuntimeRepType
typ, CollectedCCs
ccs )

  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
  | Bool
opt_AutoSccsOnIndividualCafs
  = ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> RuntimeRepType
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> RuntimeRepType
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                    CostCentreStack
caf_ccs
                    UpdateFlag
upd_flag [] StgExpr
rhs RuntimeRepType
typ
    , CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
collectCC CostCentre
caf_cc CostCentreStack
caf_ccs CollectedCCs
ccs )

  | Bool
otherwise
  = ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> RuntimeRepType
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> RuntimeRepType
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                    CostCentreStack
all_cafs_ccs
                    UpdateFlag
upd_flag [] StgExpr
rhs RuntimeRepType
typ
    , 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
isAtMostOnceDmd (Id -> Demand
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 -> PreStgRhs -> StgRhs
mkStgRhs :: Id -> PreStgRhs -> StgRhs
mkStgRhs Id
bndr (PreStgRhs [Id]
bndrs StgExpr
rhs RuntimeRepType
typ)
  | 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
-> RuntimeRepType
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> RuntimeRepType
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                  CostCentreStack
currentCCS
                  UpdateFlag
ReEntrant
                  [Id]
[BinderP 'Vanilla]
bndrs StgExpr
rhs RuntimeRepType
typ

  -- After this point we know that `bndrs` is empty,
  -- so this is not a function binding

  | Id -> Bool
isJoinId Id
bndr -- Must be a nullary join point
  = -- It might have /type/ arguments (T18328),
    -- so its JoinArity might be >0
    XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> RuntimeRepType
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> RuntimeRepType
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                  CostCentreStack
currentCCS
                  UpdateFlag
ReEntrant -- ignored for LNE
                  [] StgExpr
rhs RuntimeRepType
typ

  | StgConApp DataCon
con ConstructorNumber
mn [StgArg]
args [[PrimRep]]
_ <- StgExpr
unticked_rhs
  = CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> RuntimeRepType
-> StgRhs
forall (pass :: StgPass).
CostCentreStack
-> DataCon
-> ConstructorNumber
-> [StgTickish]
-> [StgArg]
-> RuntimeRepType
-> GenStgRhs pass
StgRhsCon CostCentreStack
currentCCS DataCon
con ConstructorNumber
mn [StgTickish]
ticks [StgArg]
args RuntimeRepType
typ

  | Bool
otherwise
  = XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> RuntimeRepType
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> RuntimeRepType
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent
                  CostCentreStack
currentCCS
                  UpdateFlag
upd_flag [] StgExpr
rhs RuntimeRepType
typ
  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
isAtMostOnceDmd (Id -> Demand
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
    { forall a. CtsM a -> Platform -> IdEnv HowBound -> a
unCtsM :: Platform -- Needed for checking for bad coercions in coreToStgArgs
             -> 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         -- 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
$c== :: HowBound -> HowBound -> Bool
== :: HowBound -> HowBound -> Bool
$c/= :: HowBound -> HowBound -> Bool
/= :: HowBound -> HowBound -> Bool
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
$c== :: LetInfo -> LetInfo -> Bool
== :: LetInfo -> LetInfo -> Bool
$c/= :: LetInfo -> LetInfo -> Bool
/= :: 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 :: Platform -> IdEnv HowBound -> CtsM a -> a
initCts :: forall a. Platform -> IdEnv HowBound -> CtsM a -> a
initCts Platform
platform IdEnv HowBound
env CtsM a
m = CtsM a -> Platform -> IdEnv HowBound -> a
forall a. CtsM a -> Platform -> IdEnv HowBound -> a
unCtsM CtsM a
m Platform
platform IdEnv HowBound
env



{-# INLINE thenCts #-}
{-# INLINE returnCts #-}

returnCts :: a -> CtsM a
returnCts :: forall a. a -> CtsM a
returnCts a
e = (Platform -> IdEnv HowBound -> a) -> CtsM a
forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> a) -> CtsM a)
-> (Platform -> IdEnv HowBound -> a) -> CtsM a
forall a b. (a -> b) -> a -> b
$ \Platform
_ 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 = (Platform -> IdEnv HowBound -> b) -> CtsM b
forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> b) -> CtsM b)
-> (Platform -> IdEnv HowBound -> b) -> CtsM b
forall a b. (a -> b) -> a -> b
$ \Platform
platform IdEnv HowBound
env
  -> CtsM b -> Platform -> IdEnv HowBound -> b
forall a. CtsM a -> Platform -> IdEnv HowBound -> a
unCtsM (a -> CtsM b
k (CtsM a -> Platform -> IdEnv HowBound -> a
forall a. CtsM a -> Platform -> IdEnv HowBound -> a
unCtsM CtsM a
m Platform
platform IdEnv HowBound
env)) Platform
platform 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

getPlatform :: CtsM Platform
getPlatform :: CtsM Platform
getPlatform = (Platform -> IdEnv HowBound -> Platform) -> CtsM Platform
forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
CtsM Platform -> IdEnv HowBound -> Platform
forall a b. a -> b -> a
const

-- Functions specific to this monad:

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
   =    (Platform -> IdEnv HowBound -> a) -> CtsM a
forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> a) -> CtsM a)
-> (Platform -> IdEnv HowBound -> a) -> CtsM a
forall a b. (a -> b) -> a -> b
$   \Platform
platform IdEnv HowBound
env
   -> CtsM a -> Platform -> IdEnv HowBound -> a
forall a. CtsM a -> Platform -> IdEnv HowBound -> a
unCtsM CtsM a
expr Platform
platform (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 = (Platform -> IdEnv HowBound -> HowBound) -> CtsM HowBound
forall a. (Platform -> IdEnv HowBound -> a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> HowBound) -> CtsM HowBound)
-> (Platform -> IdEnv HowBound -> HowBound) -> CtsM HowBound
forall a b. (a -> b) -> a -> b
$ \Platform
_ 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>") -- 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)

-- | If the argument expression is (potential chain of) 'App', return the head
-- of the app chain, and collect ticks/args along the chain.
-- INVARIANT: If the app head is trivial, return the atomic Var/Lit that was
-- wrapped in casts, empty case, ticks, etc.
-- So keep in sync with 'exprIsTrivial'.
myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish])
myCollectArgs :: HasDebugCallStack => 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
forall doc. IsDoc doc => doc -> doc -> doc
$$ [CoreArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreArg]
as SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [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
$
                                -- See Note [Ticks in applications]
                                CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
e [CoreArg]
as (CoreTickish
tCoreTickish -> [CoreTickish] -> [CoreTickish]
forall a. a -> [a] -> [a]
:[CoreTickish]
ts) -- ticks can appear in type apps
    go (Cast CoreArg
e Coercion
_)       [CoreArg]
as [CoreTickish]
ts = CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
e [CoreArg]
as [CoreTickish]
ts
    go (Case CoreArg
e Id
b RuntimeRepType
_ [Alt Id]
alts) [CoreArg]
as [CoreTickish]
ts  -- Just like in exprIsTrivial!
                                -- Otherwise we fall over in case we encounter
                                -- `(case f a of {}) b` in the future.
       | [Alt Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
alts
       = Bool
-> SDoc
-> (CoreArg, [CoreArg], [CoreTickish])
-> (CoreArg, [CoreArg], [CoreTickish])
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([CoreArg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreArg]
as) (CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
e SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [CoreArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreArg]
as SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ CoreArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreArg
expr) ((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 [] [CoreTickish]
ts -- NB: Empty case discards arguments
       | Just CoreArg
rhs <- CoreArg -> Id -> [Alt Id] -> Maybe CoreArg
isUnsafeEqualityCase CoreArg
e Id
b [Alt Id]
alts
       = CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
rhs [CoreArg]
as [CoreTickish]
ts         -- Discards unsafeCoerce in App heads
    go (Lam Id
b CoreArg
e)        [CoreArg]
as [CoreTickish]
ts
       | Id -> Bool
isTyVar Id
b            = CoreArg
-> [CoreArg]
-> [CoreTickish]
-> (CoreArg, [CoreArg], [CoreTickish])
go CoreArg
e (Int -> [CoreArg] -> [CoreArg]
forall a. Int -> [a] -> [a]
drop Int
1 [CoreArg]
as) [CoreTickish]
ts -- Note [Collect args]
    go CoreArg
e                [CoreArg]
as [CoreTickish]
ts = (CoreArg
e, [CoreArg]
as, [CoreTickish]
ts)

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

Note [Ticks in applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We can get an application like
   (tick t f) True False
via inlining in the CorePrep pass; see Note [Inlining in CorePrep]
in GHC.CoreToStg.Prep.  The tick does not satisfy tickishIsCode;
the inlining-in-CorePrep happens for cpExprIsTrivial which tests
tickishIsCode.

So we test the same thing here, pushing any non-code ticks to
the top (they don't generate any code, after all).  This showed
up in the fallout from fixing #19360.
-}

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

data CoreToStgOpts = CoreToStgOpts
  { CoreToStgOpts -> Platform
coreToStg_platform :: Platform
  , CoreToStgOpts -> Ways
coreToStg_ways :: Ways
  , CoreToStgOpts -> Bool
coreToStg_AutoSccsOnIndividualCafs :: Bool
  , CoreToStgOpts -> Bool
coreToStg_InfoTableMap :: Bool
  , CoreToStgOpts -> Bool
coreToStg_ExternalDynamicRefs :: Bool
  , CoreToStgOpts -> StgDebugOpts
coreToStg_stgDebugOpts :: StgDebugOpts
  }