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

module StgCmmBind (
        cgTopRhsClosure,
        cgBind,
        emitBlackHoleCode,
        pushUpdateFrame, emitUpdateFrame
  ) where

import GhcPrelude hiding ((<*>))

import StgCmmExpr
import StgCmmMonad
import StgCmmEnv
import StgCmmCon
import StgCmmHeap
import StgCmmProf (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
                   initUpdFrameProf)
import StgCmmTicky
import StgCmmLayout
import StgCmmUtils
import StgCmmClosure
import StgCmmForeign    (emitPrimCall)

import MkGraph
import CoreSyn          ( AltCon(..), tickishIsCode )
import BlockId
import SMRep
import Cmm
import CmmInfo
import CmmUtils
import CLabel
import StgSyn
import CostCentre
import Id
import IdInfo
import Name
import Module
import ListSetOps
import Util
import VarSet
import BasicTypes
import Outputable
import FastString
import DynFlags

import Control.Monad

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

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

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

cgTopRhsClosure :: DynFlags
-> RecFlag
-> Id
-> CostCentreStack
-> UpdateFlag
-> [Id]
-> CgStgExpr
-> (CgIdInfo, FCode ())
cgTopRhsClosure dflags :: DynFlags
dflags rec :: RecFlag
rec id :: Id
id ccs :: CostCentreStack
ccs upd_flag :: UpdateFlag
upd_flag args :: [Id]
args body :: CgStgExpr
body =
  let closure_label :: CLabel
closure_label = Name -> CafInfo -> CLabel
mkLocalClosureLabel (Id -> Name
idName Id
id) (Id -> CafInfo
idCafInfo Id
id)
      cg_id_info :: CgIdInfo
cg_id_info    = DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo DynFlags
dflags Id
id LambdaFormInfo
lf_info (CLabel -> CmmLit
CmmLabel CLabel
closure_label)
      lf_info :: LambdaFormInfo
lf_info       = DynFlags
-> Id
-> TopLevelFlag
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> LambdaFormInfo
mkClosureLFInfo DynFlags
dflags Id
id TopLevelFlag
TopLevel [] UpdateFlag
upd_flag [Id]
args
  in (CgIdInfo
cg_id_info, DynFlags -> LambdaFormInfo -> CLabel -> FCode ()
gen_code DynFlags
dflags LambdaFormInfo
lf_info CLabel
closure_label)
  where
  -- 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)
  --
  -- 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 :: DynFlags -> LambdaFormInfo -> CLabel -> FCode ()
gen_code dflags :: DynFlags
dflags _ closure_label :: CLabel
closure_label
    | StgApp f :: Id
f [] <- CgStgExpr
body, [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
args, RecFlag -> Bool
isNonRec RecFlag
rec
    = do
         CgIdInfo
cg_info <- Id -> FCode CgIdInfo
getCgIdInfo Id
f
         let closure_rep :: [CmmLit]
closure_rep   = DynFlags
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields DynFlags
dflags
                                    CmmInfoTable
indStaticInfoTable CostCentreStack
ccs CafInfo
MayHaveCafRefs
                                    [CmmExpr -> CmmLit
unLit (CgIdInfo -> CmmExpr
idInfoToAmode CgIdInfo
cg_info)]
         CLabel -> [CmmLit] -> FCode ()
emitDataLits CLabel
closure_label [CmmLit]
closure_rep
         () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  gen_code dflags :: DynFlags
dflags lf_info :: LambdaFormInfo
lf_info _closure_label :: CLabel
_closure_label
   = do { let name :: Name
name = Id -> Name
idName Id
id
        ; Module
mod_name <- FCode Module
getModuleName
        ; let descr :: String
descr         = DynFlags -> Module -> Name -> String
closureDescription DynFlags
dflags Module
mod_name Name
name
              closure_info :: ClosureInfo
closure_info  = DynFlags
-> Bool
-> Id
-> LambdaFormInfo
-> Int
-> Int
-> String
-> ClosureInfo
mkClosureInfo DynFlags
dflags Bool
True Id
id LambdaFormInfo
lf_info 0 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 CmmBuildInfoTables.updInfoSRTs,
        -- See Note [SRTs], specifically the [FUN] optimisation.

        ; let fv_details :: [(NonVoid Id, ByteOff)]
              header :: ClosureHeader
header = if LambdaFormInfo -> Bool
isLFThunk LambdaFormInfo
lf_info then ClosureHeader
ThunkHeader else ClosureHeader
StdHeader
              (_, _, fv_details :: [(NonVoid Id, Int)]
fv_details) = DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, Id)]
-> (Int, Int, [(NonVoid Id, Int)])
forall a.
DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
mkVirtHeapOffsets DynFlags
dflags ClosureHeader
header []
        -- Don't drop the non-void args until the closure info has been made
        ; FCode () -> FCode ()
