{-# 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.Make
import GHC.Stg.Utils (allowTopLevelConApp)

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 )
import GHC.Types.Basic  ( Arity, TypeOrConstraint(..) )
import GHC.Types.Literal
import GHC.Types.ForeignCall
import GHC.Types.IPE
import GHC.Types.Unique.Supply
import GHC.Types.Unique

import GHC.Unit.Module
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 GHC.Data.FastString

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.”)

Note [Saturation of data constructors in STG]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We guarantee that `StgConApp` is an exactly-saturated application of a data
constructor worker.

* If the data constructor is /under/-saturated we just fall through to build
  a `StgApp`.  Remember, data constructor workers have a regular top-level definition
  (injected by GHC.CoreToStg.Prep.mkDataConWorkers) so we can partially apply
  that function.

* If the data constructor is /over/-saturated, which can happen (see #23865) we again
  fall through to `StgApp`.  That will fail horribly at runtime (by applying data
  constructor to an argument) but it should be in dead code, and at least the compiler
  itself won't crash.  (We could inject an error-thunk instead.)

Note [Naked lambdas in coreToStgExpr]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  f x = case x of
           True  -> \y. y+x
           False -> blah
If `f` is not eta expanded (which would have happened in Prep if it was
going to happen at all, the code for f must allocate a closure for the
(\y. y+x).  So the STG code we want has

     True -> let pap = \y. y+x
             in pap

The Lam case of `coreToStgExpr` deals with adding this `StgLet`. It's the
main reason we need a unique supply in the monad.

Historical note: in the past, Prep guaranteed there would be no such naked
lambdas, so we didn't need a unique supply at all. But that proved too hard
in the end (see Note [Eta expansion and the CorePrep invariants]) so we
just deal with it here; it's very easy.
-}

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


coreToStg :: CoreToStgOpts -> Module -> ModLocation
          -> CoreProgram
          -> IO ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg :: CoreToStgOpts
-> Module
-> ModLocation
-> CoreProgram
-> IO ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg CoreToStgOpts
opts Module
this_mod ModLocation
ml CoreProgram
pgm
  = do { us <- UniqueTag -> IO UniqSupply
mkSplitUniqSupply UniqueTag
StgTag
       ; let (_, (local_ccs, local_cc_stacks), pgm')
                = initCts opts us $
                  coreTopBindsToStg opts this_mod emptyCollectedCCs pgm

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

             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

      ; return (pgm'', denv, final_ccs) }
  where
    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 }
       = CoreToStgOpts
opts

    prof :: Bool
prof = Ways -> Way -> Bool
hasWay Ways
ways Way
WayProf
    (CostCentre
all_cafs_cc, CostCentreStack
all_cafs_ccs) = Module -> (CostCentre, CostCentreStack)
getAllCAFsCC Module
this_mod

coreTopBindsToStg
    :: CoreToStgOpts
    -> Module
    -> CollectedCCs
    -> CoreProgram
    -> CtsM (IdEnv HowBound, CollectedCCs, [StgTopBinding])

coreTopBindsToStg :: CoreToStgOpts
-> Module
-> CollectedCCs
-> CoreProgram
-> CtsM (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg CoreToStgOpts
_ Module
_ CollectedCCs
ccs []
  = do { env <- CtsM (IdEnv HowBound)
getCtsEnv
       ; return (env, ccs, []) }

coreTopBindsToStg CoreToStgOpts
opts Module
this_mod CollectedCCs
ccs (CoreBind
b:CoreProgram
bs)
  | NonRec Id
_ CoreArg
rhs <- CoreBind
b, CoreArg -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreArg
rhs
  = CoreToStgOpts
-> Module
-> CollectedCCs
-> CoreProgram
-> CtsM (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg CoreToStgOpts
opts Module
this_mod CollectedCCs
ccs CoreProgram
bs
  | Bool
otherwise
  = do { (env1, ccs1, b' ) <- CoreToStgOpts
-> Module
-> CollectedCCs
-> CoreBind
-> CtsM (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg CoreToStgOpts
opts Module
this_mod CollectedCCs
ccs CoreBind
b
       ; (env2, ccs2, bs') <- setCtsEnv env1 $
                              coreTopBindsToStg opts this_mod ccs1 bs
      ; return (env2, ccs2, b':bs') }

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

coreTopBindToStg :: CoreToStgOpts
-> Module
-> CollectedCCs
-> CoreBind
-> CtsM (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg CoreToStgOpts
_ Module
_ 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
  = do { env <- CtsM (IdEnv HowBound)
getCtsEnv
       ; let 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 = LetInfo -> Int -> HowBound
LetBound LetInfo
TopLet Int
0
       ; return (env', ccs, StgTopStringLit id str) }

coreTopBindToStg CoreToStgOpts
opts Module
this_mod CollectedCCs
ccs (NonRec Id
id CoreArg
rhs)
  = do { (ccs', (id', stg_rhs)) <- CoreToStgOpts
-> Module
-> CollectedCCs
-> (Id, CoreArg)
-> CtsM (CollectedCCs, (Id, StgRhs))
coreToTopStgRhs CoreToStgOpts
opts Module
this_mod CollectedCCs
ccs (Id
id,CoreArg
rhs)

       ; env <- getCtsEnv
       ; let 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 = LetInfo -> Int -> HowBound
LetBound LetInfo
TopLet (Int -> HowBound) -> Int -> HowBound
forall a b. (a -> b) -> a -> b
$! CoreArg -> Int
manifestArity CoreArg
rhs
             bind      = GenStgBinding 'Vanilla -> StgTopBinding
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
       ; return (env', ccs', bind) }

coreTopBindToStg CoreToStgOpts
opts Module
this_mod CollectedCCs
ccs (Rec [(Id, CoreArg)]
pairs)
  = Bool
-> CtsM (IdEnv HowBound, CollectedCCs, StgTopBinding)
-> CtsM (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)) (CtsM (IdEnv HowBound, CollectedCCs, StgTopBinding)
 -> CtsM (IdEnv HowBound, CollectedCCs, StgTopBinding))
-> CtsM (IdEnv HowBound, CollectedCCs, StgTopBinding)
-> CtsM (IdEnv HowBound, CollectedCCs, StgTopBinding)
forall a b. (a -> b) -> a -> b
$
    do { env <- CtsM (IdEnv HowBound)
getCtsEnv
       ; let 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 -> [(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
       ; (ccs', stg_rhss) <- setCtsEnv env' $
                             mapAccumLM (coreToTopStgRhs opts this_mod) ccs pairs
       ; let bind = GenStgBinding 'Vanilla -> StgTopBinding
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

       ; return (env', ccs', 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 => Id -> CoreArg -> CtsM MkStgRhs
Id -> CoreArg -> CtsM MkStgRhs
coreToMkStgRhs Id
bndr CoreArg
rhs

       ; let (stg_rhs, ccs') =
               mkTopStgRhs (allowTopLevelConApp (coreToStg_platform opts) (coreToStg_ExternalDynamicRefs opts))
                           (coreToStg_AutoSccsOnIndividualCafs 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 coreToMkStgRhs.

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] -> [StgTickish] -> Type -> CtsM StgExpr
coreToStgApp Id
v [] [] (Id -> Type
idType Id
v)
coreToStgExpr (Coercion Coercion
_)
  -- See Note [Coercion tokens]
  = Id -> [CoreArg] -> [StgTickish] -> Type -> CtsM StgExpr
coreToStgApp Id
coercionTokenId [] [] (Id -> Type
idType Id
coercionTokenId)

coreToStgExpr expr :: CoreArg
expr@(App CoreArg
_ CoreArg
_)
  = case CoreArg
app_head of
      Var Id
f -> Id -> [CoreArg] -> [StgTickish] -> Type -> CtsM StgExpr
coreToStgApp Id
f [CoreArg]
args [StgTickish]
ticks Type
res_ty -- Regular application
      Lit Literal
l | Literal -> Bool
isLitRubbish Literal
l  -- Discard arguments if head is LitRubbish
                              -- 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
Literal -> StgExpr
forall (pass :: StgPass). Literal -> GenStgExpr pass
StgLit (Literal -> StgExpr) -> Literal -> StgExpr
forall a b. (a -> b) -> a -> b
$ TypeOrConstraint -> Type -> Literal
LitRubbish TypeOrConstraint
TypeLike (Type -> Literal) -> Type -> Literal
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
res_ty)

      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
      res_ty :: Type
res_ty                  = HasDebugCallStack => CoreArg -> Type
CoreArg -> Type
exprType CoreArg
expr
      (CoreArg
app_head, [CoreArg]
args, [StgTickish]
ticks) = HasDebugCallStack =>
CoreArg -> Type -> (CoreArg, [CoreArg], [StgTickish])
CoreArg -> Type -> (CoreArg, [CoreArg], [StgTickish])
myCollectArgs CoreArg
expr Type
res_ty

coreToStgExpr expr :: CoreArg
expr@(Lam {})
  | [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
val_bndrs
  = HasDebugCallStack => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
body
  | Bool
otherwise
  = -- See Note [Naked lambdas in coreToStgExpr]
    do { body' <- [(Id, HowBound)] -> CtsM StgExpr -> CtsM StgExpr
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [ (Id
a, HowBound
LambdaBound) | Id
a <- [Id]
val_bndrs ] (CtsM StgExpr -> CtsM StgExpr) -> CtsM StgExpr -> CtsM StgExpr
forall a b. (a -> b) -> a -> b
$
                  HasDebugCallStack => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
body
       ; uniq <- getCtsUnique
       ; let body_ty = HasDebugCallStack => CoreArg -> Type
CoreArg -> Type
exprType CoreArg
body
             fun_ty  = [Id] -> Type -> Type
mkLamTypes [Id]
val_bndrs Type
body_ty
                       -- This type is a bit ill-formed but it doesn't matter
             rhs = XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> Type
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> Type
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtFieldSilent
noExtFieldSilent CostCentreStack
currentCCS
                                 UpdateFlag
ReEntrant [Id]
[BinderP 'Vanilla]
val_bndrs StgExpr
body' Type
body_ty
             tmp_fun = FastString -> Unique -> Type -> Type -> Id
mkSysLocal (String -> FastString
fsLit String
"pap") Unique
uniq Type
ManyTy Type
fun_ty
       ; return (StgLet noExtFieldSilent (StgNonRec tmp_fun rhs) $
                 StgApp tmp_fun []) }
  where
    ([Id]
val_bndrs, CoreArg
body) = JoinPointHood -> CoreArg -> ([Id], CoreArg)
myCollectBinders JoinPointHood
NotJoinPoint CoreArg
expr

coreToStgExpr (Tick CoreTickish
tick CoreArg
expr)
  = do
       let !stg_tick :: StgTickish
stg_tick = Type -> CoreTickish -> StgTickish
coreToStgTick (HasDebugCallStack => CoreArg -> Type
CoreArg -> Type
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 Type
_ [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
  | Type -> Bool
isUnboxedTupleType Type
bndr_ty Bool -> Bool -> Bool
|| Type -> Bool
isUnboxedSumType Type
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 Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
unwrapType Type
bndr_ty) of
          Just TyCon
tc
            | TyCon -> Bool
isAbstractTyCon TyCon
tc -> AltType
look_for_better_tycon
            | TyCon -> Bool
isAlgTyCon TyCon
tc      -> TyCon -> AltType
AlgAlt TyCon
tc
            | Bool
otherwise          -> Bool -> SDoc -> AltType -> AltType
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TyCon -> Bool
_is_poly_alt_tycon TyCon
tc) (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) AltType
PolyAlt
          Maybe TyCon
Nothing                -> AltType
PolyAlt
      [PrimRep
non_gcd] -> PrimRep -> AltType
PrimAlt PrimRep
non_gcd
      [PrimRep]
not_unary -> Int -> AltType
MultiValAlt ([PrimRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
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]
typePrimRep Type
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
             -> [StgTickish]  -- From the application nodes
             -> Type          -- Type of the whole application
             -> CtsM StgExpr
coreToStgApp :: Id -> [CoreArg] -> [StgTickish] -> Type -> CtsM StgExpr
coreToStgApp Id
f [CoreArg]
core_args [StgTickish]
app_ticks Type
res_ty
  = do { how_bound             <- Id -> CtsM HowBound
lookupVarCts Id
f
       ; (stg_args, arg_ticks) <- coreToStgArgs core_args
       ; let app = Id -> HowBound -> [CoreArg] -> [StgArg] -> Type -> StgExpr
mkStgApp Id
f HowBound
how_bound [CoreArg]
core_args [StgArg]
stg_args Type
res_ty
             all_ticks =  [StgTickish]
app_ticks [StgTickish] -> [StgTickish] -> [StgTickish]
forall a. [a] -> [a] -> [a]
++ [StgTickish]
arg_ticks

       -- Forcing these fixes a leak in the code generator,
       -- noticed while profiling for #4367
       ; app `seq` return (foldr add_tick app all_ticks)}
  where
    add_tick :: StgTickish -> GenStgExpr pass -> GenStgExpr pass
add_tick !StgTickish
t !GenStgExpr pass
e = StgTickish -> GenStgExpr pass -> GenStgExpr pass
forall (pass :: StgPass).
StgTickish -> GenStgExpr pass -> GenStgExpr pass
StgTick StgTickish
t GenStgExpr pass
e

mkStgApp :: Id -> HowBound -> [CoreArg] -> [StgArg] -> Type -> StgExpr
mkStgApp :: Id -> HowBound -> [CoreArg] -> [StgArg] -> Type -> StgExpr
mkStgApp Id
f HowBound
how_bound [CoreArg]
core_args [StgArg]
stg_args Type
res_ty
  = case HasCallStack => Id -> IdDetails
Id -> IdDetails
idDetails Id
f of
      DataConWorkId DataCon
dc
        | Bool
exactly_saturated  -- See Note [Saturation of data constructors in STG]
        -> 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]
stg_args ([CoreArg] -> [[PrimRep]]
sumPrimReps [CoreArg]
core_args)
           else
              DataCon -> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> StgExpr
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> GenStgExpr pass
StgConApp DataCon
dc ConstructorNumber
NoNumber [StgArg]
stg_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 stg_args) $
                          StgOp -> [StgArg] -> Type -> StgExpr
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (PrimOp -> StgOp
StgPrimOp PrimOp
op) [StgArg]
stg_args Type
res_ty

      -- A call to some primitive Cmm function.
      FCallId (CCall (CCallSpec
                            (StaticTarget XStaticTarget GhcTc
ext FastString
lbl ForeignKind
ForeignFunction) CCallConv
PrimCallConv Safety
_))
                            | TargetIsInThat Unit
unit <- StaticTargetGhc -> CCallStaticTargetUnit
staticTargetUnit XStaticTarget GhcTc
StaticTargetGhc
ext
                       -> Bool -> StgExpr -> StgExpr
forall a. HasCallStack => Bool -> a -> a
assert Bool
exactly_saturated (StgExpr -> StgExpr) -> StgExpr -> StgExpr
forall a b. (a -> b) -> a -> b
$
                          StgOp -> [StgArg] -> Type -> StgExpr
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (PrimCall -> StgOp
StgPrimCallOp (FastString -> Unit -> PrimCall
PrimCall FastString
lbl Unit
unit)) [StgArg]
stg_args Type
res_ty

      -- A regular foreign call.
      FCallId ForeignCall
call     -> Bool -> StgExpr -> StgExpr
forall a. HasCallStack => Bool -> a -> a
assert Bool
exactly_saturated (StgExpr -> StgExpr) -> StgExpr -> StgExpr
forall a b. (a -> b) -> a -> b
$
                          StgOp -> [StgArg] -> Type -> StgExpr
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (ForeignCall -> Type -> StgOp
StgFCallOp ForeignCall
call (Id -> Type
idType Id
f)) [StgArg]
stg_args Type
res_ty

      TickBoxOpId {}   -> String -> SDoc -> StgExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"coreToStg TickBox" (SDoc -> StgExpr) -> SDoc -> StgExpr
forall a b. (a -> b) -> a -> b
$ (Id, [StgArg]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id
f,[StgArg]
stg_args)

      IdDetails
_other           -> Id -> [StgArg] -> StgExpr
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
f [StgArg]
stg_args
  where
    -- 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 :: Int
f_arity    = Id -> HowBound -> Int
stgArity Id
f HowBound
how_bound
    n_val_args :: Int
n_val_args = [StgArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StgArg]
stg_args  -- StgArgs are all value arguments
    exactly_saturated :: Bool
exactly_saturated  = Int
f_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n_val_args


-- 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 Type
ty : [CoreArg]
args) | Type -> Bool
isRuntimeRepKindedTy Type
ty
  = HasDebugCallStack => SDoc -> Type -> [PrimRep]
SDoc -> Type -> [PrimRep]
runtimeRepPrimRep (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sumPrimReps") Type
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
Id -> StgArg
StgVarArg Literal -> StgArg
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 Type
_ : [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 -> Type
CoreArg -> Type
exprType CoreArg
arg
        ticks' = (CoreTickish -> StgTickish) -> [CoreTickish] -> [StgTickish]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> CoreTickish -> StgTickish
coreToStgTick Type
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 => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
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)

    -- Yikes!  This assert FAILS in tests T13658, T14779b
    -- It has been so for ages, but without the "() <-" it was lazily dropped
    -- Hence commenting it out: see #27132
    --    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 :: Type -> CoreTickish -> StgTickish
coreToStgTick Type
_ty (HpcTick Module
m Int
i)           = Module -> Int -> StgTickish
forall (pass :: TickishPass). Module -> Int -> GenTickish pass
HpcTick Module
m Int
i
coreToStgTick Type
_ty (SourceNote RealSrcSpan
span LexicalFastString
nm)    = RealSrcSpan -> LexicalFastString -> StgTickish
forall (pass :: TickishPass).
RealSrcSpan -> LexicalFastString -> GenTickish pass
SourceNote RealSrcSpan
span LexicalFastString
nm
coreToStgTick Type
_ty (ProfNote CostCentre
cc Bool
cnt Bool
scope) = CostCentre -> Bool -> Bool -> StgTickish
forall (pass :: TickishPass).
CostCentre -> Bool -> Bool -> GenTickish pass
ProfNote CostCentre
cc Bool
cnt Bool
scope
coreToStgTick !Type
ty (Breakpoint XBreakpoint 'TickishPassCore
_ BreakpointId
bid [XTickishId 'TickishPassCore]
fvs)  = XBreakpoint 'TickishPassStg
-> BreakpointId -> [XTickishId 'TickishPassStg] -> StgTickish
forall (pass :: TickishPass).
XBreakpoint pass
-> BreakpointId -> [XTickishId pass] -> GenTickish pass
Breakpoint Type
XBreakpoint 'TickishPassStg
ty BreakpointId
bid [XTickishId 'TickishPassCore]
[XTickishId 'TickishPassStg]
fvs

-- ---------------------------------------------------------------------------
-- 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 => Id -> CoreArg -> CtsM MkStgRhs
Id -> CoreArg -> CtsM MkStgRhs
coreToMkStgRhs Id
bndr CoreArg
rhs
    return (mkStgRhs bndr new_rhs)

-- Convert the RHS of a binding from Core to STG. This is a wrapper around
-- coreToStgExpr that can handle value lambdas.
coreToMkStgRhs :: HasDebugCallStack => Id -> CoreExpr -> CtsM MkStgRhs
coreToMkStgRhs :: HasDebugCallStack => Id -> CoreArg -> CtsM MkStgRhs
coreToMkStgRhs Id
bndr CoreArg
expr = do
  let ([Id]
bndrs, CoreArg
body) = JoinPointHood -> CoreArg -> ([Id], CoreArg)
myCollectBinders (Id -> JoinPointHood
idJoinPointHood Id
bndr) CoreArg
expr
  [(Id, HowBound)] -> CtsM MkStgRhs -> CtsM MkStgRhs
forall a. [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [ (Id
a, HowBound
LambdaBound) | Id
a <- [Id]
bndrs ] (CtsM MkStgRhs -> CtsM MkStgRhs) -> CtsM MkStgRhs -> CtsM MkStgRhs
forall a b. (a -> b) -> a -> b
$ do
    body' <- HasDebugCallStack => CoreArg -> CtsM StgExpr
CoreArg -> CtsM StgExpr
coreToStgExpr CoreArg
body
    let mk_rhs = MkStgRhs
          { rhs_args :: [Id]
rhs_args = [Id]
bndrs
          , rhs_expr :: StgExpr
rhs_expr = StgExpr
body'
          , rhs_type :: Type
rhs_type = HasDebugCallStack => CoreArg -> Type
CoreArg -> Type
exprType CoreArg
body
          , rhs_is_join :: Bool
rhs_is_join = Id -> Bool
isJoinId Id
bndr
          }
    pure mk_rhs

-- ---------------------------------------------------------------------------
-- 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 -> UniqSM a
unCtsM :: Platform -- Needed for checking for bad coercions in coreToStgArgs
             -> IdEnv HowBound
             -> UniqSM 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 :: CoreToStgOpts -> UniqSupply -> CtsM a -> a
initCts :: forall a. CoreToStgOpts -> UniqSupply -> CtsM a -> a
initCts CoreToStgOpts
opts UniqSupply
us CtsM a
cts_m
  = UniqSupply -> UniqSM a -> a
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (UniqSM a -> a) -> UniqSM a -> a
forall a b. (a -> b) -> a -> b
$
    CtsM a -> Platform -> IdEnv HowBound -> UniqSM a
forall a. CtsM a -> Platform -> IdEnv HowBound -> UniqSM a
unCtsM CtsM a
cts_m (CoreToStgOpts -> Platform
coreToStg_platform CoreToStgOpts
opts) IdEnv HowBound
forall a. VarEnv a
emptyVarEnv


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

returnCts :: a -> CtsM a
returnCts :: forall a. a -> CtsM a
returnCts a
e = (Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
(Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
forall a. (Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a)
-> (Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
forall a b. (a -> b) -> a -> b
$ \Platform
_ IdEnv HowBound
_ -> a -> UniqSM a
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> UniqSM b) -> CtsM b
(Platform -> IdEnv HowBound -> UniqSM b) -> CtsM b
forall a. (Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> UniqSM b) -> CtsM b)
-> (Platform -> IdEnv HowBound -> UniqSM b) -> CtsM b
forall a b. (a -> b) -> a -> b
$ \Platform
platform IdEnv HowBound
env ->
              do { v <- CtsM a -> Platform -> IdEnv HowBound -> UniqSM a
forall a. CtsM a -> Platform -> IdEnv HowBound -> UniqSM a
unCtsM CtsM a
m Platform
platform IdEnv HowBound
env
                 ; unCtsM (k v) platform 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 -> UniqSM Platform) -> CtsM Platform
(Platform -> IdEnv HowBound -> UniqSM Platform) -> CtsM Platform
forall a. (Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> UniqSM Platform) -> CtsM Platform)
-> (Platform -> IdEnv HowBound -> UniqSM Platform) -> CtsM Platform
forall a b. (a -> b) -> a -> b
$ \Platform
platform IdEnv HowBound
_ -> Platform -> UniqSM Platform
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return Platform
platform

-- Functions specific to this monad:

setCtsEnv :: IdEnv HowBound -> CtsM a -> CtsM a
setCtsEnv :: forall a. IdEnv HowBound -> CtsM a -> CtsM a
setCtsEnv IdEnv HowBound
env CtsM a
thing = (Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
(Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
forall a. (Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a)
-> (Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
forall a b. (a -> b) -> a -> b
$ \Platform
platform IdEnv HowBound
_ -> CtsM a -> Platform -> IdEnv HowBound -> UniqSM a
forall a. CtsM a -> Platform -> IdEnv HowBound -> UniqSM a
unCtsM CtsM a
thing Platform
platform IdEnv HowBound
env

getCtsEnv :: CtsM (IdEnv HowBound)
getCtsEnv :: CtsM (IdEnv HowBound)
getCtsEnv = (Platform -> IdEnv HowBound -> UniqSM (IdEnv HowBound))
-> CtsM (IdEnv HowBound)
(Platform -> IdEnv HowBound -> UniqSM (IdEnv HowBound))
-> CtsM (IdEnv HowBound)
forall a. (Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> UniqSM (IdEnv HowBound))
 -> CtsM (IdEnv HowBound))
-> (Platform -> IdEnv HowBound -> UniqSM (IdEnv HowBound))
-> CtsM (IdEnv HowBound)
forall a b. (a -> b) -> a -> b
$ \Platform
_ IdEnv HowBound
env -> IdEnv HowBound -> UniqSM (IdEnv HowBound)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return IdEnv HowBound
env

getCtsUnique :: CtsM Unique
getCtsUnique :: CtsM Unique
getCtsUnique = (Platform -> IdEnv HowBound -> UniqSM Unique) -> CtsM Unique
(Platform -> IdEnv HowBound -> UniqSM Unique) -> CtsM Unique
forall a. (Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> UniqSM Unique) -> CtsM Unique)
-> (Platform -> IdEnv HowBound -> UniqSM Unique) -> CtsM Unique
forall a b. (a -> b) -> a -> b
$ \Platform
_ IdEnv HowBound
_ -> UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM

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 -> UniqSM a) -> CtsM a
(Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
forall a. (Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a)
-> (Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
forall a b. (a -> b) -> a -> b
$   \Platform
platform IdEnv HowBound
env
   -> CtsM a -> Platform -> IdEnv HowBound -> UniqSM a
forall a. CtsM a -> Platform -> IdEnv HowBound -> UniqSM 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 -> UniqSM HowBound) -> CtsM HowBound
(Platform -> IdEnv HowBound -> UniqSM HowBound) -> CtsM HowBound
forall a. (Platform -> IdEnv HowBound -> UniqSM a) -> CtsM a
CtsM ((Platform -> IdEnv HowBound -> UniqSM HowBound) -> CtsM HowBound)
-> (Platform -> IdEnv HowBound -> UniqSM HowBound) -> CtsM HowBound
forall a b. (a -> b) -> a -> b
$ \Platform
_ IdEnv HowBound
env -> HowBound -> UniqSM HowBound
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (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

-- 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 :: JoinPointHood -> Expr Var -> ([Var], Expr Var)
-- Collect the binders from a lambda:
--   * Dropping type lambdas
--   * Stopping at join-point arity
myCollectBinders :: JoinPointHood -> CoreArg -> ([Id], CoreArg)
myCollectBinders JoinPointHood
NotJoinPoint CoreArg
expr
  = [Id] -> CoreArg -> ([Id], CoreArg)
go [] CoreArg
expr
  where
    go :: [Id] -> CoreArg -> ([Id], CoreArg)
go [Id]
bs (Lam Id
b CoreArg
e) | Id -> Bool
isRuntimeVar Id
b = [Id] -> CoreArg -> ([Id], CoreArg)
go (Id
bId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bs) CoreArg
e
                    | Bool
otherwise      = [Id] -> CoreArg -> ([Id], CoreArg)
go [Id]
bs     CoreArg
e
    go [Id]
bs (Cast CoreArg
e Coercion
_)                 = [Id] -> CoreArg -> ([Id], CoreArg)
go [Id]
bs CoreArg
e
    go [Id]
bs CoreArg
e                          = ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bs, CoreArg
e)

myCollectBinders (JoinPoint Int
n) CoreArg
expr
  = Int -> [Id] -> CoreArg -> ([Id], CoreArg)
forall {t}.
(Eq t, Num t) =>
t -> [Id] -> CoreArg -> ([Id], CoreArg)
go Int
n [] CoreArg
expr
  where
    go :: t -> [Id] -> CoreArg -> ([Id], CoreArg)
go t
n [Id]
bs CoreArg
e | t
nt -> t -> Bool
forall a. Eq a => a -> a -> Bool
==t
0                   = ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bs, CoreArg
e)
    go t
n [Id]
bs (Lam Id
b CoreArg
e) | Id -> Bool
isRuntimeVar Id
b = t -> [Id] -> CoreArg -> ([Id], CoreArg)
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) (Id
bId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bs) CoreArg
e
                      | Bool
otherwise      = t -> [Id] -> CoreArg -> ([Id], CoreArg)
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) [Id]
bs     CoreArg
e
    go t
n [Id]
bs (Cast CoreArg
e Coercion
_)                 = t -> [Id] -> CoreArg -> ([Id], CoreArg)
go t
n [Id]
bs CoreArg
e
    go t
_ [Id]
bs CoreArg
e                          = ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
bs, CoreArg
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 -> Type -> (CoreExpr, [CoreArg], [StgTickish])
myCollectArgs :: HasDebugCallStack =>
CoreArg -> Type -> (CoreArg, [CoreArg], [StgTickish])
myCollectArgs CoreArg
expr Type
res_ty
  = CoreArg
-> [CoreArg] -> [StgTickish] -> (CoreArg, [CoreArg], [StgTickish])
go CoreArg
expr [] []
  where
    go :: CoreArg
-> [CoreArg] -> [StgTickish] -> (CoreArg, [CoreArg], [StgTickish])
go h :: CoreArg
h@(Var Id
f) [CoreArg]
as [StgTickish]
ts
      | Id -> Bool
isUnaryClassId Id
f, (CoreArg
the_arg:[CoreArg]
as') <- (CoreArg -> Bool) -> [CoreArg] -> [CoreArg]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile CoreArg -> Bool
forall b. Expr b -> Bool
isTypeArg [CoreArg]
as
      = CoreArg
-> [CoreArg] -> [StgTickish] -> (CoreArg, [CoreArg], [StgTickish])
go CoreArg
the_arg [CoreArg]
as' [StgTickish]
ts
        -- See (UCM1) in Note [Unary class magic] in GHC.Core.TyCon
        -- isUnaryClassId includes both the class op and the data-con

      | Bool
otherwise
      = (CoreArg
h, [CoreArg]
as, [StgTickish]
ts)

    go (App CoreArg
f CoreArg
a)  [CoreArg]
as [StgTickish]
ts = CoreArg
-> [CoreArg] -> [StgTickish] -> (CoreArg, [CoreArg], [StgTickish])
go CoreArg
f (CoreArg
aCoreArg -> [CoreArg] -> [CoreArg]
forall a. a -> [a] -> [a]
:[CoreArg]
as) [StgTickish]
ts
    go (Cast CoreArg
e Coercion
_) [CoreArg]
as [StgTickish]
ts = CoreArg
-> [CoreArg] -> [StgTickish] -> (CoreArg, [CoreArg], [StgTickish])
go CoreArg
e [CoreArg]
as [StgTickish]
ts
    go (Tick CoreTickish
t CoreArg
e) [CoreArg]
as [StgTickish]
ts = Bool
-> SDoc
-> (CoreArg, [CoreArg], [StgTickish])
-> (CoreArg, [CoreArg], [StgTickish])
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
$$ [StgTickish] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgTickish]
ts) ((CoreArg, [CoreArg], [StgTickish])
 -> (CoreArg, [CoreArg], [StgTickish]))
-> (CoreArg, [CoreArg], [StgTickish])
-> (CoreArg, [CoreArg], [StgTickish])
forall a b. (a -> b) -> a -> b
$
                          -- See Note [Ticks in applications]
                          -- ticks can appear in type apps
                          CoreArg
-> [CoreArg] -> [StgTickish] -> (CoreArg, [CoreArg], [StgTickish])
go CoreArg
e [CoreArg]
as (Type -> CoreTickish -> StgTickish
coreToStgTick Type
res_ty CoreTickish
t StgTickish -> [StgTickish] -> [StgTickish]
forall a. a -> [a] -> [a]
: [StgTickish]
ts)

    go (Case CoreArg
e Id
b Type
_ [Alt Id]
alts) [CoreArg]
as [StgTickish]
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], [StgTickish])
-> (CoreArg, [CoreArg], [StgTickish])
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], [StgTickish])
 -> (CoreArg, [CoreArg], [StgTickish]))
-> (CoreArg, [CoreArg], [StgTickish])
-> (CoreArg, [CoreArg], [StgTickish])
forall a b. (a -> b) -> a -> b
$
                   CoreArg
-> [CoreArg] -> [StgTickish] -> (CoreArg, [CoreArg], [StgTickish])
go CoreArg
e [] [StgTickish]
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] -> [StgTickish] -> (CoreArg, [CoreArg], [StgTickish])
go CoreArg
rhs [CoreArg]
as [StgTickish]
ts         -- Discards unsafeCoerce in App heads

    go (Lam Id
b CoreArg
e) [CoreArg]
as [StgTickish]
ts
       | Id -> Bool
isTyVar Id
b
       = CoreArg
-> [CoreArg] -> [StgTickish] -> (CoreArg, [CoreArg], [StgTickish])
go CoreArg
e (Int -> [CoreArg] -> [CoreArg]
forall a. Int -> [a] -> [a]
drop Int
1 [CoreArg]
as) [StgTickish]
ts -- Note [Collect args]

    go CoreArg
e [CoreArg]
as [StgTickish]
ts = (CoreArg
e, [CoreArg]
as, [StgTickish]
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
  }