-----------------------------------------------------------------------------
--
-- Stg to C-- code generation: bindings
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module GHC.StgToCmm.Bind (
        cgTopRhsClosure,
        cgBind,
        emitBlackHoleCode,
        pushUpdateFrame, emitUpdateFrame
  ) where

import GHC.Prelude hiding ((<*>))

import GHC.Core          ( AltCon(..) )
import GHC.Core.Opt.Arity( isOneShotBndr )
import GHC.Runtime.Heap.Layout
import GHC.Unit.Module

import GHC.Stg.Syntax

import GHC.Platform
import GHC.Platform.Profile

import GHC.Builtin.Names (unpackCStringName, unpackCStringUtf8Name)

import GHC.StgToCmm.Config
import GHC.StgToCmm.Expr
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Env
import GHC.StgToCmm.DataCon
import GHC.StgToCmm.Heap
import GHC.StgToCmm.Prof (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
                   initUpdFrameProf)
import GHC.StgToCmm.TagCheck
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Layout
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Foreign    (emitPrimCall)

import GHC.Cmm.Graph
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Info
import GHC.Cmm.Utils
import GHC.Cmm.CLabel

import GHC.Stg.Utils
import GHC.Types.CostCentre
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Types.Tickish ( tickishIsCode )

import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic

import GHC.Data.FastString
import GHC.Data.List.SetOps

import Control.Monad

------------------------------------------------------------------------
--              Top-level bindings
------------------------------------------------------------------------

-- For closures bound at top level, allocate in static space.
-- They should have no free variables.

cgTopRhsClosure :: Platform
                -> RecFlag              -- member of a recursive group?
                -> Id
                -> CostCentreStack      -- Optional cost centre annotation
                -> UpdateFlag
                -> [Id]                 -- Args
                -> CgStgExpr
                -> (CgIdInfo, FCode ())

cgTopRhsClosure :: Platform
-> RecFlag
-> Id
-> CostCentreStack
-> UpdateFlag
-> [Id]
-> CgStgExpr
-> (CgIdInfo, FCode ())
cgTopRhsClosure Platform
platform RecFlag
rec Id
id CostCentreStack
ccs UpdateFlag
upd_flag [Id]
args CgStgExpr
body =
  let closure_label :: CLabel
closure_label = Name -> CafInfo -> CLabel
mkClosureLabel (Id -> Name
idName Id
id) (Id -> CafInfo
idCafInfo Id
id)
      cg_id_info :: CgIdInfo
cg_id_info    = Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo Platform
platform Id
id LambdaFormInfo
lf_info (CLabel -> CmmLit
CmmLabel CLabel
closure_label)
      lf_info :: LambdaFormInfo
