{-# LANGUAGE CPP #-}

--
-- (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 CoreToStg ( coreToStg ) where

#include "HsVersions.h"

import GhcPrelude

import CoreSyn
import CoreUtils        ( exprType, findDefault, isJoinBind
                        , exprIsTickedString_maybe )
import CoreArity        ( manifestArity )
import StgSyn

import Type
import RepType
import TyCon
import MkId             ( coercionTokenId )
import Id
import IdInfo
import DataCon
import CostCentre
import VarEnv
import Module
import Name             ( isExternalName, nameOccName, nameModule_maybe )
import OccName          ( occNameFS )
import BasicTypes       ( Arity )
import TysWiredIn       ( unboxedUnitDataCon, unitDataConId )
import Literal
import Outputable
import MonadUtils
import FastString
import Util
import DynFlags
import ForeignCall
import Demand           ( isUsedOnce )
import PrimOp           ( PrimCall(..), primOpWrapperId )
import SrcLoc           ( mkGeneralSrcSpan )

import Data.List.NonEmpty (nonEmpty, toList)
import Data.Maybe    (fromMaybe)
import Control.Monad (liftM, 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.

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

coreToStg :: DynFlags -> Module -> CoreProgram
          -> ([StgTopBinding], CollectedCCs)
coreToStg :: DynFlags
-> Module -> CoreProgram -> ([StgTopBinding], CollectedCCs)
coreToStg dflags :: DynFlags
dflags this_mod :: Module
this_mod pgm :: CoreProgram
pgm
  = ([StgTopBinding]
pgm', CollectedCCs
final_ccs)
  where
    (_, (local_ccs :: [CostCentre]
local_ccs, local_cc_stacks :: [CostCentreStack]
local_cc_stacks), pgm' :: [StgTopBinding]
pgm')
      = DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg DynFlags
dflags Module
this_mod IdEnv HowBound
forall a. VarEnv a
emptyVarEnv CollectedCCs
emptyCollectedCCs CoreProgram
pgm

    prof :: Bool
prof = Way
WayProf Way -> [Way] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> [Way]
ways DynFlags
dflags

    final_ccs :: CollectedCCs
final_ccs
      | Bool
prof Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AutoSccsOnIndividualCafs DynFlags
dflags
      = ([CostCentre]
local_ccs,[CostCentreStack]
local_cc_stacks)  -- don't need "all CAFs" CC
      | Bool
prof
      = (CostCentre
all_cafs_ccCostCentre -> [CostCentre] -> [CostCentre]
forall a. a -> [a] -> [a]
:[CostCentre]
local_ccs, CostCentreStack
all_cafs_ccsCostCentreStack -> [CostCentreStack] -> [CostCentreStack]
forall a. a -> [a] -> [a]
:[CostCentreStack]
local_cc_stacks)
      | Bool
otherwise
      = CollectedCCs
emptyCollectedCCs

    (all_cafs_cc :: CostCentre
all_cafs_cc, all_cafs_ccs :: CostCentreStack
all_cafs_ccs) = Module -> (CostCentre, CostCentreStack)
getAllCAFsCC Module
this_mod

coreTopBindsToStg
    :: DynFlags
    -> Module
    -> IdEnv HowBound           -- environment for the bindings
    -> CollectedCCs
    -> CoreProgram
    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])

coreTopBindsToStg :: DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg _      _        env :: IdEnv HowBound
env ccs :: CollectedCCs
ccs []
  = (IdEnv HowBound
env, CollectedCCs
ccs, [])
coreTopBindsToStg dflags :: DynFlags
dflags this_mod :: Module
this_mod env :: IdEnv HowBound
env ccs :: CollectedCCs
ccs (b :: CoreBind
b:bs :: CoreProgram
bs)
  = (IdEnv HowBound
env2, CollectedCCs
ccs2, StgTopBinding
b'StgTopBinding -> [StgTopBinding] -> [StgTopBinding]
forall a. a -> [a] -> [a]
:[StgTopBinding]
bs')
  where
        (env1 :: IdEnv HowBound
env1, ccs1 :: CollectedCCs
ccs1, b' :: StgTopBinding
b' ) =
          DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreBind
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env CollectedCCs
ccs CoreBind
b
        (env2 :: IdEnv HowBound
env2, ccs2 :: CollectedCCs
ccs2, bs' :: [StgTopBinding]
bs') =
          DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreProgram
-> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
coreTopBindsToStg DynFlags
dflags Module
this_mod IdEnv HowBound
env1 CollectedCCs
ccs1 CoreProgram
bs

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

coreTopBindToStg :: DynFlags
-> Module
-> IdEnv HowBound
-> CollectedCCs
-> CoreBind
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
coreTopBindToStg _ _ env :: IdEnv HowBound
env ccs :: CollectedCCs
ccs (NonRec id :: CoreBndr
id e :: Expr CoreBndr
e)
  | Just str :: ByteString
str <- Expr CoreBndr -> Maybe ByteString
exprIsTickedString_maybe Expr CoreBndr
e
  -- top-level string literal
  -- See Note [CoreSyn top-level string literals] in CoreSyn
  = let
        env' :: IdEnv HowBound
env' = IdEnv HowBound -> CoreBndr -> HowBound -> IdEnv HowBound
forall a. VarEnv a -> CoreBndr -> a -> VarEnv a
extendVarEnv IdEnv HowBound
env CoreBndr
id HowBound
how_bound
        how_bound :: HowBound
how_bound = LetInfo -> Arity -> HowBound
LetBound LetInfo
TopLet 0
    in (IdEnv HowBound
env', CollectedCCs
ccs, CoreBndr -> ByteString -> StgTopBinding
forall (pass :: StgPass).
CoreBndr -> ByteString -> GenStgTopBinding pass
StgTopStringLit CoreBndr
id ByteString
str)

coreTopBindToStg dflags :: DynFlags
dflags this_mod :: Module
this_mod env :: IdEnv HowBound
env ccs :: CollectedCCs
ccs (NonRec id :: CoreBndr
id rhs :: Expr CoreBndr
rhs)
  = let
        env' :: IdEnv HowBound
env'      = IdEnv HowBound -> CoreBndr -> HowBound -> IdEnv HowBound
forall a. VarEnv a -> CoreBndr -> a -> VarEnv a
extendVarEnv IdEnv HowBound
env CoreBndr
id HowBound
how_bound
        how_bound :: HowBound
how_bound = LetInfo -> Arity -> HowBound
LetBound LetInfo
TopLet (Arity -> HowBound) -> Arity -> HowBound
forall a b. (a -> b) -> a -> b
$! Expr CoreBndr -> Arity
manifestArity Expr CoreBndr
rhs

        (stg_rhs :: StgRhs
stg_rhs, ccs' :: CollectedCCs
ccs') =
            IdEnv HowBound
-> CtsM (StgRhs, CollectedCCs) -> (StgRhs, CollectedCCs)
forall a. IdEnv HowBound -> CtsM a -> a
initCts IdEnv HowBound
env (CtsM (StgRhs, CollectedCCs) -> (StgRhs, CollectedCCs))
-> CtsM (StgRhs, CollectedCCs) -> (StgRhs, CollectedCCs)
forall a b. (a -> b) -> a -> b
$
              DynFlags
-> CollectedCCs
-> Module
-> (CoreBndr, Expr CoreBndr)
-> CtsM (StgRhs, CollectedCCs)
coreToTopStgRhs DynFlags
dflags CollectedCCs
ccs Module
this_mod (CoreBndr
id,Expr CoreBndr
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 CoreBndr
BinderP 'Vanilla
id StgRhs
stg_rhs
    in
    DynFlags
-> CoreBndr
-> StgTopBinding
-> SDoc
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
forall a. DynFlags -> CoreBndr -> StgTopBinding -> SDoc -> a -> a
assertConsistentCaInfo DynFlags
dflags CoreBndr
id StgTopBinding
bind (StgTopBinding -> SDoc
forall a. Outputable a => a -> SDoc
ppr StgTopBinding
bind)
      -- 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 dflags :: DynFlags
dflags this_mod :: Module
this_mod env :: IdEnv HowBound
env ccs :: CollectedCCs
ccs (Rec pairs :: [(CoreBndr, Expr CoreBndr)]
pairs)
  = ASSERT( not (null pairs) )
    let
        binders :: [CoreBndr]
binders = ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, Expr CoreBndr)]
pairs

        extra_env' :: [(CoreBndr, HowBound)]
extra_env' = [ (CoreBndr
b, LetInfo -> Arity -> HowBound
LetBound LetInfo
TopLet (Arity -> HowBound) -> Arity -> HowBound
forall a b. (a -> b) -> a -> b
$! Expr CoreBndr -> Arity
manifestArity Expr CoreBndr
rhs)
                     | (b :: CoreBndr
b, rhs :: Expr CoreBndr
rhs) <- [(CoreBndr, Expr CoreBndr)]
pairs ]
        env' :: IdEnv HowBound
env' = IdEnv HowBound -> [(CoreBndr, HowBound)] -> IdEnv HowBound
forall a. VarEnv a -> [(CoreBndr, a)] -> VarEnv a
extendVarEnvList IdEnv HowBound
env [(CoreBndr, HowBound)]
extra_env'

        -- generate StgTopBindings and CAF cost centres created for CAFs
        (ccs' :: CollectedCCs
ccs', stg_rhss :: [StgRhs]
stg_rhss)
          = IdEnv HowBound
-> CtsM (CollectedCCs, [StgRhs]) -> (CollectedCCs, [StgRhs])
forall a. IdEnv HowBound -> CtsM a -> a
initCts IdEnv HowBound
env' (CtsM (CollectedCCs, [StgRhs]) -> (CollectedCCs, [StgRhs]))
-> CtsM (CollectedCCs, [StgRhs]) -> (CollectedCCs, [StgRhs])
forall a b. (a -> b) -> a -> b
$ do
               (CollectedCCs
 -> (CoreBndr, Expr CoreBndr) -> CtsM (CollectedCCs, StgRhs))
-> CollectedCCs
-> [(CoreBndr, Expr CoreBndr)]
-> CtsM (CollectedCCs, [StgRhs])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (\ccs :: CollectedCCs
ccs rhs :: (CoreBndr, Expr CoreBndr)
rhs -> do
                            (rhs' :: StgRhs
rhs', ccs' :: CollectedCCs
ccs') <-
                              DynFlags
-> CollectedCCs
-> Module
-> (CoreBndr, Expr CoreBndr)
-> CtsM (StgRhs, CollectedCCs)
coreToTopStgRhs DynFlags
dflags CollectedCCs
ccs Module
this_mod (CoreBndr, Expr CoreBndr)
rhs
                            (CollectedCCs, StgRhs) -> CtsM (CollectedCCs, StgRhs)
forall (m :: * -> *) a. Monad m => a -> m a
return (CollectedCCs
ccs', StgRhs
rhs'))
                          CollectedCCs
ccs
                          [(CoreBndr, Expr CoreBndr)]
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 ([CoreBndr] -> [StgRhs] -> [(CoreBndr, StgRhs)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CoreBndr]
binders [StgRhs]
stg_rhss)
    in
    DynFlags
-> CoreBndr
-> StgTopBinding
-> SDoc
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
-> (IdEnv HowBound, CollectedCCs, StgTopBinding)
forall a. DynFlags -> CoreBndr -> StgTopBinding -> SDoc -> a -> a
assertConsistentCaInfo DynFlags
dflags ([CoreBndr] -> CoreBndr
forall a. [a] -> a
head [CoreBndr]
binders) StgTopBinding
bind ([CoreBndr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreBndr]
binders)
    (IdEnv HowBound
env', CollectedCCs
ccs', StgTopBinding
bind)

-- | CAF consistency issues will generally result in segfaults and are quite
-- difficult to debug (see #16846). We enable checking of the
-- 'consistentCafInfo' invariant with @-dstg-lint@ to increase the chance that
-- we catch these issues.
assertConsistentCaInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a
assertConsistentCaInfo :: DynFlags -> CoreBndr -> StgTopBinding -> SDoc -> a -> a
assertConsistentCaInfo dflags :: DynFlags
dflags id :: CoreBndr
id bind :: StgTopBinding
bind err_doc :: SDoc
err_doc result :: a
result
  | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoStgLinting DynFlags
dflags Bool -> Bool -> Bool
|| Bool
debugIsOn
  , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CoreBndr -> StgTopBinding -> Bool
consistentCafInfo CoreBndr
id StgTopBinding
bind = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic "assertConsistentCaInfo" SDoc
err_doc
  | Bool
otherwise = a
result

-- Assertion helper: this checks that the CafInfo on the Id matches
-- what CoreToStg has figured out about the binding's SRT.  The
-- CafInfo will be exact in all cases except when CorePrep has
-- floated out a binding, in which case it will be approximate.
consistentCafInfo :: Id -> StgTopBinding -> Bool
consistentCafInfo :: CoreBndr -> StgTopBinding -> Bool
consistentCafInfo id :: CoreBndr
id bind :: StgTopBinding
bind
  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
    Bool
safe
  where
    safe :: Bool
safe  = Bool
id_marked_caffy Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
binding_is_caffy
    exact :: Bool
exact = Bool
id_marked_caffy Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
binding_is_caffy
    id_marked_caffy :: Bool
id_marked_caffy  = CafInfo -> Bool
mayHaveCafRefs (CoreBndr -> CafInfo
idCafInfo CoreBndr
id)
    binding_is_caffy :: Bool
binding_is_caffy = StgTopBinding -> Bool
forall (pass :: StgPass). GenStgTopBinding pass -> Bool
topStgBindHasCafRefs StgTopBinding
bind
    is_sat_thing :: Bool
is_sat_thing = OccName -> FastString
occNameFS (Name -> OccName
nameOccName (CoreBndr -> Name
idName CoreBndr
id)) FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> FastString
fsLit "sat"

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

coreToTopStgRhs :: DynFlags
-> CollectedCCs
-> Module
-> (CoreBndr, Expr CoreBndr)
-> CtsM (StgRhs, CollectedCCs)
coreToTopStgRhs dflags :: DynFlags
dflags ccs :: CollectedCCs
ccs this_mod :: Module
this_mod (bndr :: CoreBndr
bndr, rhs :: Expr CoreBndr
rhs)
  = do { StgExpr
new_rhs <- Expr CoreBndr -> CtsM StgExpr
coreToStgExpr Expr CoreBndr
rhs

       ; let (stg_rhs :: StgRhs
stg_rhs, ccs' :: CollectedCCs
ccs') =
               DynFlags
-> Module
-> CollectedCCs
-> CoreBndr
-> StgExpr
-> (StgRhs, CollectedCCs)
mkTopStgRhs DynFlags
dflags Module
this_mod CollectedCCs
ccs CoreBndr
bndr StgExpr
new_rhs
             stg_arity :: Arity
stg_arity =
               StgRhs -> Arity
stgRhsArity StgRhs
stg_rhs

       ; (StgRhs, CollectedCCs) -> CtsM (StgRhs, CollectedCCs)
forall (m :: * -> *) a. Monad m => a -> m a
return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
                 CollectedCCs
ccs') }
  where
        -- It's vital that the arity on a top-level Id matches
        -- the arity of the generated STG binding, else an importing
        -- module will use the wrong calling convention
        --      (Trac #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 :: Arity -> Bool
arity_ok stg_arity :: Arity
stg_arity
       | Name -> Bool
isExternalName (CoreBndr -> Name
idName CoreBndr
bndr) = Arity
id_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
stg_arity
       | Bool
otherwise                    = Bool
True
    id_arity :: Arity
id_arity  = CoreBndr -> Arity
idArity CoreBndr
bndr
    mk_arity_msg :: a -> SDoc
mk_arity_msg stg_arity :: a
stg_arity
        = [SDoc] -> SDoc
vcat [CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
bndr,
                String -> SDoc
text "Id arity:" SDoc -> SDoc -> SDoc
<+> Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
id_arity,
                String -> SDoc
text "STG arity:" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
stg_arity]

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

coreToStgExpr
        :: CoreExpr
        -> CtsM StgExpr

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

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

coreToStgExpr expr :: Expr CoreBndr
expr@(App _ _)
  = Maybe UpdateFlag
-> CoreBndr
-> [Expr CoreBndr]
-> [Tickish CoreBndr]
-> CtsM StgExpr
coreToStgApp Maybe UpdateFlag
forall a. Maybe a
Nothing CoreBndr
f [Expr CoreBndr]
args [Tickish CoreBndr]
ticks
  where
    (f :: CoreBndr
f, args :: [Expr CoreBndr]
args, ticks :: [Tickish CoreBndr]
ticks) = Expr CoreBndr -> (CoreBndr, [Expr CoreBndr], [Tickish CoreBndr])
myCollectArgs Expr CoreBndr
expr

coreToStgExpr expr :: Expr CoreBndr
expr@(Lam _ _)
  = let
        (args :: [CoreBndr]
args, body :: Expr CoreBndr
body) = Expr CoreBndr -> ([CoreBndr], Expr CoreBndr)
myCollectBinders Expr CoreBndr
expr
        args' :: [CoreBndr]
args'        = [CoreBndr] -> [CoreBndr]
filterStgBinders [CoreBndr]
args
    in
    [(CoreBndr, HowBound)] -> CtsM StgExpr -> CtsM StgExpr
forall a. [(CoreBndr, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [ (CoreBndr
a, HowBound
LambdaBound) | CoreBndr
a <- [CoreBndr]
args' ] (CtsM StgExpr -> CtsM StgExpr) -> CtsM StgExpr -> CtsM StgExpr
forall a b. (a -> b) -> a -> b
$ do
    StgExpr
body' <- Expr CoreBndr -> CtsM StgExpr
coreToStgExpr Expr CoreBndr
body
    let
        result_expr :: StgExpr
result_expr = case [CoreBndr] -> Maybe (NonEmpty CoreBndr)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [CoreBndr]
args' of
          Nothing     -> StgExpr
body'
          Just args'' :: NonEmpty CoreBndr
args'' -> NonEmpty (BinderP 'Vanilla) -> StgExpr -> StgExpr
forall (pass :: StgPass).
NonEmpty (BinderP pass) -> StgExpr -> GenStgExpr pass
StgLam NonEmpty CoreBndr
NonEmpty (BinderP 'Vanilla)
args'' StgExpr
body'

    StgExpr -> CtsM StgExpr
forall (m :: * -> *) a. Monad m => a -> m a
return StgExpr
result_expr

coreToStgExpr (Tick tick :: Tickish CoreBndr
tick expr :: Expr CoreBndr
expr)
  = do case Tickish CoreBndr
tick of
         HpcTick{}    -> () -> CtsM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         ProfNote{}   -> () -> CtsM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         SourceNote{} -> () -> CtsM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         Breakpoint{} -> String -> CtsM ()
forall a. String -> a
panic "coreToStgExpr: breakpoint should not happen"
       StgExpr
expr2 <- Expr CoreBndr -> CtsM StgExpr
coreToStgExpr Expr CoreBndr
expr
       StgExpr -> CtsM StgExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Tickish CoreBndr -> StgExpr -> StgExpr
forall (pass :: StgPass).
Tickish CoreBndr -> GenStgExpr pass -> GenStgExpr pass
StgTick Tickish CoreBndr
tick StgExpr
expr2)

coreToStgExpr (Cast expr :: Expr CoreBndr
expr _)
  = Expr CoreBndr -> CtsM StgExpr
coreToStgExpr Expr CoreBndr
expr

-- Cases require a little more real work.

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


coreToStgExpr (Case scrut :: Expr CoreBndr
scrut bndr :: CoreBndr
bndr _ alts :: [Alt CoreBndr]
alts) = do
    [(AltCon, [CoreBndr], StgExpr)]
alts2 <- [(CoreBndr, HowBound)]
-> CtsM [(AltCon, [CoreBndr], StgExpr)]
-> CtsM [(AltCon, [CoreBndr], StgExpr)]
forall a. [(CoreBndr, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(CoreBndr
bndr, HowBound
LambdaBound)] ((Alt CoreBndr -> CtsM (AltCon, [CoreBndr], StgExpr))
-> [Alt CoreBndr] -> CtsM [(AltCon, [CoreBndr], StgExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt CoreBndr -> CtsM (AltCon, [CoreBndr], StgExpr)
vars_alt [Alt CoreBndr]
alts)
    StgExpr
scrut2 <- Expr CoreBndr -> CtsM StgExpr
coreToStgExpr Expr CoreBndr
scrut
    StgExpr -> CtsM StgExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (StgExpr
-> BinderP 'Vanilla -> AltType -> [GenStgAlt 'Vanilla] -> StgExpr
forall (pass :: StgPass).
GenStgExpr pass
-> BinderP pass -> AltType -> [GenStgAlt pass] -> GenStgExpr pass
StgCase StgExpr
scrut2 CoreBndr
BinderP 'Vanilla
bndr (CoreBndr -> [Alt CoreBndr] -> AltType
mkStgAltType CoreBndr
bndr [Alt CoreBndr]
alts) [(AltCon, [CoreBndr], StgExpr)]
[GenStgAlt 'Vanilla]
alts2)
  where
    vars_alt :: Alt CoreBndr -> CtsM (AltCon, [CoreBndr], StgExpr)
vars_alt (con :: AltCon
con, binders :: [CoreBndr]
binders, rhs :: Expr CoreBndr
rhs)
      | DataAlt c :: DataCon
c <- AltCon
con, DataCon
c DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
unboxedUnitDataCon
      = -- This case is a bit smelly.
        -- See Note [Nullary unboxed tuple] in Type.hs
        -- where a nullary tuple is mapped to (State# World#)
        ASSERT( null binders )
        do { StgExpr
rhs2 <- Expr CoreBndr -> CtsM StgExpr
coreToStgExpr Expr CoreBndr
rhs
           ; (AltCon, [CoreBndr], StgExpr) -> CtsM (AltCon, [CoreBndr], StgExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon
DEFAULT, [], StgExpr
rhs2)  }
      | Bool
otherwise
      = let     -- Remove type variables
            binders' :: [CoreBndr]
binders' = [CoreBndr] -> [CoreBndr]
filterStgBinders [CoreBndr]
binders
        in
        [(CoreBndr, HowBound)]
-> CtsM (AltCon, [CoreBndr], StgExpr)
-> CtsM (AltCon, [CoreBndr], StgExpr)
forall a. [(CoreBndr, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(CoreBndr
b, HowBound
LambdaBound) | CoreBndr
b <- [CoreBndr]
binders'] (CtsM (AltCon, [CoreBndr], StgExpr)
 -> CtsM (AltCon, [CoreBndr], StgExpr))
-> CtsM (AltCon, [CoreBndr], StgExpr)
-> CtsM (AltCon, [CoreBndr], StgExpr)
forall a b. (a -> b) -> a -> b
$ do
        StgExpr
rhs2 <- Expr CoreBndr -> CtsM StgExpr
coreToStgExpr Expr CoreBndr
rhs
        (AltCon, [CoreBndr], StgExpr) -> CtsM (AltCon, [CoreBndr], StgExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon
con, [CoreBndr]
binders', StgExpr
rhs2)

coreToStgExpr (Let bind :: CoreBind
bind body :: Expr CoreBndr
body) = do
    CoreBind -> Expr CoreBndr -> CtsM StgExpr
coreToStgLet CoreBind
bind Expr CoreBndr
body

coreToStgExpr e :: Expr CoreBndr
e = String -> SDoc -> CtsM StgExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic "coreToStgExpr" (Expr CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr CoreBndr
e)

mkStgAltType :: Id -> [CoreAlt] -> AltType
mkStgAltType :: CoreBndr -> [Alt CoreBndr] -> AltType
mkStgAltType bndr :: CoreBndr
bndr alts :: [Alt CoreBndr]
alts
  | Type -> Bool
isUnboxedTupleType Type
bndr_ty Bool -> Bool -> Bool
|| Type -> Bool
isUnboxedSumType Type
bndr_ty
  = Arity -> AltType
MultiValAlt ([PrimRep] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [PrimRep]
prim_reps)  -- always use MultiValAlt for unboxed tuples

  | Bool
otherwise
  = case [PrimRep]
prim_reps of
      [LiftedRep] -> case Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
unwrapType Type
bndr_ty) of
        Just tc :: TyCon
tc
          | TyCon -> Bool
isAbstractTyCon TyCon
tc -> AltType
look_for_better_tycon
          | TyCon -> Bool
isAlgTyCon TyCon
tc      -> TyCon -> AltType
AlgAlt TyCon
tc
          | Bool
otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
                                  AltType
PolyAlt
        Nothing                -> AltType
PolyAlt
      [unlifted :: PrimRep
unlifted] -> PrimRep -> AltType
PrimAlt PrimRep
unlifted
      not_unary :: [PrimRep]
not_unary  -> Arity -> AltType
MultiValAlt ([PrimRep] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [PrimRep]
not_unary)
  where
   bndr_ty :: Type
bndr_ty   = CoreBndr -> Type
idType CoreBndr
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 tc :: TyCon
tc
        =  TyCon -> Bool
isFunTyCon TyCon
tc
        Bool -> Bool -> Bool
|| TyCon -> Bool
isPrimTyCon TyCon
tc   -- "Any" is lifted but primitive
        Bool -> Bool -> Bool
|| TyCon -> Bool
isFamilyTyCon TyCon
tc -- Type family; e.g. Any, or arising from strict
                            -- function application where argument has a
                            -- type-family type

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

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

coreToStgApp
         :: Maybe UpdateFlag            -- Just upd <=> this application is
                                        -- the rhs of a thunk binding
                                        --      x = [...] \upd [] -> the_app
                                        -- with specified update flag
        -> Id                           -- Function
        -> [CoreArg]                    -- Arguments
        -> [Tickish Id]                 -- Debug ticks
        -> CtsM StgExpr


coreToStgApp :: Maybe UpdateFlag
-> CoreBndr
-> [Expr CoreBndr]
-> [Tickish CoreBndr]
-> CtsM StgExpr
coreToStgApp _ f :: CoreBndr
f args :: [Expr CoreBndr]
args ticks :: [Tickish CoreBndr]
ticks = do
    (args' :: [StgArg]
args', ticks' :: [Tickish CoreBndr]
ticks') <- [Expr CoreBndr] -> CtsM ([StgArg], [Tickish CoreBndr])
coreToStgArgs [Expr CoreBndr]
args
    HowBound
how_bound <- CoreBndr -> CtsM HowBound
lookupVarCts CoreBndr
f

    let
        n_val_args :: Arity
n_val_args       = [Expr CoreBndr] -> Arity
forall b. [Arg b] -> Arity
valArgCount [Expr CoreBndr]
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 :: Arity
f_arity   = CoreBndr -> HowBound -> Arity
stgArity CoreBndr
f HowBound
how_bound
        saturated :: Bool
saturated = Arity
f_arity Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
<= Arity
n_val_args

        res_ty :: Type
res_ty = Expr CoreBndr -> Type
exprType (Expr CoreBndr -> [Expr CoreBndr] -> Expr CoreBndr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreBndr -> Expr CoreBndr
forall b. CoreBndr -> Expr b
Var CoreBndr
f) [Expr CoreBndr]
args)
        app :: GenStgExpr pass
app = case CoreBndr -> IdDetails
idDetails CoreBndr
f of
                DataConWorkId dc :: DataCon
dc
                  | Bool
saturated    -> DataCon -> [StgArg] -> [Type] -> GenStgExpr pass
forall (pass :: StgPass).
DataCon -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
dc [StgArg]
args'
                                      ([Type] -> [Type]
dropRuntimeRepArgs ([Type] -> Maybe [Type] -> [Type]
forall a. a -> Maybe a -> a
fromMaybe [] (Type -> Maybe [Type]
tyConAppArgs_maybe Type
res_ty)))

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

                -- A call to some primitive Cmm function.
                FCallId (CCall (CCallSpec (StaticTarget _ lbl :: FastString
lbl (Just pkgId :: UnitId
pkgId) True)
                                          PrimCallConv _))
                                 -> ASSERT( saturated )
                                    StgOp -> [StgArg] -> Type -> GenStgExpr pass
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (PrimCall -> StgOp
StgPrimCallOp (FastString -> UnitId -> PrimCall
PrimCall FastString
lbl UnitId
pkgId)) [StgArg]
args' Type
res_ty

                -- A regular foreign call.
                FCallId call :: ForeignCall
call     -> ASSERT( saturated )
                                    StgOp -> [StgArg] -> Type -> GenStgExpr pass
forall (pass :: StgPass).
StgOp -> [StgArg] -> Type -> GenStgExpr pass
StgOpApp (ForeignCall -> Unique -> StgOp
StgFCallOp ForeignCall
call (CoreBndr -> Unique
idUnique CoreBndr
f)) [StgArg]
args' Type
res_ty

                TickBoxOpId {}   -> String -> SDoc -> GenStgExpr pass
forall a. HasCallStack => String -> SDoc -> a
pprPanic "coreToStg TickBox" (SDoc -> GenStgExpr pass) -> SDoc -> GenStgExpr pass
forall a b. (a -> b) -> a -> b
$ (CoreBndr, [StgArg]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CoreBndr
f,[StgArg]
args')
                _other :: IdDetails
_other           -> CoreBndr -> [StgArg] -> GenStgExpr pass
forall (pass :: StgPass). CoreBndr -> [StgArg] -> GenStgExpr pass
StgApp CoreBndr
f [StgArg]
args'

        tapp :: GenStgExpr pass
tapp = (Tickish CoreBndr -> GenStgExpr pass -> GenStgExpr pass)
-> GenStgExpr pass -> [Tickish CoreBndr] -> GenStgExpr pass
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tickish CoreBndr -> GenStgExpr pass -> GenStgExpr pass
forall (pass :: StgPass).
Tickish CoreBndr -> GenStgExpr pass -> GenStgExpr pass
StgTick GenStgExpr pass
forall (pass :: StgPass). GenStgExpr pass
app ([Tickish CoreBndr]
ticks [Tickish CoreBndr] -> [Tickish CoreBndr] -> [Tickish CoreBndr]
forall a. [a] -> [a] -> [a]
++ [Tickish CoreBndr]
ticks')

    -- Forcing these fixes a leak in the code generator, noticed while
    -- profiling for trac #4367
    GenStgExpr Any
forall (pass :: StgPass). GenStgExpr pass
app GenStgExpr Any -> CtsM StgExpr -> CtsM StgExpr
forall a b. a -> b -> b
`seq` StgExpr -> CtsM StgExpr
forall (m :: * -> *) a. Monad m => a -> m a
return StgExpr
forall (pass :: StgPass). GenStgExpr pass
tapp

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

coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])
coreToStgArgs :: [Expr CoreBndr] -> CtsM ([StgArg], [Tickish CoreBndr])
coreToStgArgs []
  = ([StgArg], [Tickish CoreBndr])
-> CtsM ([StgArg], [Tickish CoreBndr])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])

coreToStgArgs (Type _ : args :: [Expr CoreBndr]
args) = do     -- Type argument
    (args' :: [StgArg]
args', ts :: [Tickish CoreBndr]
ts) <- [Expr CoreBndr] -> CtsM ([StgArg], [Tickish CoreBndr])
coreToStgArgs [Expr CoreBndr]
args
    ([StgArg], [Tickish CoreBndr])
-> CtsM ([StgArg], [Tickish CoreBndr])
forall (m :: * -> *) a. Monad m => a -> m a
return ([StgArg]
args', [Tickish CoreBndr]
ts)

coreToStgArgs (Coercion _ : args :: [Expr CoreBndr]
args)  -- Coercion argument; replace with place holder
  = do { (args' :: [StgArg]
args', ts :: [Tickish CoreBndr]
ts) <- [Expr CoreBndr] -> CtsM ([StgArg], [Tickish CoreBndr])
coreToStgArgs [Expr CoreBndr]
args
       ; ([StgArg], [Tickish CoreBndr])
-> CtsM ([StgArg], [Tickish CoreBndr])
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> StgArg
StgVarArg CoreBndr
coercionTokenId StgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
: [StgArg]
args', [Tickish CoreBndr]
ts) }

coreToStgArgs (Tick t :: Tickish CoreBndr
t e :: Expr CoreBndr
e : args :: [Expr CoreBndr]
args)
  = ASSERT( not (tickishIsCode t) )
    do { (args' :: [StgArg]
args', ts :: [Tickish CoreBndr]
ts) <- [Expr CoreBndr] -> CtsM ([StgArg], [Tickish CoreBndr])
coreToStgArgs (Expr CoreBndr
e Expr CoreBndr -> [Expr CoreBndr] -> [Expr CoreBndr]
forall a. a -> [a] -> [a]
: [Expr CoreBndr]
args)
       ; ([StgArg], [Tickish CoreBndr])
-> CtsM ([StgArg], [Tickish CoreBndr])
forall (m :: * -> *) a. Monad m => a -> m a
return ([StgArg]
args', Tickish CoreBndr
tTickish CoreBndr -> [Tickish CoreBndr] -> [Tickish CoreBndr]
forall a. a -> [a] -> [a]
:[Tickish CoreBndr]
ts) }

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

        -- WARNING: what if we have an argument like (v `cast` co)
        --          where 'co' changes the representation type?
        --          (This really only happens if co is unsafe.)
        -- Then all the getArgAmode stuff in CgBindery will set the
        -- cg_rep of the CgIdInfo based on the type of v, rather
        -- than the type of 'co'.
        -- This matters particularly when the function is a primop
        -- or foreign call.
        -- Wanted: a better solution than this hacky warning
    let
        arg_ty :: Type
arg_ty = Expr CoreBndr -> Type
exprType Expr CoreBndr
arg
        stg_arg_ty :: Type
stg_arg_ty = StgArg -> Type
stgArgType StgArg
stg_arg
        bad_args :: Bool
bad_args = (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
arg_ty Bool -> Bool -> Bool
&& Bool -> Bool
not (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
stg_arg_ty))
                Bool -> Bool -> Bool
|| (HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
arg_ty [PrimRep] -> [PrimRep] -> Bool
forall a. Eq a => a -> a -> Bool
/= HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
stg_arg_ty)
        -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
        -- and pass it to a function expecting an HValue (arg_ty).  This is ok because
        -- we can treat an unlifted value as lifted.  But the other way round
        -- we complain.
        -- We also want to check if a pointer is cast to a non-ptr etc

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


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

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

coreToStgLet :: CoreBind -> Expr CoreBndr -> CtsM StgExpr
coreToStgLet bind :: CoreBind
bind body :: Expr CoreBndr
body = do
    (bind2 :: GenStgBinding 'Vanilla
bind2, body2 :: StgExpr
body2)
       <- do

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

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

             (GenStgBinding 'Vanilla, StgExpr)
-> CtsM (GenStgBinding 'Vanilla, StgExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (GenStgBinding 'Vanilla
bind2, StgExpr
body2)

        -- Compute the new let-expression
    let
        new_let :: StgExpr
new_let | CoreBind -> Bool
isJoinBind CoreBind
bind = XLetNoEscape 'Vanilla
-> GenStgBinding 'Vanilla -> StgExpr -> StgExpr
forall (pass :: StgPass).
XLetNoEscape pass
-> GenStgBinding pass -> GenStgExpr pass -> GenStgExpr pass
StgLetNoEscape XLetNoEscape 'Vanilla
NoExtSilent
noExtSilent 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
NoExtSilent
noExtSilent GenStgBinding 'Vanilla
bind2 StgExpr
body2

    StgExpr -> CtsM StgExpr
forall (m :: * -> *) a. Monad m => a -> m a
return StgExpr
new_let
  where
    mk_binding :: a -> Expr CoreBndr -> (a, HowBound)
mk_binding binder :: a
binder rhs :: Expr CoreBndr
rhs
        = (a
binder, LetInfo -> Arity -> HowBound
LetBound LetInfo
NestedLet (Expr CoreBndr -> Arity
manifestArity Expr CoreBndr
rhs))

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

    vars_bind :: CoreBind -> CtsM (GenStgBinding 'Vanilla, [(CoreBndr, HowBound)])
vars_bind (NonRec binder :: CoreBndr
binder rhs :: Expr CoreBndr
rhs) = do
        StgRhs
rhs2 <- (CoreBndr, Expr CoreBndr) -> CtsM StgRhs
coreToStgRhs (CoreBndr
binder,Expr CoreBndr
rhs)
        let
            env_ext_item :: (CoreBndr, HowBound)
env_ext_item = CoreBndr -> Expr CoreBndr -> (CoreBndr, HowBound)
forall a. a -> Expr CoreBndr -> (a, HowBound)
mk_binding CoreBndr
binder Expr CoreBndr
rhs

        (GenStgBinding 'Vanilla, [(CoreBndr, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(CoreBndr, HowBound)])
forall (m :: * -> *) a. Monad m => a -> m a
return (BinderP 'Vanilla -> StgRhs -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
BinderP pass -> GenStgRhs pass -> GenStgBinding pass
StgNonRec CoreBndr
BinderP 'Vanilla
binder StgRhs
rhs2, [(CoreBndr, HowBound)
env_ext_item])

    vars_bind (Rec pairs :: [(CoreBndr, Expr CoreBndr)]
pairs)
      =    let
                binders :: [CoreBndr]
binders = ((CoreBndr, Expr CoreBndr) -> CoreBndr)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Expr CoreBndr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, Expr CoreBndr)]
pairs
                env_ext :: [(CoreBndr, HowBound)]
env_ext = [ CoreBndr -> Expr CoreBndr -> (CoreBndr, HowBound)
forall a. a -> Expr CoreBndr -> (a, HowBound)
mk_binding CoreBndr
b Expr CoreBndr
rhs
                          | (b :: CoreBndr
b,rhs :: Expr CoreBndr
rhs) <- [(CoreBndr, Expr CoreBndr)]
pairs ]
           in
           [(CoreBndr, HowBound)]
-> CtsM (GenStgBinding 'Vanilla, [(CoreBndr, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(CoreBndr, HowBound)])
forall a. [(CoreBndr, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts [(CoreBndr, HowBound)]
env_ext (CtsM (GenStgBinding 'Vanilla, [(CoreBndr, HowBound)])
 -> CtsM (GenStgBinding 'Vanilla, [(CoreBndr, HowBound)]))
-> CtsM (GenStgBinding 'Vanilla, [(CoreBndr, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(CoreBndr, HowBound)])
forall a b. (a -> b) -> a -> b
$ do
              [StgRhs]
rhss2 <- ((CoreBndr, Expr CoreBndr) -> CtsM StgRhs)
-> [(CoreBndr, Expr CoreBndr)] -> CtsM [StgRhs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CoreBndr, Expr CoreBndr) -> CtsM StgRhs
coreToStgRhs [(CoreBndr, Expr CoreBndr)]
pairs
              (GenStgBinding 'Vanilla, [(CoreBndr, HowBound)])
-> CtsM (GenStgBinding 'Vanilla, [(CoreBndr, HowBound)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(BinderP 'Vanilla, StgRhs)] -> GenStgBinding 'Vanilla
forall (pass :: StgPass).
[(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
StgRec ([CoreBndr]
binders [CoreBndr] -> [StgRhs] -> [(CoreBndr, StgRhs)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [StgRhs]
rhss2), [(CoreBndr, HowBound)]
env_ext)

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

coreToStgRhs :: (CoreBndr, Expr CoreBndr) -> CtsM StgRhs
coreToStgRhs (bndr :: CoreBndr
bndr, rhs :: Expr CoreBndr
rhs) = do
    StgExpr
new_rhs <- Expr CoreBndr -> CtsM StgExpr
coreToStgExpr Expr CoreBndr
rhs
    StgRhs -> CtsM StgRhs
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> StgExpr -> StgRhs
mkStgRhs CoreBndr
bndr StgExpr
new_rhs)

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

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

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

  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
  | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AutoSccsOnIndividualCafs DynFlags
dflags
  = ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtSilent
noExtSilent
                    CostCentreStack
caf_ccs
                    UpdateFlag
upd_flag [] StgExpr
rhs
    , CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
collectCC CostCentre
caf_cc CostCentreStack
caf_ccs CollectedCCs
ccs )

  | Bool
otherwise
  = ( XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtSilent
noExtSilent
                    CostCentreStack
all_cafs_ccs
                    UpdateFlag
upd_flag [] StgExpr
rhs
    , CollectedCCs
ccs )

  where
    (_, unticked_rhs :: StgExpr
unticked_rhs) = (Tickish CoreBndr -> Bool)
-> StgExpr -> ([Tickish CoreBndr], StgExpr)
forall (p :: StgPass).
(Tickish CoreBndr -> Bool)
-> GenStgExpr p -> ([Tickish CoreBndr], GenStgExpr p)
stripStgTicksTop (Bool -> Bool
not (Bool -> Bool)
-> (Tickish CoreBndr -> Bool) -> Tickish CoreBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tickish CoreBndr -> Bool
forall id. Tickish id -> Bool
tickishIsCode) StgExpr
rhs

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

    -- CAF cost centres generated for -fcaf-all
    caf_cc :: CostCentre
caf_cc = CoreBndr -> Module -> CostCentre
mkAutoCC CoreBndr
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 m :: Module
m <- Name -> Maybe Module
nameModule_maybe (CoreBndr -> Name
idName CoreBndr
bndr) = Module
m
         | Bool
otherwise = Module
this_mod

    -- default CAF cost centre
    (_, all_cafs_ccs :: 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 initialzation plan].
mkStgRhs :: Id -> StgExpr -> StgRhs
mkStgRhs :: CoreBndr -> StgExpr -> StgRhs
mkStgRhs bndr :: CoreBndr
bndr rhs :: StgExpr
rhs
  | StgLam bndrs :: NonEmpty (BinderP 'Vanilla)
bndrs body :: StgExpr
body <- StgExpr
rhs
  = XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtSilent
noExtSilent
                  CostCentreStack
currentCCS
                  UpdateFlag
ReEntrant
                  (NonEmpty CoreBndr -> [CoreBndr]
forall a. NonEmpty a -> [a]
toList NonEmpty CoreBndr
NonEmpty (BinderP 'Vanilla)
bndrs) StgExpr
body

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

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

  | Bool
otherwise
  = XRhsClosure 'Vanilla
-> CostCentreStack
-> UpdateFlag
-> [BinderP 'Vanilla]
-> StgExpr
-> StgRhs
forall (pass :: StgPass).
XRhsClosure pass
-> CostCentreStack
-> UpdateFlag
-> [BinderP pass]
-> GenStgExpr pass
-> GenStgRhs pass
StgRhsClosure XRhsClosure 'Vanilla
NoExtSilent
noExtSilent
                  CostCentreStack
currentCCS
                  UpdateFlag
upd_flag [] StgExpr
rhs
  where
    (_, unticked_rhs :: StgExpr
unticked_rhs) = (Tickish CoreBndr -> Bool)
-> StgExpr -> ([Tickish CoreBndr], StgExpr)
forall (p :: StgPass).
(Tickish CoreBndr -> Bool)
-> GenStgExpr p -> ([Tickish CoreBndr], GenStgExpr p)
stripStgTicksTop (Bool -> Bool
not (Bool -> Bool)
-> (Tickish CoreBndr -> Bool) -> Tickish CoreBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tickish CoreBndr -> Bool
forall id. Tickish id -> Bool
tickishIsCode) StgExpr
rhs

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

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

    upd_flag | isPAP env rhs  = ReEntrant
             | otherwise      = Updatable

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

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

-}

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

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

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

newtype CtsM a = CtsM
    { CtsM a -> IdEnv HowBound -> a
unCtsM :: IdEnv HowBound
             -> a
    }

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

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

  | LambdaBound         -- Used for both lambda and case
  deriving (HowBound -> HowBound -> Bool
(HowBound -> HowBound -> Bool)
-> (HowBound -> HowBound -> Bool) -> Eq HowBound
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HowBound -> HowBound -> Bool
$c/= :: HowBound -> HowBound -> Bool
== :: HowBound -> HowBound -> Bool
$c== :: HowBound -> HowBound -> Bool
Eq)

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

-- For a let(rec)-bound variable, x, we record LiveInfo, the set of
-- variables that are live if x is live.  This LiveInfo comprises
--         (a) dynamic live variables (ones with a non-top-level binding)
--         (b) static live variabes (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 :: IdEnv HowBound -> CtsM a -> a
initCts :: IdEnv HowBound -> CtsM a -> a
initCts env :: IdEnv HowBound
env m :: CtsM a
m = CtsM a -> IdEnv HowBound -> a
forall a. CtsM a -> IdEnv HowBound -> a
unCtsM CtsM a
m IdEnv HowBound
env



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

returnCts :: a -> CtsM a
returnCts :: a -> CtsM a
returnCts e :: a
e = (IdEnv HowBound -> a) -> CtsM a
forall a. (IdEnv HowBound -> a) -> CtsM a
CtsM ((IdEnv HowBound -> a) -> CtsM a)
-> (IdEnv HowBound -> a) -> CtsM a
forall a b. (a -> b) -> a -> b
$ \_ -> a
e

thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
thenCts m :: CtsM a
m k :: a -> CtsM b
k = (IdEnv HowBound -> b) -> CtsM b
forall a. (IdEnv HowBound -> a) -> CtsM a
CtsM ((IdEnv HowBound -> b) -> CtsM b)
-> (IdEnv HowBound -> b) -> CtsM b
forall a b. (a -> b) -> a -> b
$ \env :: IdEnv HowBound
env
  -> CtsM b -> IdEnv HowBound -> b
forall a. CtsM a -> IdEnv HowBound -> a
unCtsM (a -> CtsM b
k (CtsM a -> IdEnv HowBound -> a
forall a. CtsM a -> IdEnv HowBound -> a
unCtsM CtsM a
m IdEnv HowBound
env)) IdEnv HowBound
env

instance Functor CtsM where
    fmap :: (a -> b) -> CtsM a -> CtsM b
fmap = (a -> b) -> CtsM a -> CtsM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative CtsM where
    pure :: a -> CtsM a
pure = a -> CtsM a
forall a. a -> CtsM a
returnCts
    <*> :: CtsM (a -> b) -> CtsM a -> CtsM b
(<*>) = CtsM (a -> b) -> CtsM a -> CtsM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad CtsM where
    >>= :: CtsM a -> (a -> CtsM b) -> CtsM b
(>>=)  = CtsM a -> (a -> CtsM b) -> CtsM b
forall a b. CtsM a -> (a -> CtsM b) -> CtsM b
thenCts

-- Functions specific to this monad:

extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts :: [(CoreBndr, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts ids_w_howbound :: [(CoreBndr, HowBound)]
ids_w_howbound expr :: CtsM a
expr
   =    (IdEnv HowBound -> a) -> CtsM a
forall a. (IdEnv HowBound -> a) -> CtsM a
CtsM ((IdEnv HowBound -> a) -> CtsM a)
-> (IdEnv HowBound -> a) -> CtsM a
forall a b. (a -> b) -> a -> b
$   \env :: IdEnv HowBound
env
   -> CtsM a -> IdEnv HowBound -> a
forall a. CtsM a -> IdEnv HowBound -> a
unCtsM CtsM a
expr (IdEnv HowBound -> [(CoreBndr, HowBound)] -> IdEnv HowBound
forall a. VarEnv a -> [(CoreBndr, a)] -> VarEnv a
extendVarEnvList IdEnv HowBound
env [(CoreBndr, HowBound)]
ids_w_howbound)

lookupVarCts :: Id -> CtsM HowBound
lookupVarCts :: CoreBndr -> CtsM HowBound
lookupVarCts v :: CoreBndr
v = (IdEnv HowBound -> HowBound) -> CtsM HowBound
forall a. (IdEnv HowBound -> a) -> CtsM a
CtsM ((IdEnv HowBound -> HowBound) -> CtsM HowBound)
-> (IdEnv HowBound -> HowBound) -> CtsM HowBound
forall a b. (a -> b) -> a -> b
$ \env :: IdEnv HowBound
env -> IdEnv HowBound -> CoreBndr -> HowBound
lookupBinding IdEnv HowBound
env CoreBndr
v

lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding :: IdEnv HowBound -> CoreBndr -> HowBound
lookupBinding env :: IdEnv HowBound
env v :: CoreBndr
v = case IdEnv HowBound -> CoreBndr -> Maybe HowBound
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv IdEnv HowBound
env CoreBndr
v of
                        Just xx :: HowBound
xx -> HowBound
xx
                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound

getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
getAllCAFsCC this_mod :: Module
this_mod =
    let
      span :: SrcSpan
span = FastString -> SrcSpan
mkGeneralSrcSpan (String -> FastString
mkFastString "<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 :: [CoreBndr] -> [CoreBndr]
filterStgBinders bndrs :: [CoreBndr]
bndrs = (CoreBndr -> Bool) -> [CoreBndr] -> [CoreBndr]
forall a. (a -> Bool) -> [a] -> [a]
filter CoreBndr -> Bool
isId [CoreBndr]
bndrs

myCollectBinders :: Expr Var -> ([Var], Expr Var)
myCollectBinders :: Expr CoreBndr -> ([CoreBndr], Expr CoreBndr)
myCollectBinders expr :: Expr CoreBndr
expr
  = [CoreBndr] -> Expr CoreBndr -> ([CoreBndr], Expr CoreBndr)
forall a. [a] -> Expr a -> ([a], Expr a)
go [] Expr CoreBndr
expr
  where
    go :: [a] -> Expr a -> ([a], Expr a)
go bs :: [a]
bs (Lam b :: a
b e :: 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 bs :: [a]
bs (Cast e :: Expr a
e _)         = [a] -> Expr a -> ([a], Expr a)
go [a]
bs Expr a
e
    go bs :: [a]
bs e :: Expr a
e                  = ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
bs, Expr a
e)

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

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

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