forkClosureBody (Bool
-> Id
-> ClosureInfo
-> CostCentreStack
-> [NonVoid Id]
-> Int
-> CgStgExpr
-> [(NonVoid Id, Int)]
-> FCode ()
closureCodeBody Bool
True Id
id ClosureInfo
closure_info CostCentreStack
ccs
                                ([Id] -> [NonVoid Id]
nonVoidIds [Id]
args) ([Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
args) CgStgExpr
body [(NonVoid Id, Int)]
fv_details)

        ; () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }

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

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

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

cgBind (StgRec pairs :: [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs)
  = do  {  [(CgIdInfo, FCode CmmAGraph)]
r <- [FCode (CgIdInfo, FCode CmmAGraph)]
-> FCode [(CgIdInfo, FCode CmmAGraph)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t 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 :: [CgIdInfo]
id_infos, fcodes :: [FCode CmmAGraph]
fcodes) = [(CgIdInfo, FCode CmmAGraph)] -> ([CgIdInfo], [FCode CmmAGraph])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CgIdInfo, FCode CmmAGraph)]
r
        ;  [CgIdInfo] -> FCode ()
addBindsC [CgIdInfo]
id_infos
        ;  (inits :: [CmmAGraph]
inits, body :: CmmAGraph
body) <- FCode [CmmAGraph] -> FCode ([CmmAGraph], CmmAGraph)
forall a. FCode a -> FCode (a, CmmAGraph)
getCodeR (FCode [CmmAGraph] -> FCode ([CmmAGraph], CmmAGraph))
-> FCode [CmmAGraph] -> FCode ([CmmAGraph], CmmAGraph)
forall a b. (a -> b) -> a -> b
$ [FCode CmmAGraph] -> FCode [CmmAGraph]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [FCode CmmAGraph]
fcodes
        ;  CmmAGraph -> FCode ()
emit ([CmmAGraph] -> CmmAGraph
catAGraphs [CmmAGraph]
inits CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
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 pratice 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
                                  -- assignent of the form "x = Hp - n"
                                  -- (see above)
               )

cgRhs :: Id -> GenStgRhs 'CodeGen -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhs id :: Id
id (StgRhsCon cc :: CostCentreStack
cc con :: DataCon
con args :: [StgArg]
args)
  = Name
-> FCode (CgIdInfo, FCode CmmAGraph)
-> FCode (CgIdInfo, FCode CmmAGraph)
forall a. Name -> FCode a -> FCode a
withNewTickyCounterCon (Id -> Name
idName Id
id) (FCode (CgIdInfo, FCode CmmAGraph)
 -> FCode (CgIdInfo, FCode CmmAGraph))
-> FCode (CgIdInfo, FCode CmmAGraph)
-> FCode (CgIdInfo, FCode CmmAGraph)
forall a b. (a -> b) -> a -> b
$
    Id
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon Id
id Bool
True CostCentreStack
cc DataCon
con ([StgArg] -> [NonVoid StgArg]
assertNonVoidStgArgs [StgArg]
args)
      -- con args are always non-void,
      -- see Note [Post-unarisation invariants] in UnariseStg