lf_info       = Platform
-> Id
-> TopLevelFlag
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> LambdaFormInfo
mkClosureLFInfo Platform
platform Id
id TopLevelFlag
TopLevel [] UpdateFlag
upd_flag [Id]
args
  in (CgIdInfo
cg_id_info, LambdaFormInfo -> CLabel -> FCode ()
gen_code LambdaFormInfo
lf_info CLabel
closure_label)
  where

  gen_code :: LambdaFormInfo -> CLabel -> FCode ()

  -- special case for a indirection (f = g).  We create an IND_STATIC
  -- closure pointing directly to the indirectee.  This is exactly
  -- what the CAF will eventually evaluate to anyway, we're just
  -- shortcutting the whole process, and generating a lot less code
  -- (#7308). Eventually the IND_STATIC closure will be eliminated
  -- by assembly '.equiv' directives, where possible (#15155).
  -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
  --
  -- Note: we omit the optimisation when this binding is part of a
  -- recursive group, because the optimisation would inhibit the black
  -- hole detection from working in that case.  Test
  -- concurrent/should_run/4030 fails, for instance.
  --
  gen_code :: LambdaFormInfo -> CLabel -> FCode ()
gen_code LambdaFormInfo
_ CLabel
closure_label
    | StgApp Id
f [] <- CgStgExpr
body
    , [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
args
    , RecFlag -> Bool
isNonRec RecFlag
rec
    = do
         cg_info <- Id -> FCode CgIdInfo
getCgIdInfo Id
f
         emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)]

  -- Emit standard stg_unpack_cstring closures for top-level unpackCString# thunks.
  --
  -- Note that we do not do this for thunks enclosured in code ticks (e.g. hpc
  -- ticks) since we want to ensure that these ticks are not lost (e.g.
  -- resulting in Strings being reported by hpc as uncovered). However, we
  -- don't worry about standard profiling ticks since unpackCString tends not
  -- be terribly interesting in profiles. See Note [unpack_cstring closures] in
  -- StgStdThunks.cmm.
  gen_code LambdaFormInfo
_ CLabel
closure_label
    | [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
args
    , Just FCode (CmmInfoTable, CmmLit)
gen <- CgStgExpr -> Maybe (FCode (CmmInfoTable, CmmLit))
isUnpackCStringClosure CgStgExpr
body
    = do (info, lit) <- FCode (CmmInfoTable, CmmLit)
gen
         emitDecl $ CmmData (Section Data closure_label) $
             CmmStatics closure_label info ccs [] [lit]

  gen_code LambdaFormInfo
lf_info CLabel
_closure_label
   = do { profile <- FCode Profile
getProfile
        ; let name = Id -> Name
idName Id
id
        ; mod_name <- getModuleName
        ; let descr         = Module -> Name -> String
closureDescription Module
mod_name Name
name
              closure_info  = Profile
-> Bool
-> Id
-> LambdaFormInfo
-> ByteOff
-> ByteOff
-> String
-> ClosureInfo
mkClosureInfo Profile
profile Bool
True Id
id LambdaFormInfo
lf_info ByteOff
0 ByteOff
0 String
descr

        -- We don't generate the static closure here, because we might
        -- want to add references to static closures to it later.  The
        -- static closure is generated by GHC.Cmm.Info.Build.updInfoSRTs,
        -- See Note [SRTs], specifically the [FUN] optimisation.

        ; let fv_details :: [(NonVoid Id, ByteOff)]
              header = if LambdaFormInfo -> Bool
isLFThunk LambdaFormInfo
lf_info then ClosureHeader
ThunkHeader else ClosureHeader
StdHeader
              (_, _, fv_details) = mkVirtHeapOffsets profile header []
        -- Don't drop the non-void args until the closure info has been made
        ; forkClosureBody (closureCodeBody True id closure_info ccs
                                args body fv_details)

        ; return () }

  unLit :: CmmExpr -> CmmLit
unLit (CmmLit CmmLit
l) = CmmLit
l
  unLit CmmExpr
_ = String -> CmmLit
forall a. HasCallStack => String -> a
panic String
"unLit"

isUnpackCStringClosure :: CgStgExpr -> Maybe (FCode (CmmInfoTable, CmmLit))
isUnpackCStringClosure :: CgStgExpr -> Maybe (FCode (CmmInfoTable, CmmLit))
isUnpackCStringClosure CgStgExpr
body = case (StgTickish -> Bool) -> CgStgExpr -> CgStgExpr
forall (p :: StgPass).
(StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p
stripStgTicksTopE (Bool -> Bool
not (Bool -> Bool) -> (StgTickish -> Bool) -> StgTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode) CgStgExpr
body of
  StgApp Id
f [StgArg
arg]
    | Just CLabel
unpack <- Id -> Maybe CLabel
is_string_unpack_op Id
f
    -> FCode (CmmInfoTable, CmmLit)
-> Maybe (FCode (CmmInfoTable, CmmLit))
forall a. a -> Maybe a
Just (FCode (CmmInfoTable, CmmLit)
 -> Maybe (FCode (CmmInfoTable, CmmLit)))
-> FCode (CmmInfoTable, CmmLit)
-> Maybe (FCode (CmmInfoTable, CmmLit))
forall a b. (a -> b) -> a -> b
$ do
        arg' <- NonVoid StgArg -> FCode CmmExpr
getArgAmode (StgArg -> NonVoid StgArg
forall a. a -> NonVoid a
NonVoid StgArg
arg)
        case arg' of
          CmmLit CmmLit
lit -> do
            let info :: CmmInfoTable
info = CmmInfoTable
                  { cit_lbl :: CLabel
cit_lbl = CLabel
unpack
                  , cit_rep :: SMRep
cit_rep = Bool -> ByteOff -> ByteOff -> ClosureTypeInfo -> SMRep
HeapRep Bool
True ByteOff
0 ByteOff
1 ClosureTypeInfo
Thunk
                  , cit_prof :: ProfilingInfo
cit_prof = ProfilingInfo
NoProfilingInfo
                  , cit_srt :: Maybe CLabel
cit_srt = Maybe CLabel
forall a. Maybe a
Nothing
                  , cit_clo :: Maybe (Id, CostCentreStack)
cit_clo = Maybe (Id, CostCentreStack)
forall a. Maybe a
Nothing
                  }
            (CmmInfoTable, CmmLit) -> FCode (CmmInfoTable, CmmLit)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmInfoTable
info, CmmLit
lit)
          CmmExpr
_ -> String -> FCode (CmmInfoTable, CmmLit)
forall a. HasCallStack => String -> a
panic String
"isUnpackCStringClosure: not a lit"
  StgCase (StgLit Literal
l) BinderP 'CodeGen
b AltType
_ [GenStgAlt 'CodeGen
alt]
    -- In -O0, we might get strings that haven't been floated to top-level, e.g.,
    --   case "undefined"# of sat {
    --     __DEFAULT -> unpackCString# sat
    --   }
    -- This case is supposed to catch that.
    | Just FCode (CmmInfoTable, CmmLit)
gen <- CgStgExpr -> Maybe (FCode (CmmInfoTable, CmmLit))
isUnpackCStringClosure (GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)
    -> FCode (CmmInfoTable, CmmLit)
-> Maybe (FCode (CmmInfoTable, CmmLit))
forall a. a -> Maybe a
Just (FCode (CmmInfoTable, CmmLit)
 -> Maybe (FCode (CmmInfoTable, CmmLit)))
-> FCode (CmmInfoTable, CmmLit)
-> Maybe (FCode (CmmInfoTable, CmmLit))
forall a b. (a -> b) -> a -> b
$ do
        e <- Literal -> FCode CmmExpr
cgLit Literal
l
        addBindC (mkCgIdInfo b mkLFStringLit e)
        gen
  CgStgExpr
_ -> Maybe (FCode (CmmInfoTable, CmmLit))
forall a. Maybe a
Nothing
  where
    is_string_unpack_op :: Id -> Maybe CLabel
is_string_unpack_op Id
f
      | Id -> Name
idName Id
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unpackCStringName     = CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
mkRtsUnpackCStringLabel
      | Id -> Name
idName Id
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unpackCStringUtf8Name = CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
mkRtsUnpackCStringUtf8Label
      | Bool
otherwise                         = Maybe CLabel
forall a. Maybe a
Nothing

------------------------------------------------------------------------
--              Non-top-level bindings
------------------------------------------------------------------------

cgBind :: CgStgBinding -> FCode ()
cgBind :: CgStgBinding -> FCode ()
cgBind (StgNonRec BinderP 'CodeGen
name GenStgRhs 'CodeGen
rhs)
  = do  { (info, fcode) <- Id -> GenStgRhs 'CodeGen -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhs Id
BinderP 'CodeGen
name GenStgRhs 'CodeGen
rhs
        ; addBindC info
        ; init <- fcode
        ; emit init }
        -- init cannot be used in body, so slightly better to sink it eagerly

cgBind (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs)
  = do  {  r <- [FCode (CgIdInfo, FCode CmmAGraph)]
-> FCode [(CgIdInfo, FCode CmmAGraph)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([FCode (CgIdInfo, FCode CmmAGraph)]
 -> FCode [(CgIdInfo, FCode CmmAGraph)])
-> [FCode (CgIdInfo, FCode CmmAGraph)]
-> FCode [(CgIdInfo, FCode CmmAGraph)]
forall a b. (a -> b) -> a -> b
$ (Id -> GenStgRhs 'CodeGen -> FCode (CgIdInfo, FCode CmmAGraph))
-> [(Id, GenStgRhs 'CodeGen)]
-> [FCode (CgIdInfo, FCode CmmAGraph)]
forall a b c. (a -> b -> c) -> [(a, b)] -> [c]
unzipWith Id -> GenStgRhs 'CodeGen -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhs [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs
        ;  let (id_infos, fcodes) = unzip r
        ;  addBindsC id_infos
        ;  (inits, body) <- getCodeR $ sequence fcodes
        ;  emit (catAGraphs inits <*> body) }

{- Note [cgBind rec]
   ~~~~~~~~~~~~~~~~~
   Recursive let-bindings are tricky.
   Consider the following pseudocode:

     let x = \_ ->  ... y ...
         y = \_ ->  ... z ...
         z = \_ ->  ... x ...
     in ...

   For each binding, we need to allocate a closure, and each closure must
   capture the address of the other closures.
   We want to generate the following C-- code:
     // Initialization Code
     x = hp - 24; // heap address of x's closure
     y = hp - 40; // heap address of x's closure
     z = hp - 64; // heap address of x's closure
     // allocate and initialize x
     m[hp-8]   = ...
     m[hp-16]  = y       // the closure for x captures y
     m[hp-24] = x_info;
     // allocate and initialize y
     m[hp-32] = z;       // the closure for y captures z
     m[hp-40] = y_info;
     // allocate and initialize z
     ...

   For each closure, we must generate not only the code to allocate and
   initialize the closure itself, but also some initialization Code that
   sets a variable holding the closure pointer.

   We could generate a pair of the (init code, body code), but since
   the bindings are recursive we also have to initialise the
   environment with the CgIdInfo for all the bindings before compiling
   anything.  So we do this in 3 stages:

     1. collect all the CgIdInfos and initialise the environment
     2. compile each binding into (init, body) code
     3. emit all the inits, and then all the bodies

   We'd rather not have separate functions to do steps 1 and 2 for
   each binding, since in practice they share a lot of code.  So we
   have just one function, cgRhs, that returns a pair of the CgIdInfo
   for step 1, and a monadic computation to generate the code in step
   2.

   The alternative to separating things in this way is to use a
   fixpoint.  That's what we used to do, but it introduces a
   maintenance nightmare because there is a subtle dependency on not
   being too strict everywhere.  Doing things this way means that the
   FCode monad can be strict, for example.
 -}

cgRhs :: Id
      -> CgStgRhs
      -> FCode (
                 CgIdInfo         -- The info for this binding
               , FCode CmmAGraph  -- A computation which will generate the
                                  -- code for the binding, and return an
                                  -- assignment of the form "x = Hp - n"
                                  -- (see above)
               )

cgRhs :: Id -> GenStgRhs 'CodeGen -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhs Id
id (StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
mn [StgTickish]
_ts [StgArg]
args Type
_typ)
  = Id
-> DataCon
-> ConstructorNumber
-> FCode (CgIdInfo, FCode CmmAGraph)
-> FCode (CgIdInfo, FCode CmmAGraph)
forall a. Id -> DataCon -> ConstructorNumber -> FCode a -> FCode a
withNewTickyCounterCon Id
id DataCon
con ConstructorNumber
mn (FCode (CgIdInfo, FCode CmmAGraph)
 -> FCode (CgIdInfo, FCode CmmAGraph))
-> FCode (CgIdInfo, FCode CmmAGraph)
-> FCode (CgIdInfo, FCode CmmAGraph)
forall a b. (a -> b) -> a -> b
$
    Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon Id
id ConstructorNumber
mn Bool
True CostCentreStack
cc DataCon
con ([StgArg] -> [NonVoid StgArg]
assertNonVoidStgArgs [StgArg]
args)
      -- con args are always non-void,
      -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise

{- See Note [GC recovery] in "GHC.StgToCmm.Closure" -}
cgRhs Id
id (StgRhsClosure XRhsClosure 'CodeGen
fvs CostCentreStack
cc UpdateFlag
upd_flag [BinderP 'CodeGen]
args CgStgExpr
body Type
_typ)
  = do
    profile <- FCode Profile
getProfile
    check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig
    use_std_ap_thunk <- stgToCmmTickyAP <$> getStgToCmmConfig
    mkRhsClosure profile use_std_ap_thunk check_tags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body

------------------------------------------------------------------------
--              Non-constructor right hand sides
------------------------------------------------------------------------

mkRhsClosure :: Profile
             -> Bool                            -- Omit AP Thunks to improve profiling
             -> Bool                            -- Lint tag inference checks
             -> Id -> CostCentreStack
             -> [NonVoid Id]                    -- Free vars
             -> UpdateFlag
             -> [Id]                            -- Args
             -> CgStgExpr
             -> FCode (CgIdInfo, FCode CmmAGraph)

{- mkRhsClosure looks for two special forms of the right-hand side:
        a) selector thunks
        b) AP thunks

If neither happens, it just calls mkClosureLFInfo.  You might think
that mkClosureLFInfo should do all this, but it seems wrong for the
latter to look at the structure of an expression

Note [Selectors]
~~~~~~~~~~~~~~~~
We look at the body of the closure to see if it's a selector---turgid,
but nothing deep.  We are looking for a closure of {\em exactly} the
form:

...  = [the_fv] \ u [] ->
         case the_fv of
           con a_1 ... a_n -> a_i

Note [Ap thunks]
~~~~~~~~~~~~~~~~
A more generic AP thunk of the form

        x = [ x_1...x_n ] \.. [] -> x_1 ... x_n

A set of these is compiled statically into the RTS, so we just use
those.  We could extend the idea to thunks where some of the x_i are
global ids (and hence not free variables), but this would entail
generating a larger thunk.  It might be an option for non-optimising
compilation, though.

We only generate an Ap thunk if all the free variables are pointers,
for semi-obvious reasons.

-}

---------- See Note [Selectors] ------------------
mkRhsClosure :: Profile
-> Bool
-> Bool
-> Id
-> CostCentreStack
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> CgStgExpr
-> FCode (CgIdInfo, FCode CmmAGraph)
mkRhsClosure    Profile
profile Bool
_ Bool
_check_tags Id
bndr CostCentreStack
_cc
                [NonVoid Id
the_fv]                -- Just one free var
                UpdateFlag
upd_flag                -- Updatable thunk
                []                      -- A thunk
                CgStgExpr
expr
  | let strip :: GenStgExpr p -> GenStgExpr p
strip = (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p
forall (p :: StgPass).
(StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p
stripStgTicksTopE (Bool -> Bool
not (Bool -> Bool) -> (StgTickish -> Bool) -> StgTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode)
  , StgCase (StgApp Id
scrutinee [{-no args-}])
         BinderP 'CodeGen
_   -- ignore bndr
         (AlgAlt TyCon
_)
         [GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con   = DataAlt DataCon
_
                   , alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP 'CodeGen]
params
                   , alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs   = CgStgExpr
sel_expr}] <- CgStgExpr -> CgStgExpr
forall {p :: StgPass}. GenStgExpr p -> GenStgExpr p
strip CgStgExpr
expr
  , StgApp Id
selectee [{-no args-}] <- CgStgExpr -> CgStgExpr
forall {p :: StgPass}. GenStgExpr p -> GenStgExpr p
strip CgStgExpr
sel_expr
  , Id
the_fv Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
scrutinee                -- Scrutinee is the only free variable

  , let (ByteOff
_, ByteOff
_, [(NonVoid Id, ByteOff)]
params_w_offsets) = Profile
-> [NonVoid (PrimRep, Id)]
-> (ByteOff, ByteOff, [(NonVoid Id, ByteOff)])
forall a.
Profile
-> [NonVoid (PrimRep, a)]
-> (ByteOff, ByteOff, [(NonVoid a, ByteOff)])
mkVirtConstrOffsets Profile
profile ([NonVoid Id] -> [NonVoid (PrimRep, Id)]
addIdReps ([Id] -> [NonVoid Id]
assertNonVoidIds [Id]
[BinderP 'CodeGen]
params))
                                   -- pattern binders are always non-void,
                                   -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
  , Just ByteOff
the_offset <- [(NonVoid Id, ByteOff)] -> NonVoid Id -> Maybe ByteOff
forall a b. Eq a => Assoc a b -> a -> Maybe b
assocMaybe [(NonVoid Id, ByteOff)]
params_w_offsets (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
selectee)

  , let offset_into_int :: ByteOff
offset_into_int = Platform -> ByteOff -> ByteOff
bytesToWordsRoundUp (Profile -> Platform
profilePlatform Profile
profile) ByteOff
the_offset
                          ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- Profile -> ByteOff
fixedHdrSizeW Profile
profile
  , ByteOff
offset_into_int ByteOff -> ByteOff -> Bool
forall a. Ord a => a -> a -> Bool
<= PlatformConstants -> ByteOff
pc_MAX_SPEC_SELECTEE_SIZE (Profile -> PlatformConstants
profileConstants Profile
profile) -- Offset is small enough
  = -- NOT TRUE: assert (is_single_constructor)
    -- The simplifier may have statically determined that the single alternative
    -- is the only possible case and eliminated the others, even if there are
    -- other constructors in the datatype.  It's still ok to make a selector
    -- thunk in this case, because we *know* which constructor the scrutinee
    -- will evaluate to.
    --
    -- srt is discarded; it must be empty
    let lf_info :: LambdaFormInfo
lf_info = Id -> ByteOff -> Bool -> LambdaFormInfo
mkSelectorLFInfo Id
bndr ByteOff
offset_into_int (UpdateFlag -> Bool
isUpdatable UpdateFlag
upd_flag)
    in Id
-> LambdaFormInfo -> [StgArg] -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhsStdThunk Id
bndr LambdaFormInfo
lf_info [Id -> StgArg
StgVarArg Id
the_fv]

---------- See Note [Ap thunks] ------------------
mkRhsClosure    Profile
profile Bool
use_std_ap Bool
check_tags Id
bndr CostCentreStack
_cc
                [NonVoid Id]
fvs
                UpdateFlag
upd_flag
                []                      -- No args; a thunk
                (StgApp Id
fun_id [StgArg]
args)

  -- We are looking for an "ApThunk"; see data con ApThunk in GHC.StgToCmm.Closure
  -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)
  -- So the xi will all be free variables
  | Bool
use_std_ap
  , [StgArg]
args [StgArg] -> ByteOff -> Bool
forall a. [a] -> ByteOff -> Bool
`lengthIs` (ByteOff
n_fvsByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
-ByteOff
1)  -- This happens only if the fun_id and
                               -- args are all distinct local variables
                               -- The "-1" is for fun_id
    -- Missed opportunity:   (f x x) is not detected
  , (NonVoid Id -> Bool) -> [NonVoid Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (PrimRep -> Bool
isGcPtrRep (PrimRep -> Bool) -> (NonVoid Id -> PrimRep) -> NonVoid Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> PrimRep
idPrimRepU (Id -> PrimRep) -> (NonVoid Id -> Id) -> NonVoid Id -> PrimRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonVoid Id -> Id
forall a. NonVoid a -> a
fromNonVoid) [NonVoid Id]
fvs
  , UpdateFlag -> Bool
isUpdatable UpdateFlag
upd_flag
  , ByteOff
n_fvs ByteOff -> ByteOff -> Bool
forall a. Ord a => a -> a -> Bool
<= PlatformConstants -> ByteOff
pc_MAX_SPEC_AP_SIZE (Profile -> PlatformConstants
profileConstants Profile
profile)
  , Bool -> Bool
not (Profile -> Bool
profileIsProfiling Profile
profile)
                         -- not when profiling: we don't want to
                         -- lose information about this particular
                         -- thunk (e.g. its type) (#949)
  , Id -> ByteOff
idArity Id
fun_id ByteOff -> ByteOff -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOff
unknownArity -- don't spoil a known call
          -- Ha! an Ap thunk
  , Bool -> Bool
not Bool
check_tags -- See Note [Tag inference debugging]
  = Id
-> LambdaFormInfo -> [StgArg] -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhsStdThunk Id
bndr LambdaFormInfo
lf_info [StgArg]
payload

  where
    n_fvs :: ByteOff
n_fvs   = [NonVoid Id] -> ByteOff
forall a. [a] -> ByteOff
forall (t :: * -> *) a. Foldable t => t a -> ByteOff
length [NonVoid Id]
fvs
    lf_info :: LambdaFormInfo
lf_info = Id -> UpdateFlag -> ByteOff -> LambdaFormInfo
mkApLFInfo Id
bndr UpdateFlag
upd_flag ByteOff
n_fvs
    -- the payload has to be in the correct order, hence we can't
    -- just use the fvs.
    payload :: [StgArg]
payload = Id -> StgArg
StgVarArg Id
fun_id StgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
: [StgArg]
args

---------- Default case ------------------
mkRhsClosure Profile
profile Bool
_use_ap Bool
_check_tags Id
bndr CostCentreStack
cc [NonVoid Id]
fvs UpdateFlag
upd_flag [Id]
args CgStgExpr
body
  = do  { let lf_info :: LambdaFormInfo
lf_info = Platform
-> Id
-> TopLevelFlag
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> LambdaFormInfo
mkClosureLFInfo (Profile -> Platform
profilePlatform Profile
profile) Id
bndr TopLevelFlag
NotTopLevel [NonVoid Id]
fvs UpdateFlag
upd_flag [Id]
args
        ; (id_info, reg) <- Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo Id
bndr LambdaFormInfo
lf_info
        ; return (id_info, gen_code lf_info reg) }
 where
 gen_code :: LambdaFormInfo -> LocalReg -> FCode CmmAGraph
gen_code LambdaFormInfo
lf_info LocalReg
reg
  = do  {       -- LAY OUT THE OBJECT
        -- If the binder is itself a free variable, then don't store
        -- it in the closure.  Instead, just bind it to Node on entry.
        -- NB we can be sure that Node will point to it, because we
        -- haven't told mkClosureLFInfo about this; so if the binder
        -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
        -- stored in the closure itself, so it will make sure that
        -- Node points to it...
        ; let   reduced_fvs :: [NonVoid Id]
reduced_fvs = (NonVoid Id -> Bool) -> [NonVoid Id] -> [NonVoid Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
bndr NonVoid Id -> NonVoid Id -> Bool
forall a. Eq a => a -> a -> Bool
/=) [NonVoid Id]
fvs

        ; profile <- FCode Profile
getProfile
        ; let platform = Profile -> Platform
profilePlatform Profile
profile

        -- MAKE CLOSURE INFO FOR THIS CLOSURE
        ; mod_name <- getModuleName
        ; let   name  = Id -> Name
idName Id
bndr
                descr = Module -> Name -> String
closureDescription Module
mod_name Name
name
                fv_details :: [(NonVoid Id, ByteOff)]
                header = if LambdaFormInfo -> Bool
isLFThunk LambdaFormInfo
lf_info then ClosureHeader
ThunkHeader else ClosureHeader
StdHeader
                (tot_wds, ptr_wds, fv_details)
                   = mkVirtHeapOffsets profile header (addIdReps reduced_fvs)
                closure_info = Profile
-> Bool
-> Id
-> LambdaFormInfo
-> ByteOff
-> ByteOff
-> String
-> ClosureInfo
mkClosureInfo Profile
profile Bool
False       -- Not static
                                             Id
bndr LambdaFormInfo
lf_info ByteOff
tot_wds ByteOff
ptr_wds
                                             String
descr

        -- BUILD ITS INFO TABLE AND CODE
        ; forkClosureBody $
                -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
                --                  (b) ignore Sequel from context; use empty Sequel
                -- And compile the body
                closureCodeBody False bndr closure_info cc args
                                body fv_details

        -- BUILD THE OBJECT
--      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
        ; let use_cc = Platform -> CmmExpr
cccsExpr Platform
platform; blame_cc = Platform -> CmmExpr
cccsExpr Platform
platform
        ; emit (mkComment $ mkFastString "calling allocDynClosure")
        ; let toVarArg (NonVoid Id
a, b
off) = (StgArg -> NonVoid StgArg
forall a. a -> NonVoid a
NonVoid (Id -> StgArg
StgVarArg Id
a), b
off)
        ; let info_tbl = ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
mkCmmInfo ClosureInfo
closure_info Id
bndr CostCentreStack
currentCCS
        ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc
                                         (map toVarArg fv_details)

        -- RETURN
        ; return (mkRhsInit platform reg lf_info hp_plus_n) }

-------------------------
cgRhsStdThunk
        :: Id
        -> LambdaFormInfo
        -> [StgArg]             -- payload
        -> FCode (CgIdInfo, FCode CmmAGraph)

cgRhsStdThunk :: Id
-> LambdaFormInfo -> [StgArg] -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhsStdThunk Id
bndr LambdaFormInfo
lf_info [StgArg]
payload
 = do  { (id_info, reg) <- Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo Id
bndr LambdaFormInfo
lf_info
       ; return (id_info, gen_code reg)
       }
 where
 gen_code :: LocalReg -> FCode CmmAGraph
gen_code LocalReg
reg  -- AHA!  A STANDARD-FORM THUNK
  = Bool -> Id -> [StgArg] -> FCode CmmAGraph -> FCode CmmAGraph
forall a. Bool -> Id -> [StgArg] -> FCode a -> FCode a
withNewTickyCounterStdThunk (LambdaFormInfo -> Bool
lfUpdatable LambdaFormInfo
lf_info) (Id
bndr) [StgArg]
payload (FCode CmmAGraph -> FCode CmmAGraph)
-> FCode CmmAGraph -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$
    do
  {     -- LAY OUT THE OBJECT
    mod_name <- FCode Module
getModuleName
  ; profile  <- getProfile
  ; platform <- getPlatform
  ; let
        header = if LambdaFormInfo -> Bool
isLFThunk LambdaFormInfo
lf_info then ClosureHeader
ThunkHeader else ClosureHeader
StdHeader
        (tot_wds, ptr_wds, payload_w_offsets)
            = mkVirtHeapOffsets profile header
                (addArgReps (nonVoidStgArgs payload))

        descr = Module -> Name -> String
closureDescription Module
mod_name (Id -> Name
idName Id
bndr)
        closure_info = Profile
-> Bool
-> Id
-> LambdaFormInfo
-> ByteOff
-> ByteOff
-> String
-> ClosureInfo
mkClosureInfo Profile
profile Bool
False       -- Not static
                                     Id
bndr LambdaFormInfo
lf_info ByteOff
tot_wds ByteOff
ptr_wds
                                     String
descr

--  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
  ; let use_cc = Platform -> CmmExpr
cccsExpr Platform
platform; blame_cc = Platform -> CmmExpr
cccsExpr Platform
platform


        -- BUILD THE OBJECT
  ; let info_tbl = ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
mkCmmInfo ClosureInfo
closure_info Id
bndr CostCentreStack
currentCCS
  ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info
                                   use_cc blame_cc payload_w_offsets

        -- RETURN
  ; return (mkRhsInit platform reg lf_info hp_plus_n) }


mkClosureLFInfo :: Platform
                -> Id           -- The binder
                -> TopLevelFlag -- True of top level
                -> [NonVoid Id] -- Free vars
                -> UpdateFlag   -- Update flag
                -> [Id]         -- Args
                -> LambdaFormInfo
mkClosureLFInfo :: Platform
-> Id
-> TopLevelFlag
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> LambdaFormInfo
mkClosureLFInfo Platform
platform Id
bndr TopLevelFlag
top [NonVoid Id]
fvs UpdateFlag
upd_flag [Id]
args
  | [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
args =
        Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
mkLFThunk (Id -> Type
idType Id
bndr) TopLevelFlag
top ((NonVoid Id -> Id) -> [NonVoid Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map NonVoid Id -> Id
forall a. NonVoid a -> a
fromNonVoid [NonVoid Id]
fvs) UpdateFlag
upd_flag
  | Bool
otherwise =
        TopLevelFlag -> [Id] -> [Id] -> ArgDescr -> LambdaFormInfo
mkLFReEntrant TopLevelFlag
top ((NonVoid Id -> Id) -> [NonVoid Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map NonVoid Id -> Id
forall a. NonVoid a -> a
fromNonVoid [NonVoid Id]
fvs) [Id]
args (Platform -> [Id] -> ArgDescr
mkArgDescr Platform
platform [Id]
args)


------------------------------------------------------------------------
--              The code for closures
------------------------------------------------------------------------

closureCodeBody :: Bool            -- whether this is a top-level binding
                -> Id              -- the closure's name
                -> ClosureInfo     -- Lots of information about this closure
                -> CostCentreStack -- Optional cost centre attached to closure
                -> [Id]            -- incoming args to the closure
                -> CgStgExpr
                -> [(NonVoid Id, ByteOff)] -- the closure's free vars
                -> FCode ()

{- There are two main cases for the code for closures.

* If there are *no arguments*, then the closure is a thunk, and not in
  normal form. So it should set up an update frame (if it is
  shared). NB: Thunks cannot have a primitive type!

* If there is *at least one* argument, then this closure is in
  normal form, so there is no need to set up an update frame.
-}

-- No args i.e. thunk
closureCodeBody :: Bool
-> Id
-> ClosureInfo
-> CostCentreStack
-> [Id]
-> CgStgExpr
-> [(NonVoid Id, ByteOff)]
-> FCode ()
closureCodeBody Bool
top_lvl Id
bndr ClosureInfo
cl_info CostCentreStack
cc [] CgStgExpr
body [(NonVoid Id, ByteOff)]
fv_details
  = Bool -> Bool -> Id -> [NonVoid Id] -> FCode () -> FCode ()
forall a. Bool -> Bool -> Id -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterThunk
        (ClosureInfo -> Bool
isStaticClosure ClosureInfo
cl_info)
        (ClosureInfo -> Bool
closureUpdReqd ClosureInfo
cl_info)
        (ClosureInfo -> Id
closureName ClosureInfo
cl_info)
        (((NonVoid Id, ByteOff) -> NonVoid Id)
-> [(NonVoid Id, ByteOff)] -> [NonVoid Id]
forall a b. (a -> b) -> [a] -> [b]
map (NonVoid Id, ByteOff) -> NonVoid Id
forall a b. (a, b) -> a
fst [(NonVoid Id, ByteOff)]
fv_details) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
    Bool
-> Id
-> LambdaFormInfo
-> CmmInfoTable
-> [NonVoid Id]
-> ((ByteOff, LocalReg, [LocalReg]) -> FCode ())
-> FCode ()
emitClosureProcAndInfoTable Bool
top_lvl Id
bndr LambdaFormInfo
lf_info CmmInfoTable
info_tbl [] (((ByteOff, LocalReg, [LocalReg]) -> FCode ()) -> FCode ())
-> ((ByteOff, LocalReg, [LocalReg]) -> FCode ()) -> FCode ()
forall a b. (a -> b) -> a -> b
$
      \(ByteOff
_, LocalReg
node, [LocalReg]
_) -> ClosureInfo
-> [(NonVoid Id, ByteOff)]
-> CostCentreStack
-> LocalReg
-> CgStgExpr
-> FCode ()
thunkCode ClosureInfo
cl_info [(NonVoid Id, ByteOff)]
fv_details CostCentreStack
cc LocalReg
node CgStgExpr
body
   where
     lf_info :: LambdaFormInfo
lf_info  = ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
cl_info
     info_tbl :: CmmInfoTable
info_tbl = ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
mkCmmInfo ClosureInfo
cl_info Id
bndr CostCentreStack
cc

-- Functions
closureCodeBody Bool
top_lvl Id
bndr ClosureInfo
cl_info CostCentreStack
cc args :: [Id]
args@(Id
arg0:[Id]
_) CgStgExpr
body [(NonVoid Id, ByteOff)]
fv_details
  = let nv_args :: [NonVoid Id]
nv_args = [Id] -> [NonVoid Id]
nonVoidIds [Id]
args
        arity :: ByteOff
arity = [Id] -> ByteOff
forall a. [a] -> ByteOff
forall (t :: * -> *) a. Foldable t => t a -> ByteOff
length [Id]
args
    in
    -- See Note [OneShotInfo overview] in GHC.Types.Basic.
    Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode () -> FCode ()
forall a.
Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterFun (Id -> Bool
isOneShotBndr Id
arg0) (ClosureInfo -> Id
closureName ClosureInfo
cl_info) (((NonVoid Id, ByteOff) -> NonVoid Id)
-> [(NonVoid Id, ByteOff)] -> [NonVoid Id]
forall a b. (a -> b) -> [a] -> [b]
map (NonVoid Id, ByteOff) -> NonVoid Id
forall a b. (a, b) -> a
fst [(NonVoid Id, ByteOff)]
fv_details)
        [NonVoid Id]
nv_args (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do {

        ; let
             lf_info :: LambdaFormInfo
lf_info  = ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
cl_info
             info_tbl :: CmmInfoTable
info_tbl = ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
mkCmmInfo ClosureInfo
cl_info Id
bndr CostCentreStack
cc

        -- Emit the main entry code
        ; Bool
-> Id
-> LambdaFormInfo
-> CmmInfoTable
-> [NonVoid Id]
-> ((ByteOff, LocalReg, [LocalReg]) -> FCode ())
-> FCode ()
emitClosureProcAndInfoTable Bool
top_lvl Id
bndr LambdaFormInfo
lf_info CmmInfoTable
info_tbl [NonVoid Id]
nv_args (((ByteOff, LocalReg, [LocalReg]) -> FCode ()) -> FCode ())
-> ((ByteOff, LocalReg, [LocalReg]) -> FCode ()) -> FCode ()
forall a b. (a -> b) -> a -> b
$
            \(ByteOff
_offset, LocalReg
node, [LocalReg]
arg_regs) -> do
                -- Emit slow-entry code (for entering a closure through a PAP)
                { Id -> ClosureInfo -> [LocalReg] -> FCode ()
mkSlowEntryCode Id
bndr ClosureInfo
cl_info [LocalReg]
arg_regs
                ; profile <- FCode Profile
getProfile
                ; platform <- getPlatform
                ; let node_points = Profile -> LambdaFormInfo -> Bool
nodeMustPointToIt Profile
profile LambdaFormInfo
lf_info
                      node' = if Bool
node_points then LocalReg -> Maybe LocalReg
forall a. a -> Maybe a
Just LocalReg
node else Maybe LocalReg
forall a. Maybe a
Nothing
                ; loop_header_id <- newBlockId
                -- Extend reader monad with information that
                -- self-recursive tail calls can be optimized into local
                -- jumps. See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr.
                ; let !self_loop_info = MkSelfLoopInfo
                        { sli_id :: Id
sli_id = Id
bndr
                        , sli_arity :: ByteOff
sli_arity = ByteOff
arity
                        , sli_header_block :: BlockId
sli_header_block = BlockId
loop_header_id
                        , sli_registers :: [LocalReg]
sli_registers = [LocalReg]
arg_regs
                        }
                ; withSelfLoop self_loop_info $ do
                {
                -- Main payload
                ; entryHeapCheck cl_info node' arity arg_regs $ do
                { -- emit LDV code when profiling
                  when node_points (ldvEnterClosure cl_info (CmmLocal node))
                -- ticky after heap check to avoid double counting
                ; tickyEnterFun cl_info
                ; enterCostCentreFun cc
                    (CmmMachOp (mo_wordSub platform)
                         [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
                         , mkIntExpr platform (funTag platform cl_info) ])
                ; fv_bindings <- mapM bind_fv fv_details
                -- Load free vars out of closure *after*
                -- heap check, to reduce live vars over check
                ; when node_points $ load_fvs node lf_info fv_bindings
                ; checkFunctionArgTags (text "TagCheck failed - Argument to local function:" <> ppr bndr) bndr args
                ; void $ cgExpr body
                }}}

  }

-- Note [NodeReg clobbered with loopification]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Previously we used to pass nodeReg (aka R1) here. With profiling, upon
-- entering a closure, enterFunCCS was called with R1 passed to it. But since R1
-- may get clobbered inside the body of a closure, and since a self-recursive
-- tail call does not restore R1, a subsequent call to enterFunCCS received a
-- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to
-- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores
-- the original value of R1. This way R1 may get modified but loopification will
-- not care.

-- A function closure pointer may be tagged, so we
-- must take it into account when accessing the free variables.
bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
bind_fv (NonVoid Id
id, ByteOff
off) = do { reg <- NonVoid Id -> FCode LocalReg
rebindToReg NonVoid Id
id; return (reg, off) }

load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
load_fvs LocalReg
node LambdaFormInfo
lf_info = ((LocalReg, ByteOff) -> FCode ())
-> [(LocalReg, ByteOff)] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ (LocalReg
reg, ByteOff
off) ->
   do platform <- FCode Platform
getPlatform
      let tag = Platform -> LambdaFormInfo -> ByteOff
lfDynTag Platform
platform LambdaFormInfo
lf_info
      emit $ mkTaggedObjectLoad platform reg node off tag)

-----------------------------------------
-- The "slow entry" code for a function.  This entry point takes its
-- arguments on the stack.  It loads the arguments into registers
-- according to the calling convention, and jumps to the function's
-- normal entry point.  The function's closure is assumed to be in
-- R1/node.
--
-- The slow entry point is used for unknown calls: eg. stg_PAP_entry

mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
-- If this function doesn't have a specialised ArgDescr, we need
-- to generate the function's arg bitmap and slow-entry code.
-- Here, we emit the slow-entry code.
mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
mkSlowEntryCode Id
bndr ClosureInfo
cl_info [LocalReg]
arg_regs -- function closure is already in `Node'
  | Just (ByteOff
_, ArgGen Liveness
_) <- ClosureInfo -> Maybe (ByteOff, ArgDescr)
closureFunInfo ClosureInfo
cl_info
  = do cfg       <- FCode StgToCmmConfig
getStgToCmmConfig
       upd_frame <- getUpdFrameOff
       let node = Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
bndr)
           profile  = StgToCmmConfig -> Profile
stgToCmmProfile  StgToCmmConfig
cfg
           platform = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
           slow_lbl = Platform -> ClosureInfo -> CLabel
closureSlowEntryLabel  Platform
platform ClosureInfo
cl_info
           fast_lbl = Platform -> ClosureInfo -> CLabel
closureLocalEntryLabel Platform
platform ClosureInfo
cl_info
           -- mkDirectJump does not clobber `Node' containing function closure
           jump = Profile
-> Convention -> CmmExpr -> [CmmExpr] -> ByteOff -> CmmAGraph
mkJump Profile
profile Convention
NativeNodeCall
                                (CLabel -> CmmExpr
mkLblExpr CLabel
fast_lbl)
                                ((LocalReg -> CmmExpr) -> [LocalReg] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> (LocalReg -> CmmReg) -> LocalReg -> CmmExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) (LocalReg
node LocalReg -> [LocalReg] -> [LocalReg]
forall a. a -> [a] -> [a]
: [LocalReg]
arg_regs))
                                ByteOff
upd_frame
       tscope <- getTickScope
       emitProcWithConvention Slow Nothing slow_lbl
         (node : arg_regs) (jump, tscope)
  | Bool
otherwise = () -> FCode ()
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-----------------------------------------
thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
          -> LocalReg -> CgStgExpr -> FCode ()
thunkCode :: ClosureInfo
-> [(NonVoid Id, ByteOff)]
-> CostCentreStack
-> LocalReg
-> CgStgExpr
-> FCode ()
thunkCode ClosureInfo
cl_info [(NonVoid Id, ByteOff)]
fv_details CostCentreStack
_cc LocalReg
node CgStgExpr
body
  = do { profile <- FCode Profile
getProfile
       ; platform <- getPlatform
       ; let node_points = Profile -> LambdaFormInfo -> Bool
nodeMustPointToIt Profile
profile (ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
cl_info)
             node'       = if Bool
node_points then LocalReg -> Maybe LocalReg
forall a. a -> Maybe a
Just LocalReg
node else Maybe LocalReg
forall a. Maybe a
Nothing
        ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling

        -- Heap overflow check
        ; entryHeapCheck cl_info node' 0 [] $ do
        { -- Overwrite with black hole if necessary
          -- but *after* the heap-overflow check
        ; tickyEnterThunk cl_info
        ; when (blackHoleOnEntry cl_info && node_points)
                (blackHoleIt node)

          -- Push update frame
        ; setupUpdate cl_info node $
            -- We only enter cc after setting up update so
            -- that cc of enclosing scope will be recorded
            -- in update frame CAF/DICT functions will be
            -- subsumed by this enclosing cc
            do { enterCostCentreThunk (CmmReg $ nodeReg platform)
               ; let lf_info = ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
cl_info
               ; fv_bindings <- mapM bind_fv fv_details
               ; load_fvs node lf_info fv_bindings
               ; void $ cgExpr body }}}


------------------------------------------------------------------------
--              Update and black-hole wrappers
------------------------------------------------------------------------

blackHoleIt :: LocalReg -> FCode ()
-- Only called for closures with no args
-- Node points to the closure
blackHoleIt :: LocalReg -> FCode ()
blackHoleIt LocalReg
node_reg
  = CmmExpr -> FCode ()
emitBlackHoleCode (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
node_reg))

emitBlackHoleCode :: CmmExpr -> FCode ()
emitBlackHoleCode :: CmmExpr -> FCode ()
emitBlackHoleCode CmmExpr
node = do
  cfg <- FCode StgToCmmConfig
getStgToCmmConfig
  let profile     = StgToCmmConfig -> Profile
stgToCmmProfile  StgToCmmConfig
cfg
      platform    = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
      is_eager_bh = StgToCmmConfig -> Bool
stgToCmmEagerBlackHole StgToCmmConfig
cfg

  -- Eager blackholing is normally disabled, but can be turned on with
  -- -feager-blackholing.  When it is on, we replace the info pointer
  -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.

  -- If we wanted to do eager blackholing with slop filling, we'd need
  -- to do it at the *end* of a basic block, otherwise we overwrite
  -- the free variables in the thunk that we still need.  We have a
  -- patch for this from Andy Cheadle, but not incorporated yet. --SDM
  -- [6/2004]
  --
  -- Previously, eager blackholing was enabled when ticky-ticky was
  -- on. But it didn't work, and it wasn't strictly necessary to bring
  -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is
  -- unconditionally disabled. -- krc 1/2007

  -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
  -- because emitBlackHoleCode is called from GHC.Cmm.Parser.

  let  eager_blackholing =  Bool -> Bool
not (Profile -> Bool
profileIsProfiling Profile
profile) Bool -> Bool -> Bool
&& Bool
is_eager_bh
             -- Profiling needs slop filling (to support LDV
             -- profiling), so currently eager blackholing doesn't
             -- work with profiling.

  when eager_blackholing $ do
    whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node
    emitAtomicStore platform MemOrderRelease
        (cmmOffsetW platform node (fixedHdrSizeW profile))
        (currentTSOExpr platform)
    -- See Note [Heap memory barriers] in SMP.h.
    emitAtomicStore platform MemOrderRelease
        node
        (CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform))

emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode ()
emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode ()
emitAtomicStore Platform
platform MemoryOrdering
mord CmmExpr
addr CmmExpr
val =
    [LocalReg] -> CallishMachOp -> [CmmExpr] -> FCode ()
emitPrimCall [] (Width -> MemoryOrdering -> CallishMachOp
MO_AtomicWrite Width
w MemoryOrdering
mord) [CmmExpr
addr, CmmExpr
val]
  where
    w :: Width
w = CmmType -> Width
typeWidth (CmmType -> Width) -> CmmType -> Width
forall a b. (a -> b) -> a -> b
$ Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
val

setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
        -- Nota Bene: this function does not change Node (even if it's a CAF),
        -- so that the cost centre in the original closure can still be
        -- extracted by a subsequent enterCostCentre
setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
setupUpdate ClosureInfo
closure_info LocalReg
node FCode ()
body
  | Bool -> Bool
not (LambdaFormInfo -> Bool
lfUpdatable (ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
closure_info))
  = FCode ()
body

  | Bool -> Bool
not (ClosureInfo -> Bool
isStaticClosure ClosureInfo
closure_info)
  = if Bool -> Bool
not (ClosureInfo -> Bool
closureUpdReqd ClosureInfo
closure_info)
      then do FCode ()
tickyUpdateFrameOmitted; FCode ()
body
      else do
          FCode ()
tickyPushUpdateFrame
          cfg <- FCode StgToCmmConfig
getStgToCmmConfig
          let
              bh = ClosureInfo -> Bool
blackHoleOnEntry ClosureInfo
closure_info
                Bool -> Bool -> Bool
&& Bool -> Bool
not (StgToCmmConfig -> Bool
stgToCmmSCCProfiling StgToCmmConfig
cfg)
                Bool -> Bool -> Bool
&& StgToCmmConfig -> Bool
stgToCmmEagerBlackHole StgToCmmConfig
cfg

              lbl | Bool
bh        = CLabel
mkBHUpdInfoLabel
                  | Bool
otherwise = CLabel
mkUpdInfoLabel

          pushOrigThunkInfoFrame closure_info
            $ pushUpdateFrame lbl (CmmReg (CmmLocal node)) body

  | Bool
otherwise   -- A static closure
  = do  { ClosureInfo -> FCode ()
tickyUpdateBhCaf ClosureInfo
closure_info

        ; if ClosureInfo -> Bool
closureUpdReqd ClosureInfo
closure_info
          then do       -- Blackhole the (updatable) CAF:
                { upd_closure <- LocalReg -> FCode CmmExpr
link_caf LocalReg
node
                ; pushOrigThunkInfoFrame closure_info
                    $ pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
          else do {FCode ()
tickyUpdateFrameOmitted; FCode ()
body}
    }

-----------------------------------------------------------------------------
-- Setting up update frames

-- Push the update frame on the stack in the Entry area,
-- leaving room for the return address that is already
-- at the old end of the area.
--
pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()
pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()
pushUpdateFrame CLabel
lbl CmmExpr
updatee FCode ()
body
  = do
       updfr  <- FCode ByteOff
getUpdFrameOff
       profile <- getProfile
       let hdr         = Profile -> ByteOff
fixedHdrSize Profile
profile
           frame       = ByteOff
updfr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
hdr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ PlatformConstants -> ByteOff
pc_SIZEOF_StgUpdateFrame_NoHdr (Profile -> PlatformConstants
profileConstants Profile
profile)
       --
       emitUpdateFrame (CmmStackSlot Old frame) lbl updatee
       withUpdFrameOff frame body

emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode ()
emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode ()
emitUpdateFrame CmmExpr
frame CLabel
lbl CmmExpr
updatee = do
  profile <- FCode Profile
getProfile
  let
           hdr         = Profile -> ByteOff
fixedHdrSize Profile
profile
           off_updatee = ByteOff
hdr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ PlatformConstants -> ByteOff
pc_OFFSET_StgUpdateFrame_updatee (Platform -> PlatformConstants
platformConstants Platform
platform)
           platform    = Profile -> Platform
profilePlatform Profile
profile
  --
  emitStore frame (mkLblExpr lbl)
  emitStore (cmmOffset platform frame off_updatee) updatee
  initUpdFrameProf frame

-----------------------------------------------------------------------------
-- Original thunk info table frames
--
-- Note [Original thunk info table frames]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- In some debugging scenarios (e.g. when debugging cyclic thunks) it can be very
-- useful to know which thunks the program is in the process of evaluating.
-- However, in the case of updateable thunks this can be very difficult
-- to determine since the process of blackholing overwrites the thunk's
-- info table pointer.
--
-- To help in such situations we provide the -forig-thunk-info flag. This enables
-- code generation logic which pushes a stg_orig_thunk_info_frame stack frame to
-- accompany each update frame. As the name suggests, this frame captures the
-- the original info table of the thunk being updated. The entry code for these
-- frames has no operational effects; the frames merely exist as breadcrumbs
-- for debugging.

pushOrigThunkInfoFrame :: ClosureInfo -> FCode () -> FCode ()
pushOrigThunkInfoFrame :: ClosureInfo -> FCode () -> FCode ()
pushOrigThunkInfoFrame ClosureInfo
closure_info FCode ()
body = do
  cfg <- FCode StgToCmmConfig
getStgToCmmConfig
  if stgToCmmOrigThunkInfo cfg
     then do_it
     else body
  where
    orig_itbl :: CmmExpr
orig_itbl = CLabel -> CmmExpr
mkLblExpr (ClosureInfo -> CLabel
closureInfoLabel ClosureInfo
closure_info)
    do_it :: FCode ()
do_it = do
      updfr <- FCode ByteOff
getUpdFrameOff
      profile <- getProfile
      let platform = Profile -> Platform
profilePlatform Profile
profile
          hdr = Profile -> ByteOff
fixedHdrSize Profile
profile
          orig_info_frame_sz =
              ByteOff
hdr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ PlatformConstants -> ByteOff
pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr (Profile -> PlatformConstants
profileConstants Profile
profile)
          off_orig_info = ByteOff
hdr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ PlatformConstants -> ByteOff
pc_OFFSET_StgOrigThunkInfoFrame_info_ptr (Profile -> PlatformConstants
profileConstants Profile
profile)
          frame_off = ByteOff
updfr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
orig_info_frame_sz
          frame = Area -> ByteOff -> CmmExpr
CmmStackSlot Area
Old ByteOff
frame_off
      --
      emitStore frame (mkLblExpr mkOrigThunkInfoLabel)
      emitStore (cmmOffset platform frame off_orig_info) orig_itbl
      withUpdFrameOff frame_off body

-----------------------------------------------------------------------------
-- Entering a CAF
--
-- See Note [CAF management] in rts/sm/Storage.c

link_caf :: LocalReg           -- pointer to the closure
         -> FCode CmmExpr      -- Returns amode for closure to be updated
-- This function returns the address of the black hole, so it can be
-- updated with the new value when available.
link_caf :: LocalReg -> FCode CmmExpr
link_caf LocalReg
node = do
  { cfg <- FCode StgToCmmConfig
getStgToCmmConfig
        -- Call the RTS function newCAF, returning the newly-allocated
        -- blackhole indirection closure
  ; let newCAF_lbl = FastString
-> Maybe ByteOff -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel (String -> FastString
fsLit String
"newCAF") Maybe ByteOff
forall a. Maybe a
Nothing
                                    ForeignLabelSource
ForeignLabelInExternalPackage FunctionOrData
IsFunction
  ; let profile  = StgToCmmConfig -> Profile
stgToCmmProfile StgToCmmConfig
cfg
  ; let platform = Profile -> Platform
profilePlatform Profile
profile
  ; bh <- newTemp (bWord platform)
  ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl
      [ (baseExpr platform,  AddrHint),
        (CmmReg (CmmLocal node), AddrHint) ]
      False

  -- see Note [atomic CAF entry] in rts/sm/Storage.c
  ; updfr  <- getUpdFrameOff
  ; let align_check = StgToCmmConfig -> Bool
stgToCmmAlignCheck StgToCmmConfig
cfg
  ; let target      = Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform
                        (Platform -> Bool -> CmmExpr -> CmmExpr
closureInfoPtr Platform
platform Bool
align_check (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
node)))
  ; emit =<< mkCmmIfThen
      (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform))
        -- re-enter the CAF
       (mkJump profile NativeNodeCall target [] updfr)

  ; return (CmmReg (CmmLocal bh)) }

------------------------------------------------------------------------
--              Profiling
------------------------------------------------------------------------

-- For "global" data constructors the description is simply occurrence
-- name of the data constructor itself.  Otherwise it is determined by
-- @closureDescription@ from the let binding information.

closureDescription
   :: Module            -- Module
   -> Name              -- Id of closure binding
   -> String
        -- Not called for StgRhsCon which have global info tables built in
        -- CgConTbls.hs with a description generated from the data constructor
closureDescription :: Module -> Name -> String
closureDescription Module
mod_name Name
name
  = SDocContext -> SDoc -> String
showSDocOneLine SDocContext
defaultSDocContext
    (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'<' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Module -> Name -> SDoc
pprFullName Module
mod_name Name
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'>')