Module hierarchy (#13009): Stg

1 files changed, 939 insertions, 0 deletions

diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
new file mode 100644
index 0000000000..1ee5febd2e
--- /dev/null
+++ b/compiler/GHC/CoreToStg.hs
@@ -0,0 +1,939 @@
+{-# LANGUAGE CPP, DeriveFunctor #-}
+
+--
+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+--
+
+--------------------------------------------------------------
+-- Converting Core to STG Syntax
+--------------------------------------------------------------
+
+-- And, as we have the info in hand, we may convert some lets to
+-- let-no-escapes.
+
+module GHC.CoreToStg ( coreToStg ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn
+import CoreUtils        ( exprType, findDefault, isJoinBind
+                        , exprIsTickedString_maybe )
+import CoreArity        ( manifestArity )
+import GHC.Stg.Syntax
+
+import Type
+import GHC.Types.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 (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 dflags this_mod pgm
+  = (pgm', final_ccs)
+  where
+    (_, (local_ccs, local_cc_stacks), pgm')
+      = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm
+
+    prof = WayProf `elem` ways dflags
+
+    final_ccs
+      | prof && gopt Opt_AutoSccsOnIndividualCafs dflags
+      = (local_ccs,local_cc_stacks)  -- don't need "all CAFs" CC
+      | prof
+      = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)
+      | otherwise
+      = emptyCollectedCCs
+
+    (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod
+
+coreTopBindsToStg
+    :: DynFlags
+    -> Module
+    -> IdEnv HowBound           -- environment for the bindings
+    -> CollectedCCs
+    -> CoreProgram
+    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
+
+coreTopBindsToStg _      _        env ccs []
+  = (env, ccs, [])
+coreTopBindsToStg dflags this_mod env ccs (b:bs)
+  = (env2, ccs2, b':bs')
+  where
+        (env1, ccs1, b' ) =
+          coreTopBindToStg dflags this_mod env ccs b
+        (env2, ccs2, bs') =
+          coreTopBindsToStg dflags this_mod env1 ccs1 bs
+
+coreTopBindToStg
+        :: DynFlags
+        -> Module
+        -> IdEnv HowBound
+        -> CollectedCCs
+        -> CoreBind
+        -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
+
+coreTopBindToStg _ _ env ccs (NonRec id e)
+  | Just str <- exprIsTickedString_maybe e
+  -- top-level string literal
+  -- See Note [CoreSyn top-level string literals] in CoreSyn
+  = let
+        env' = extendVarEnv env id how_bound
+        how_bound = LetBound TopLet 0
+    in (env', ccs, StgTopStringLit id str)
+
+coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
+  = let
+        env'      = extendVarEnv env id how_bound
+        how_bound = LetBound TopLet $! manifestArity rhs
+
+        (stg_rhs, ccs') =
+            initCts dflags env $
+              coreToTopStgRhs dflags ccs this_mod (id,rhs)
+
+        bind = StgTopLifted $ StgNonRec id stg_rhs
+    in
+    assertConsistentCafInfo dflags id bind (ppr 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!
+    (env', ccs', bind)
+
+coreTopBindToStg dflags this_mod env ccs (Rec pairs)
+  = ASSERT( not (null pairs) )
+    let
+        binders = map fst pairs
+
+        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
+                     | (b, rhs) <- pairs ]
+        env' = extendVarEnvList env extra_env'
+
+        -- generate StgTopBindings and CAF cost centres created for CAFs
+        (ccs', stg_rhss)
+          = initCts dflags env' $ do
+               mapAccumLM (\ccs rhs -> do
+                            (rhs', ccs') <-
+                              coreToTopStgRhs dflags ccs this_mod rhs
+                            return (ccs', rhs'))
+                          ccs
+                          pairs
+
+        bind = StgTopLifted $ StgRec (zip binders stg_rhss)
+    in
+    assertConsistentCafInfo dflags (head binders) bind (ppr binders)
+    (env', ccs', 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.
+assertConsistentCafInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a
+assertConsistentCafInfo dflags id bind err_doc result
+  | gopt Opt_DoStgLinting dflags || debugIsOn
+  , not $ consistentCafInfo id bind = pprPanic "assertConsistentCafInfo" err_doc
+  | otherwise = 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 id bind
+  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
+    safe
+  where
+    safe  = id_marked_caffy || not binding_is_caffy
+    exact = id_marked_caffy == binding_is_caffy
+    id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
+    binding_is_caffy = topStgBindHasCafRefs bind
+    is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
+
+coreToTopStgRhs
+        :: DynFlags
+        -> CollectedCCs
+        -> Module
+        -> (Id,CoreExpr)
+        -> CtsM (StgRhs, CollectedCCs)
+
+coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
+  = do { new_rhs <- coreToStgExpr rhs
+
+       ; let (stg_rhs, ccs') =
+               mkTopStgRhs dflags this_mod ccs bndr new_rhs
+             stg_arity =
+               stgRhsArity stg_rhs
+
+       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
+                 ccs') }
+  where
+        -- It's vital that the arity on a top-level Id matches
+        -- the arity of the generated STG binding, else an importing
+        -- module will use the wrong calling convention
+        --      (#2844 was an example where this happened)
+        -- NB1: we can't move the assertion further out without
+        --      blocking the "knot" tied in coreTopBindsToStg
+        -- NB2: the arity check is only needed for Ids with External
+        --      Names, because they are externally visible.  The CorePrep
+        --      pass introduces "sat" things with Local Names and does
+        --      not bother to set their Arity info, so don't fail for those
+    arity_ok stg_arity
+       | isExternalName (idName bndr) = id_arity == stg_arity
+       | otherwise                    = True
+    id_arity  = idArity bndr
+    mk_arity_msg stg_arity
+        = vcat [ppr bndr,
+                text "Id arity:" <+> ppr id_arity,
+                text "STG arity:" <+> ppr 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 (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger"
+coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural"
+coreToStgExpr (Lit l)      = return (StgLit l)
+coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type)
+  -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in
+  -- a STG to Cmm pass.
+  = coreToStgExpr (Var unitDataConId)
+coreToStgExpr (Var v)      = coreToStgApp v               [] []
+coreToStgExpr (Coercion _) = coreToStgApp coercionTokenId [] []
+
+coreToStgExpr expr@(App _ _)
+  = coreToStgApp f args ticks
+  where
+    (f, args, ticks) = myCollectArgs expr
+
+coreToStgExpr expr@(Lam _ _)
+  = let
+        (args, body) = myCollectBinders expr
+        args'        = filterStgBinders args
+    in
+    extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
+    body' <- coreToStgExpr body
+    let
+        result_expr = case nonEmpty args' of
+          Nothing     -> body'
+          Just args'' -> StgLam args'' body'
+
+    return result_expr
+
+coreToStgExpr (Tick tick expr)
+  = do case tick of
+         HpcTick{}    -> return ()
+         ProfNote{}   -> return ()
+         SourceNote{} -> return ()
+         Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
+       expr2 <- coreToStgExpr expr
+       return (StgTick tick expr2)
+
+coreToStgExpr (Cast expr _)
+  = coreToStgExpr expr
+
+-- Cases require a little more real work.
+
+coreToStgExpr (Case scrut _ _ [])
+  = coreToStgExpr 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 bndr _ alts) = do
+    alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
+    scrut2 <- coreToStgExpr scrut
+    return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2)
+  where
+    vars_alt (con, binders, rhs)
+      | DataAlt c <- con, c == 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 { rhs2 <- coreToStgExpr rhs
+           ; return (DEFAULT, [], rhs2)  }
+      | otherwise
+      = let     -- Remove type variables
+            binders' = filterStgBinders binders
+        in
+        extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do
+        rhs2 <- coreToStgExpr rhs
+        return (con, binders', rhs2)
+
+coreToStgExpr (Let bind body) = do
+    coreToStgLet bind body
+
+coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
+
+mkStgAltType :: Id -> [CoreAlt] -> AltType
+mkStgAltType bndr alts
+  | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty
+  = MultiValAlt (length prim_reps)  -- always use MultiValAlt for unboxed tuples
+
+  | otherwise
+  = case prim_reps of
+      [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of
+        Just tc
+          | isAbstractTyCon tc -> look_for_better_tycon
+          | isAlgTyCon tc      -> AlgAlt tc
+          | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
+                                  PolyAlt
+        Nothing                -> PolyAlt
+      [unlifted] -> PrimAlt unlifted
+      not_unary  -> MultiValAlt (length not_unary)
+  where
+   bndr_ty   = idType bndr
+   prim_reps = typePrimRep bndr_ty
+
+   _is_poly_alt_tycon tc
+        =  isFunTyCon tc
+        || isPrimTyCon tc   -- "Any" is lifted but primitive
+        || isFamilyTyCon 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
+        | ((DataAlt con, _, _) : _) <- data_alts =
+                AlgAlt (dataConTyCon con)
+        | otherwise =
+                ASSERT(null data_alts)
+                PolyAlt
+        where
+                (data_alts, _deflt) = findDefault alts
+
+-- ---------------------------------------------------------------------------
+-- Applications
+-- ---------------------------------------------------------------------------
+
+coreToStgApp :: Id            -- Function
+             -> [CoreArg]     -- Arguments
+             -> [Tickish Id]  -- Debug ticks
+             -> CtsM StgExpr
+coreToStgApp f args ticks = do
+    (args', ticks') <- coreToStgArgs args
+    how_bound <- lookupVarCts f
+
+    let
+        n_val_args       = valArgCount 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   = stgArity f how_bound
+        saturated = f_arity <= n_val_args
+
+        res_ty = exprType (mkApps (Var f) args)
+        app = case idDetails f of
+                DataConWorkId dc
+                  | saturated    -> StgConApp dc args'
+                                      (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe 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
+                  | saturated    -> StgOpApp (StgPrimOp op) args' res_ty
+                  | otherwise    -> StgApp (primOpWrapperId op) args'
+
+                -- A call to some primitive Cmm function.
+                FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
+                                          PrimCallConv _))
+                                 -> ASSERT( saturated )
+                                    StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
+
+                -- A regular foreign call.
+                FCallId call     -> ASSERT( saturated )
+                                    StgOpApp (StgFCallOp call (idType f)) args' res_ty
+
+                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
+                _other           -> StgApp f args'
+
+        tapp = foldr StgTick app (ticks ++ ticks')
+
+    -- Forcing these fixes a leak in the code generator, noticed while
+    -- profiling for trac #4367
+    app `seq` return tapp
+
+-- ---------------------------------------------------------------------------
+-- Argument lists
+-- This is the guy that turns applications into A-normal form
+-- ---------------------------------------------------------------------------
+
+coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])
+coreToStgArgs []
+  = return ([], [])
+
+coreToStgArgs (Type _ : args) = do     -- Type argument
+    (args', ts) <- coreToStgArgs args
+    return (args', ts)
+
+coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
+  = do { (args', ts) <- coreToStgArgs args
+       ; return (StgVarArg coercionTokenId : args', ts) }
+
+coreToStgArgs (Tick t e : args)
+  = ASSERT( not (tickishIsCode t) )
+    do { (args', ts) <- coreToStgArgs (e : args)
+       ; return (args', t:ts) }
+
+coreToStgArgs (arg : args) = do         -- Non-type argument
+    (stg_args, ticks) <- coreToStgArgs args
+    arg' <- coreToStgExpr arg
+    let
+        (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
+        stg_arg = case arg'' of
+                       StgApp v []        -> StgVarArg v
+                       StgConApp con [] _ -> StgVarArg (dataConWorkId con)
+                       StgLit lit         -> StgLitArg lit
+                       _                  -> pprPanic "coreToStgArgs" (ppr 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
+
+    dflags <- getDynFlags
+    let
+        arg_rep = typePrimRep (exprType arg)
+        stg_arg_rep = typePrimRep (stgArgType stg_arg)
+        bad_args = not (primRepsCompatible dflags arg_rep stg_arg_rep)
+
+    WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
+     return (stg_arg : stg_args, ticks ++ aticks)
+
+
+-- ---------------------------------------------------------------------------
+-- The magic for lets:
+-- ---------------------------------------------------------------------------
+
+coreToStgLet
+         :: CoreBind     -- bindings
+         -> CoreExpr     -- body
+         -> CtsM StgExpr -- new let
+
+coreToStgLet bind body = do
+    (bind2, body2)
+       <- do
+
+          ( bind2, env_ext)
+                <- vars_bind bind
+
+          -- Do the body
+          extendVarEnvCts env_ext $ do
+             body2 <- coreToStgExpr body
+
+             return (bind2, body2)
+
+        -- Compute the new let-expression
+    let
+        new_let | isJoinBind bind = StgLetNoEscape noExtFieldSilent bind2 body2
+                | otherwise       = StgLet noExtFieldSilent bind2 body2
+
+    return new_let
+  where
+    mk_binding binder rhs
+        = (binder, LetBound NestedLet (manifestArity rhs))
+
+    vars_bind :: CoreBind
+              -> CtsM (StgBinding,
+                       [(Id, HowBound)])  -- extension to environment
+
+    vars_bind (NonRec binder rhs) = do
+        rhs2 <- coreToStgRhs (binder,rhs)
+        let
+            env_ext_item = mk_binding binder rhs
+
+        return (StgNonRec binder rhs2, [env_ext_item])
+
+    vars_bind (Rec pairs)
+      =    let
+                binders = map fst pairs
+                env_ext = [ mk_binding b rhs
+                          | (b,rhs) <- pairs ]
+           in
+           extendVarEnvCts env_ext $ do
+              rhss2 <- mapM coreToStgRhs pairs
+              return (StgRec (binders `zip` rhss2), env_ext)
+
+coreToStgRhs :: (Id,CoreExpr)
+             -> CtsM StgRhs
+
+coreToStgRhs (bndr, rhs) = do
+    new_rhs <- coreToStgExpr rhs
+    return (mkStgRhs bndr 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 dflags this_mod ccs bndr rhs
+  | StgLam bndrs body <- rhs
+  = -- StgLam can't have empty arguments, so not CAF
+    ( StgRhsClosure noExtFieldSilent
+                    dontCareCCS
+                    ReEntrant
+                    (toList bndrs) body
+    , ccs )
+
+  | StgConApp con args _ <- unticked_rhs
+  , -- Dynamic StgConApps are updatable
+    not (isDllConApp dflags this_mod con args)
+  = -- CorePrep does this right, but just to make sure
+    ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)
+           , ppr bndr $$ ppr con $$ ppr args)
+    ( StgRhsCon dontCareCCS con args, ccs )
+
+  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
+  | gopt Opt_AutoSccsOnIndividualCafs dflags
+  = ( StgRhsClosure noExtFieldSilent
+                    caf_ccs
+                    upd_flag [] rhs
+    , collectCC caf_cc caf_ccs ccs )
+
+  | otherwise
+  = ( StgRhsClosure noExtFieldSilent
+                    all_cafs_ccs
+                    upd_flag [] rhs
+    , ccs )
+
+  where
+    unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs
+
+    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
+             | otherwise                      = Updatable
+
+    -- CAF cost centres generated for -fcaf-all
+    caf_cc = mkAutoCC bndr modl
+    caf_ccs = mkSingletonCCS caf_cc
+           -- careful: the binder might be :Main.main,
+           -- which doesn't belong to module mod_name.
+           -- bug #249, tests prof001, prof002
+    modl | Just m <- nameModule_maybe (idName bndr) = m
+         | otherwise = this_mod
+
+    -- default CAF cost centre
+    (_, all_cafs_ccs) = getAllCAFsCC this_mod
+
+-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
+-- see Note [Cost-centre initialzation plan].
+mkStgRhs :: Id -> StgExpr -> StgRhs
+mkStgRhs bndr rhs
+  | StgLam bndrs body <- rhs
+  = StgRhsClosure noExtFieldSilent
+                  currentCCS
+                  ReEntrant
+                  (toList bndrs) body
+
+  | isJoinId bndr -- must be a nullary join point
+  = ASSERT(idJoinArity bndr == 0)
+    StgRhsClosure noExtFieldSilent
+                  currentCCS
+                  ReEntrant -- ignored for LNE
+                  [] rhs
+
+  | StgConApp con args _ <- unticked_rhs
+  = StgRhsCon currentCCS con args
+
+  | otherwise
+  = StgRhsClosure noExtFieldSilent
+                  currentCCS
+                  upd_flag [] rhs
+  where
+    unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs
+
+    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
+             | otherwise                      = 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
+    { unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs
+             -> IdEnv HowBound
+             -> a
+    }
+    deriving (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 (Eq)
+
+data LetInfo
+  = TopLet              -- top level things
+  | NestedLet
+  deriving (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 :: DynFlags -> IdEnv HowBound -> CtsM a -> a
+initCts dflags env m = unCtsM m dflags env
+
+
+
+{-# INLINE thenCts #-}
+{-# INLINE returnCts #-}
+
+returnCts :: a -> CtsM a
+returnCts e = CtsM $ \_ _ -> e
+
+thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
+thenCts m k = CtsM $ \dflags env
+  -> unCtsM (k (unCtsM m dflags env)) dflags env
+
+instance Applicative CtsM where
+    pure = returnCts
+    (<*>) = ap
+
+instance Monad CtsM where
+    (>>=)  = thenCts
+
+instance HasDynFlags CtsM where
+    getDynFlags = CtsM $ \dflags _ -> dflags
+
+-- Functions specific to this monad:
+
+extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
+extendVarEnvCts ids_w_howbound expr
+   =    CtsM $   \dflags env
+   -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound)
+
+lookupVarCts :: Id -> CtsM HowBound
+lookupVarCts v = CtsM $ \_ env -> lookupBinding env v
+
+lookupBinding :: IdEnv HowBound -> Id -> HowBound
+lookupBinding env v = case lookupVarEnv env v of
+                        Just xx -> xx
+                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
+
+getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
+getAllCAFsCC this_mod =
+    let
+      span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
+      all_cafs_cc  = mkAllCafsCC this_mod span
+      all_cafs_ccs = mkSingletonCCS all_cafs_cc
+    in
+      (all_cafs_cc, all_cafs_ccs)
+
+-- Misc.
+
+filterStgBinders :: [Var] -> [Var]
+filterStgBinders bndrs = filter isId bndrs
+
+myCollectBinders :: Expr Var -> ([Var], Expr Var)
+myCollectBinders expr
+  = go [] expr
+  where
+    go bs (Lam b e)          = go (b:bs) e
+    go bs (Cast e _)         = go bs e
+    go bs e                  = (reverse bs, 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
+  = go expr [] []
+  where
+    go (Var v)          as ts = (v, as, ts)
+    go (App f a)        as ts = go f (a:as) ts
+    go (Tick t e)       as ts = ASSERT( all isTypeArg as )
+                                go e as (t:ts) -- ticks can appear in type apps
+    go (Cast e _)       as ts = go e as ts
+    go (Lam b e)        as ts
+       | isTyVar b            = go e as ts -- Note [Collect args]
+    go _                _  _  = pprPanic "CoreToStg.myCollectArgs" (ppr 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 _ (LetBound _ arity) = arity
+stgArity f ImportBound        = idArity f
+stgArity _ LambdaBound        = 0