{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}
cgRhs id :: Id
id (StgRhsClosure fvs :: XRhsClosure 'CodeGen
fvs cc :: CostCentreStack
cc upd_flag :: UpdateFlag
upd_flag args :: [BinderP 'CodeGen]
args body :: CgStgExpr
body)
  = do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       DynFlags
-> Id
-> CostCentreStack
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> CgStgExpr
-> FCode (CgIdInfo, FCode CmmAGraph)
mkRhsClosure DynFlags
dflags Id
id CostCentreStack
cc ([Id] -> [NonVoid Id]
nonVoidIds (DVarSet -> [Id]
dVarSetElems DVarSet
XRhsClosure 'CodeGen
fvs)) UpdateFlag
upd_flag [Id]
[BinderP 'CodeGen]
args CgStgExpr
body

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

mkRhsClosure :: DynFlags -> 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.

-}

---------- Note [Selectors] ------------------
mkRhsClosure :: DynFlags
-> Id
-> CostCentreStack
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> CgStgExpr
-> FCode (CgIdInfo, FCode CmmAGraph)
mkRhsClosure    dflags :: DynFlags
dflags bndr :: Id
bndr _cc :: CostCentreStack
_cc
                [NonVoid the_fv :: Id
the_fv]                -- Just one free var
                upd_flag :: UpdateFlag
upd_flag                -- Updatable thunk
                []                      -- A thunk
                expr :: CgStgExpr
expr
  | let strip :: GenStgExpr p -> GenStgExpr p
strip = ([Tickish Id], GenStgExpr p) -> GenStgExpr p
forall a b. (a, b) -> b
snd (([Tickish Id], GenStgExpr p) -> GenStgExpr p)
-> (GenStgExpr p -> ([Tickish Id], GenStgExpr p))
-> GenStgExpr p
-> GenStgExpr p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tickish Id -> Bool)
-> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
forall (p :: StgPass).
(Tickish Id -> Bool)
-> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
stripStgTicksTop (Bool -> Bool
not (Bool -> Bool) -> (Tickish Id -> Bool) -> Tickish Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishIsCode)
  , StgCase (StgApp scrutinee :: Id
scrutinee [{-no args-}])
         _   -- ignore bndr
         (AlgAlt _)
         [(DataAlt _, params :: [BinderP 'CodeGen]
params, sel_expr :: CgStgExpr
sel_expr)] <- CgStgExpr -> CgStgExpr
forall (p :: StgPass). GenStgExpr p -> GenStgExpr p
strip CgStgExpr
expr
  , StgApp selectee :: 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 (_, _, params_w_offsets :: [(NonVoid Id, Int)]
params_w_offsets) = DynFlags
-> [NonVoid (PrimRep, Id)] -> (Int, Int, [(NonVoid Id, Int)])
forall a.
DynFlags
-> [NonVoid (PrimRep, a)] -> (Int, Int, [(NonVoid a, Int)])
mkVirtConstrOffsets DynFlags
dflags ([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 UnariseStg
  , Just the_offset :: Int
the_offset <- [(NonVoid Id, Int)] -> NonVoid Id -> Maybe Int
forall a b. Eq a => Assoc a b -> a -> Maybe b
assocMaybe [(NonVoid Id, Int)]
params_w_offsets (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
selectee)

  , let offset_into_int :: Int
offset_into_int = DynFlags -> Int -> Int
bytesToWordsRoundUp DynFlags
dflags Int
the_offset
                          Int -> Int -> Int
forall a. Num a => a -> a -> a
- DynFlags -> Int
fixedHdrSizeW DynFlags
dflags
  , Int
offset_into_int Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= DynFlags -> Int
mAX_SPEC_SELECTEE_SIZE DynFlags
dflags -- 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 -> Int -> Bool -> LambdaFormInfo
mkSelectorLFInfo Id
bndr Int
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]

---------- Note [Ap thunks] ------------------
mkRhsClosure    dflags :: DynFlags
dflags bndr :: Id
bndr _cc :: CostCentreStack
_cc
                fvs :: [NonVoid Id]
fvs
                upd_flag :: UpdateFlag
upd_flag
                []                      -- No args; a thunk
                (StgApp fun_id :: Id
fun_id args :: [StgArg]
args)

  -- We are looking for an "ApThunk"; see data con ApThunk in StgCmmClosure
  -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)
  -- So the xi will all be free variables
  | [StgArg]
args [StgArg] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` (Int
n_fvsInt -> Int -> Int
forall a. Num a => a -> a -> a
-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
idPrimRep (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
  , Int
n_fvs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= DynFlags -> Int
mAX_SPEC_AP_SIZE DynFlags
dflags
  , Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags)
                         -- not when profiling: we don't want to
                         -- lose information about this particular
                         -- thunk (e.g. its type) (#949)
  , Id -> Int
idArity Id
fun_id Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
unknownArity -- don't spoil a known call

          -- Ha! an Ap thunk
  = Id
-> LambdaFormInfo -> [StgArg] -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhsStdThunk Id
bndr LambdaFormInfo
lf_info [StgArg]
payload

  where
    n_fvs :: Int
n_fvs   = [NonVoid Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NonVoid Id]
fvs
    lf_info :: LambdaFormInfo
lf_info = Id -> UpdateFlag -> Int -> LambdaFormInfo
mkApLFInfo Id
bndr UpdateFlag
upd_flag Int
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 dflags :: DynFlags
dflags bndr :: Id
bndr cc :: CostCentreStack
cc fvs :: [NonVoid Id]
fvs upd_flag :: UpdateFlag
upd_flag args :: [Id]
args body :: CgStgExpr
body
  = do  { let lf_info :: LambdaFormInfo
lf_info = DynFlags
-> Id
-> TopLevelFlag
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> LambdaFormInfo
mkClosureLFInfo DynFlags
dflags Id
bndr TopLevelFlag
NotTopLevel [NonVoid Id]
fvs UpdateFlag
upd_flag [Id]
args
        ; (id_info :: CgIdInfo
id_info, reg :: LocalReg
reg) <- Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo Id
bndr LambdaFormInfo
lf_info
        ; (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (CgIdInfo
id_info, LambdaFormInfo -> LocalReg -> FCode CmmAGraph
gen_code LambdaFormInfo
lf_info LocalReg
reg) }
 where
 gen_code :: LambdaFormInfo -> LocalReg -> FCode CmmAGraph
gen_code lf_info :: LambdaFormInfo
lf_info reg :: 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

        -- MAKE CLOSURE INFO FOR THIS CLOSURE
        ; Module
mod_name <- FCode Module
getModuleName
        ; DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; let   name :: Name
name  = Id -> Name
idName Id
bndr
                descr :: String
descr = DynFlags -> Module -> Name -> String
closureDescription DynFlags
dflags Module
mod_name Name
name
                fv_details :: [(NonVoid Id, ByteOff)]
                header :: ClosureHeader
header = if LambdaFormInfo -> Bool
isLFThunk LambdaFormInfo
lf_info then ClosureHeader
ThunkHeader else ClosureHeader
StdHeader
                (tot_wds :: Int
tot_wds, ptr_wds :: Int
ptr_wds, fv_details :: [(NonVoid Id, Int)]
fv_details)
                   = DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, Id)]
-> (Int, Int, [(NonVoid Id, Int)])
forall a.
DynFlags
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (Int, Int, [(NonVoid a, Int)])
mkVirtHeapOffsets DynFlags
dflags ClosureHeader
header ([NonVoid Id] -> [NonVoid (PrimRep, Id)]
addIdReps [NonVoid Id]
reduced_fvs)
                closure_info :: ClosureInfo
closure_info = DynFlags
-> Bool
-> Id
-> LambdaFormInfo
-> Int
-> Int
-> String
-> ClosureInfo
mkClosureInfo DynFlags
dflags Bool
False       -- Not static
                                             Id
bndr LambdaFormInfo
lf_info Int
tot_wds Int
ptr_wds
                                             String
descr

        -- BUILD ITS INFO TABLE AND CODE
        ; FCode () -> FCode ()
forkClosureBody (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
                -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
                --                  (b) ignore Sequel from context; use empty Sequel
                -- And compile the body
                Bool
-> Id
-> ClosureInfo
-> CostCentreStack
-> [NonVoid Id]
-> Int
-> CgStgExpr
-> [(NonVoid Id, Int)]
-> FCode ()
closureCodeBody Bool
False Id
bndr ClosureInfo
closure_info CostCentreStack
cc ([Id] -> [NonVoid Id]
nonVoidIds [Id]
args)
                                ([Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
args) CgStgExpr
body [(NonVoid Id, Int)]
fv_details

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

        -- RETURN
        ; CmmAGraph -> FCode CmmAGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
mkRhsInit DynFlags
dflags LocalReg
reg LambdaFormInfo
lf_info CmmExpr
hp_plus_n) }

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

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

        descr :: String
descr = DynFlags -> Module -> Name -> String
closureDescription DynFlags
dflags Module
mod_name (Id -> Name
idName Id
bndr)
        closure_info :: ClosureInfo
closure_info = DynFlags
-> Bool
-> Id
-> LambdaFormInfo
-> Int
-> Int
-> String
-> ClosureInfo
mkClosureInfo DynFlags
dflags Bool
False       -- Not static
                                     Id
bndr LambdaFormInfo
lf_info Int
tot_wds Int
ptr_wds
                                     String
descr

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


        -- BUILD THE OBJECT
  ; let info_tbl :: CmmInfoTable
info_tbl = ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
mkCmmInfo ClosureInfo
closure_info Id
bndr CostCentreStack
currentCCS
  ; CmmExpr
hp_plus_n <- Maybe Id
-> CmmInfoTable
-> LambdaFormInfo
-> CmmExpr
-> CmmExpr
-> [(NonVoid StgArg, Int)]
-> FCode CmmExpr
allocDynClosure (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
bndr) CmmInfoTable
info_tbl LambdaFormInfo
lf_info
                                   CmmExpr
use_cc CmmExpr
blame_cc [(NonVoid StgArg, Int)]
payload_w_offsets

        -- RETURN
  ; CmmAGraph -> FCode CmmAGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
mkRhsInit DynFlags
dflags LocalReg
reg LambdaFormInfo
lf_info CmmExpr
hp_plus_n) }


mkClosureLFInfo :: DynFlags
                -> Id           -- The binder
                -> TopLevelFlag -- True of top level
                -> [NonVoid Id] -- Free vars
                -> UpdateFlag   -- Update flag
                -> [Id]         -- Args
                -> LambdaFormInfo
mkClosureLFInfo :: DynFlags
-> Id
-> TopLevelFlag
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> LambdaFormInfo
mkClosureLFInfo dflags :: DynFlags
dflags bndr :: Id
bndr top :: TopLevelFlag
top fvs :: [NonVoid Id]
fvs upd_flag :: UpdateFlag
upd_flag args :: [Id]
args
  | [Id] -> 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 (DynFlags -> [Id] -> ArgDescr
mkArgDescr DynFlags
dflags [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
                -> [NonVoid Id]    -- incoming args to the closure
                -> Int             -- arity, including void args
                -> 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.
-}

closureCodeBody :: Bool
-> Id
-> ClosureInfo
-> CostCentreStack
-> [NonVoid Id]
-> Int
-> CgStgExpr
-> [(NonVoid Id, Int)]
-> FCode ()
closureCodeBody top_lvl :: Bool
top_lvl bndr :: Id
bndr cl_info :: ClosureInfo
cl_info cc :: CostCentreStack
cc _args :: [NonVoid Id]
_args arity :: Int
arity body :: CgStgExpr
body fv_details :: [(NonVoid Id, Int)]
fv_details
  | Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 -- No args i.e. thunk
  = Bool -> Bool -> Name -> FCode () -> FCode ()
forall a. Bool -> Bool -> Name -> FCode a -> FCode a
withNewTickyCounterThunk
        (ClosureInfo -> Bool
isStaticClosure ClosureInfo
cl_info)
        (ClosureInfo -> Bool
closureUpdReqd ClosureInfo
cl_info)
        (ClosureInfo -> Name
closureName ClosureInfo
cl_info) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
    Bool
-> Id
-> LambdaFormInfo
-> CmmInfoTable
-> [NonVoid Id]
-> ((Int, LocalReg, [LocalReg]) -> FCode ())
-> FCode ()
emitClosureProcAndInfoTable Bool
top_lvl Id
bndr LambdaFormInfo
lf_info CmmInfoTable
info_tbl [] (((Int, LocalReg, [LocalReg]) -> FCode ()) -> FCode ())
-> ((Int, LocalReg, [LocalReg]) -> FCode ()) -> FCode ()
forall a b. (a -> b) -> a -> b
$
      \(_, node :: LocalReg
node, _) -> ClosureInfo
-> [(NonVoid Id, Int)]
-> CostCentreStack
-> LocalReg
-> Int
-> CgStgExpr
-> FCode ()
thunkCode ClosureInfo
cl_info [(NonVoid Id, Int)]
fv_details CostCentreStack
cc LocalReg
node Int
arity 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

closureCodeBody top_lvl :: Bool
top_lvl bndr :: Id
bndr cl_info :: ClosureInfo
cl_info cc :: CostCentreStack
cc args :: [NonVoid Id]
args arity :: Int
arity body :: CgStgExpr
body fv_details :: [(NonVoid Id, Int)]
fv_details
  = -- Note: args may be [], if all args are Void
    Bool -> Name -> [NonVoid Id] -> FCode () -> FCode ()
forall a. Bool -> Name -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterFun
        (ClosureInfo -> Bool
closureSingleEntry ClosureInfo
cl_info)
        (ClosureInfo -> Name
closureName ClosureInfo
cl_info)
        [NonVoid Id]
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]
-> ((Int, LocalReg, [LocalReg]) -> FCode ())
-> FCode ()
emitClosureProcAndInfoTable Bool
top_lvl Id
bndr LambdaFormInfo
lf_info CmmInfoTable
info_tbl [NonVoid Id]
args (((Int, LocalReg, [LocalReg]) -> FCode ()) -> FCode ())
-> ((Int, LocalReg, [LocalReg]) -> FCode ()) -> FCode ()
forall a b. (a -> b) -> a -> b
$
            \(_offset :: Int
_offset, node :: LocalReg
node, arg_regs :: [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
                ; DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                ; let node_points :: Bool
node_points = DynFlags -> LambdaFormInfo -> Bool
nodeMustPointToIt DynFlags
dflags LambdaFormInfo
lf_info
                      node' :: Maybe LocalReg
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
                ; BlockId
loop_header_id <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
                -- Extend reader monad with information that
                -- self-recursive tail calls can be optimized into local
                -- jumps. See Note [Self-recursive tail calls] in StgCmmExpr.
                ; SelfLoopInfo -> FCode () -> FCode ()
forall a. SelfLoopInfo -> FCode a -> FCode a
withSelfLoop (Id
bndr, BlockId
loop_header_id, [LocalReg]
arg_regs) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
                {
                -- Main payload
                ; ClosureInfo
-> Maybe LocalReg -> Int -> [LocalReg] -> FCode () -> FCode ()
entryHeapCheck ClosureInfo
cl_info Maybe LocalReg
node' Int
arity [LocalReg]
arg_regs (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
                { -- emit LDV code when profiling
                  Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
node_points (ClosureInfo -> CmmReg -> FCode ()
ldvEnterClosure ClosureInfo
cl_info (LocalReg -> CmmReg
CmmLocal LocalReg
node))
                -- ticky after heap check to avoid double counting
                ; ClosureInfo -> FCode ()
tickyEnterFun ClosureInfo
cl_info
                ; CostCentreStack -> CmmExpr -> FCode ()
enterCostCentreFun CostCentreStack
cc
                    (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordSub DynFlags
dflags)
                         [ CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
node) -- See [NodeReg clobbered with loopification]
                         , DynFlags -> Int -> CmmExpr
mkIntExpr DynFlags
dflags (DynFlags -> ClosureInfo -> Int
funTag DynFlags
dflags ClosureInfo
cl_info) ])
                ; [(LocalReg, Int)]
fv_bindings <- ((NonVoid Id, Int) -> FCode (LocalReg, Int))
-> [(NonVoid Id, Int)] -> FCode [(LocalReg, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NonVoid Id, Int) -> FCode (LocalReg, Int)
bind_fv [(NonVoid Id, Int)]
fv_details
                -- Load free vars out of closure *after*
                -- heap check, to reduce live vars over check
                ; Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
node_points (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ LocalReg -> LambdaFormInfo -> [(LocalReg, Int)] -> FCode ()
load_fvs LocalReg
node LambdaFormInfo
lf_info [(LocalReg, Int)]
fv_bindings
                ; FCode ReturnKind -> FCode ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (FCode ReturnKind -> FCode ()) -> FCode ReturnKind -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgStgExpr -> FCode ReturnKind
cgExpr CgStgExpr
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, Int) -> FCode (LocalReg, Int)
bind_fv (id :: NonVoid Id
id, off :: Int
off) = do { LocalReg
reg <- NonVoid Id -> FCode LocalReg
rebindToReg NonVoid Id
id; (LocalReg, Int) -> FCode (LocalReg, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalReg
reg, Int
off) }

load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, Int)] -> FCode ()
load_fvs node :: LocalReg
node lf_info :: LambdaFormInfo
lf_info = ((LocalReg, Int) -> FCode ()) -> [(LocalReg, Int)] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ (reg :: LocalReg
reg, off :: Int
off) ->
   do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      let tag :: Int
tag = DynFlags -> LambdaFormInfo -> Int
lfDynTag DynFlags
dflags LambdaFormInfo
lf_info
      CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> LocalReg -> LocalReg -> Int -> Int -> CmmAGraph
mkTaggedObjectLoad DynFlags
dflags LocalReg
reg LocalReg
node Int
off Int
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 bndr :: Id
bndr cl_info :: ClosureInfo
cl_info arg_regs :: [LocalReg]
arg_regs -- function closure is already in `Node'
  | Just (_, ArgGen _) <- ClosureInfo -> Maybe (Int, ArgDescr)
closureFunInfo ClosureInfo
cl_info
  = do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let node :: LocalReg
node = DynFlags -> NonVoid Id -> LocalReg
idToReg DynFlags
dflags (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
bndr)
           slow_lbl :: CLabel
slow_lbl = ClosureInfo -> CLabel
closureSlowEntryLabel  ClosureInfo
cl_info
           fast_lbl :: CLabel
fast_lbl = DynFlags -> ClosureInfo -> CLabel
closureLocalEntryLabel DynFlags
dflags ClosureInfo
cl_info
           -- mkDirectJump does not clobber `Node' containing function closure
           jump :: CmmAGraph
jump = DynFlags -> Convention -> CmmExpr -> [CmmExpr] -> Int -> CmmAGraph
mkJump DynFlags
dflags 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))
                                (DynFlags -> Int
initUpdFrameOff DynFlags
dflags)
       CmmTickScope
tscope <- FCode CmmTickScope
getTickScope
       Convention
-> Maybe CmmInfoTable
-> CLabel
-> [LocalReg]
-> CmmAGraphScoped
-> FCode ()
emitProcWithConvention Convention
Slow Maybe CmmInfoTable
forall a. Maybe a
Nothing CLabel
slow_lbl
         (LocalReg
node LocalReg -> [LocalReg] -> [LocalReg]
forall a. a -> [a] -> [a]
: [LocalReg]
arg_regs) (CmmAGraph
jump, CmmTickScope
tscope)
  | Bool
otherwise = () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-----------------------------------------
thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
          -> LocalReg -> Int -> CgStgExpr -> FCode ()
thunkCode :: ClosureInfo
-> [(NonVoid Id, Int)]
-> CostCentreStack
-> LocalReg
-> Int
-> CgStgExpr
-> FCode ()
thunkCode cl_info :: ClosureInfo
cl_info fv_details :: [(NonVoid Id, Int)]
fv_details _cc :: CostCentreStack
_cc node :: LocalReg
node arity :: Int
arity body :: CgStgExpr
body
  = do { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; let node_points :: Bool
node_points = DynFlags -> LambdaFormInfo -> Bool
nodeMustPointToIt DynFlags
dflags (ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
cl_info)
             node' :: Maybe LocalReg
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
        ; ClosureInfo -> CmmReg -> FCode ()
ldvEnterClosure ClosureInfo
cl_info (LocalReg -> CmmReg
CmmLocal LocalReg
node) -- NB: Node always points when profiling

        -- Heap overflow check
        ; ClosureInfo
-> Maybe LocalReg -> Int -> [LocalReg] -> FCode () -> FCode ()
entryHeapCheck ClosureInfo
cl_info Maybe LocalReg
node' Int
arity [] (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
        { -- Overwrite with black hole if necessary
          -- but *after* the heap-overflow check
        ; ClosureInfo -> FCode ()
tickyEnterThunk ClosureInfo
cl_info
        ; Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ClosureInfo -> Bool
blackHoleOnEntry ClosureInfo
cl_info Bool -> Bool -> Bool
&& Bool
node_points)
                (LocalReg -> FCode ()
blackHoleIt LocalReg
node)

          -- Push update frame
        ; ClosureInfo -> LocalReg -> FCode () -> FCode ()
setupUpdate ClosureInfo
cl_info LocalReg
node (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
            -- 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 { CmmExpr -> FCode ()
enterCostCentreThunk (CmmReg -> CmmExpr
CmmReg CmmReg
nodeReg)
               ; let lf_info :: LambdaFormInfo
lf_info = ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
cl_info
               ; [(LocalReg, Int)]
fv_bindings <- ((NonVoid Id, Int) -> FCode (LocalReg, Int))
-> [(NonVoid Id, Int)] -> FCode [(LocalReg, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NonVoid Id, Int) -> FCode (LocalReg, Int)
bind_fv [(NonVoid Id, Int)]
fv_details
               ; LocalReg -> LambdaFormInfo -> [(LocalReg, Int)] -> FCode ()
load_fvs LocalReg
node LambdaFormInfo
lf_info [(LocalReg, Int)]
fv_bindings
               ; FCode ReturnKind -> FCode ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (FCode ReturnKind -> FCode ()) -> FCode ReturnKind -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgStgExpr -> FCode ReturnKind
cgExpr CgStgExpr
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 node_reg :: LocalReg
node_reg
  = CmmExpr -> FCode ()
emitBlackHoleCode (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
node_reg))

emitBlackHoleCode :: CmmExpr -> FCode ()
emitBlackHoleCode :: CmmExpr -> FCode ()
emitBlackHoleCode node :: CmmExpr
node = do
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

  -- 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 CmmParse.

  let  eager_blackholing :: Bool
eager_blackholing =  Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags)
                         Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EagerBlackHoling DynFlags
dflags
             -- Profiling needs slop filling (to support LDV
             -- profiling), so currently eager blackholing doesn't
             -- work with profiling.

  Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
eager_blackholing (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
    CmmExpr -> CmmExpr -> FCode ()
emitStore (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
dflags CmmExpr
node (DynFlags -> Int
fixedHdrSizeW DynFlags
dflags)) CmmExpr
currentTSOExpr
    -- See Note [Heap memory barriers] in SMP.h.
    [LocalReg] -> CallishMachOp -> [CmmExpr] -> FCode ()
emitPrimCall [] CallishMachOp
MO_WriteBarrier []
    CmmExpr -> CmmExpr -> FCode ()
emitStore CmmExpr
node (CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
EagerBlackholeInfo))

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 closure_info :: ClosureInfo
closure_info node :: LocalReg
node body :: 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
          DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
          let
              bh :: Bool
bh = ClosureInfo -> Bool
blackHoleOnEntry ClosureInfo
closure_info Bool -> Bool -> Bool
&&
                   Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags) Bool -> Bool -> Bool
&&
                   GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EagerBlackHoling DynFlags
dflags

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

          CLabel -> CmmExpr -> FCode () -> FCode ()
pushUpdateFrame CLabel
lbl (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
node)) FCode ()
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:
                { CmmExpr
upd_closure <- LocalReg -> Bool -> FCode CmmExpr
link_caf LocalReg
node Bool
True
                ; CLabel -> CmmExpr -> FCode () -> FCode ()
pushUpdateFrame CLabel
mkBHUpdInfoLabel CmmExpr
upd_closure FCode ()
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 lbl :: CLabel
lbl updatee :: CmmExpr
updatee body :: FCode ()
body
  = do
       Int
updfr  <- FCode Int
getUpdFrameOff
       DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let
           hdr :: Int
hdr         = DynFlags -> Int
fixedHdrSize DynFlags
dflags
           frame :: Int
frame       = Int
updfr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hdr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DynFlags -> Int
sIZEOF_StgUpdateFrame_NoHdr DynFlags
dflags
       --
       DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()
emitUpdateFrame DynFlags
dflags (Area -> Int -> CmmExpr
CmmStackSlot Area
Old Int
frame) CLabel
lbl CmmExpr
updatee
       Int -> FCode () -> FCode ()
forall a. Int -> FCode a -> FCode a
withUpdFrameOff Int
frame FCode ()
body

emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()
emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()
emitUpdateFrame dflags :: DynFlags
dflags frame :: CmmExpr
frame lbl :: CLabel
lbl updatee :: CmmExpr
updatee = do
  let
           hdr :: Int
hdr         = DynFlags -> Int
fixedHdrSize DynFlags
dflags
           off_updatee :: Int
off_updatee = Int
hdr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DynFlags -> Int
oFFSET_StgUpdateFrame_updatee DynFlags
dflags
  --
  CmmExpr -> CmmExpr -> FCode ()
emitStore CmmExpr
frame (CLabel -> CmmExpr
mkLblExpr CLabel
lbl)
  CmmExpr -> CmmExpr -> FCode ()
emitStore (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
frame Int
off_updatee) CmmExpr
updatee
  CmmExpr -> FCode ()
initUpdFrameProf CmmExpr
frame

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

link_caf :: LocalReg           -- pointer to the closure
         -> Bool               -- True <=> updatable, False <=> single-entry
         -> 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 -> Bool -> FCode CmmExpr
link_caf node :: LocalReg
node _is_upd :: Bool
_is_upd = do
  { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        -- Call the RTS function newCAF, returning the newly-allocated
        -- blackhole indirection closure
  ; let newCAF_lbl :: CLabel
newCAF_lbl = FastString
-> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel (String -> FastString
fsLit "newCAF") Maybe Int
forall a. Maybe a
Nothing
                                    ForeignLabelSource
ForeignLabelInExternalPackage FunctionOrData
IsFunction
  ; LocalReg
bh <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
dflags)
  ; [(LocalReg, ForeignHint)]
-> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCallGen [(LocalReg
bh,ForeignHint
AddrHint)] CLabel
newCAF_lbl
      [ (CmmExpr
baseExpr,  ForeignHint
AddrHint),
        (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
node), ForeignHint
AddrHint) ]
      Bool
False

  -- see Note [atomic CAF entry] in rts/sm/Storage.c
  ; Int
updfr  <- FCode Int
getUpdFrameOff
  ; let target :: CmmExpr
target = DynFlags -> CmmExpr -> CmmExpr
entryCode DynFlags
dflags (DynFlags -> CmmExpr -> CmmExpr
closureInfoPtr DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
node)))
  ; CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThen
      (DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmEqWord DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
bh)) (DynFlags -> CmmExpr
zeroExpr DynFlags
dflags))
        -- re-enter the CAF
       (DynFlags -> Convention -> CmmExpr -> [CmmExpr] -> Int -> CmmAGraph
mkJump DynFlags
dflags Convention
NativeNodeCall CmmExpr
target [] Int
updfr)

  ; CmmExpr -> FCode CmmExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
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 :: DynFlags
           -> 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 :: DynFlags -> Module -> Name -> String
closureDescription dflags :: DynFlags
dflags mod_name :: Module
mod_name name :: Name
name
  = DynFlags -> SDoc -> String
showSDocDump DynFlags
dflags (Char -> SDoc
char '<' SDoc -> SDoc -> SDoc
<>
                    (if Name -> Bool
isExternalName Name
name
                      then Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name -- ppr will include the module name prefix
                      else Module -> SDoc
pprModule Module
mod_name SDoc -> SDoc -> SDoc
<> Char -> SDoc
char '.' SDoc -> SDoc -> SDoc
<> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<>
                    Char -> SDoc
char '>')
   -- showSDocDump, because we want to see the unique on the Name.