never executed always true always false
    1 -----------------------------------------------------------------------------
    2 --
    3 -- Stg to C-- code generation: bindings
    4 --
    5 -- (c) The University of Glasgow 2004-2006
    6 --
    7 -----------------------------------------------------------------------------
    8 
    9 module GHC.StgToCmm.Bind (
   10         cgTopRhsClosure,
   11         cgBind,
   12         emitBlackHoleCode,
   13         pushUpdateFrame, emitUpdateFrame
   14   ) where
   15 
   16 import GHC.Prelude hiding ((<*>))
   17 
   18 import GHC.Driver.Session
   19 
   20 import GHC.Core          ( AltCon(..) )
   21 import GHC.Runtime.Heap.Layout
   22 import GHC.Unit.Module
   23 
   24 import GHC.Stg.Syntax
   25 
   26 import GHC.Platform
   27 import GHC.Platform.Profile
   28 
   29 import GHC.StgToCmm.Expr
   30 import GHC.StgToCmm.Monad
   31 import GHC.StgToCmm.Env
   32 import GHC.StgToCmm.DataCon
   33 import GHC.StgToCmm.Heap
   34 import GHC.StgToCmm.Prof (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
   35                    initUpdFrameProf)
   36 import GHC.StgToCmm.Ticky
   37 import GHC.StgToCmm.Layout
   38 import GHC.StgToCmm.Utils
   39 import GHC.StgToCmm.Closure
   40 import GHC.StgToCmm.Foreign    (emitPrimCall)
   41 
   42 import GHC.Cmm.Graph
   43 import GHC.Cmm.BlockId
   44 import GHC.Cmm
   45 import GHC.Cmm.Info
   46 import GHC.Cmm.Utils
   47 import GHC.Cmm.CLabel
   48 
   49 import GHC.Types.CostCentre
   50 import GHC.Types.Id
   51 import GHC.Types.Id.Info
   52 import GHC.Types.Name
   53 import GHC.Types.Var.Set
   54 import GHC.Types.Basic
   55 import GHC.Types.Tickish ( tickishIsCode )
   56 
   57 import GHC.Utils.Misc
   58 import GHC.Utils.Outputable
   59 import GHC.Utils.Panic
   60 
   61 import GHC.Data.FastString
   62 import GHC.Data.List.SetOps
   63 
   64 import Control.Monad
   65 
   66 ------------------------------------------------------------------------
   67 --              Top-level bindings
   68 ------------------------------------------------------------------------
   69 
   70 -- For closures bound at top level, allocate in static space.
   71 -- They should have no free variables.
   72 
   73 cgTopRhsClosure :: Platform
   74                 -> RecFlag              -- member of a recursive group?
   75                 -> Id
   76                 -> CostCentreStack      -- Optional cost centre annotation
   77                 -> UpdateFlag
   78                 -> [Id]                 -- Args
   79                 -> CgStgExpr
   80                 -> (CgIdInfo, FCode ())
   81 
   82 cgTopRhsClosure platform rec id ccs upd_flag args body =
   83   let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)
   84       cg_id_info    = litIdInfo platform id lf_info (CmmLabel closure_label)
   85       lf_info       = mkClosureLFInfo platform id TopLevel [] upd_flag args
   86   in (cg_id_info, gen_code lf_info closure_label)
   87   where
   88   -- special case for a indirection (f = g).  We create an IND_STATIC
   89   -- closure pointing directly to the indirectee.  This is exactly
   90   -- what the CAF will eventually evaluate to anyway, we're just
   91   -- shortcutting the whole process, and generating a lot less code
   92   -- (#7308). Eventually the IND_STATIC closure will be eliminated
   93   -- by assembly '.equiv' directives, where possible (#15155).
   94   -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
   95   --
   96   -- Note: we omit the optimisation when this binding is part of a
   97   -- recursive group, because the optimisation would inhibit the black
   98   -- hole detection from working in that case.  Test
   99   -- concurrent/should_run/4030 fails, for instance.
  100   --
  101   gen_code _ closure_label
  102     | StgApp f [] <- body, null args, isNonRec rec
  103     = do
  104          cg_info <- getCgIdInfo f
  105          emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)]
  106 
  107   gen_code lf_info _closure_label
  108    = do { profile <- getProfile
  109         ; dflags <- getDynFlags
  110         ; let name = idName id
  111         ; mod_name <- getModuleName
  112         ; let descr         = closureDescription dflags mod_name name
  113               closure_info  = mkClosureInfo profile True id lf_info 0 0 descr
  114 
  115         -- We don't generate the static closure here, because we might
  116         -- want to add references to static closures to it later.  The
  117         -- static closure is generated by GHC.Cmm.Info.Build.updInfoSRTs,
  118         -- See Note [SRTs], specifically the [FUN] optimisation.
  119 
  120         ; let fv_details :: [(NonVoid Id, ByteOff)]
  121               header = if isLFThunk lf_info then ThunkHeader else StdHeader
  122               (_, _, fv_details) = mkVirtHeapOffsets profile header []
  123         -- Don't drop the non-void args until the closure info has been made
  124         ; forkClosureBody (closureCodeBody True id closure_info ccs
  125                                 args body fv_details)
  126 
  127         ; return () }
  128 
  129   unLit (CmmLit l) = l
  130   unLit _ = panic "unLit"
  131 
  132 ------------------------------------------------------------------------
  133 --              Non-top-level bindings
  134 ------------------------------------------------------------------------
  135 
  136 cgBind :: CgStgBinding -> FCode ()
  137 cgBind (StgNonRec name rhs)
  138   = do  { (info, fcode) <- cgRhs name rhs
  139         ; addBindC info
  140         ; init <- fcode
  141         ; emit init }
  142         -- init cannot be used in body, so slightly better to sink it eagerly
  143 
  144 cgBind (StgRec pairs)
  145   = do  {  r <- sequence $ unzipWith cgRhs pairs
  146         ;  let (id_infos, fcodes) = unzip r
  147         ;  addBindsC id_infos
  148         ;  (inits, body) <- getCodeR $ sequence fcodes
  149         ;  emit (catAGraphs inits <*> body) }
  150 
  151 {- Note [cgBind rec]
  152 
  153    Recursive let-bindings are tricky.
  154    Consider the following pseudocode:
  155 
  156      let x = \_ ->  ... y ...
  157          y = \_ ->  ... z ...
  158          z = \_ ->  ... x ...
  159      in ...
  160 
  161    For each binding, we need to allocate a closure, and each closure must
  162    capture the address of the other closures.
  163    We want to generate the following C-- code:
  164      // Initialization Code
  165      x = hp - 24; // heap address of x's closure
  166      y = hp - 40; // heap address of x's closure
  167      z = hp - 64; // heap address of x's closure
  168      // allocate and initialize x
  169      m[hp-8]   = ...
  170      m[hp-16]  = y       // the closure for x captures y
  171      m[hp-24] = x_info;
  172      // allocate and initialize y
  173      m[hp-32] = z;       // the closure for y captures z
  174      m[hp-40] = y_info;
  175      // allocate and initialize z
  176      ...
  177 
  178    For each closure, we must generate not only the code to allocate and
  179    initialize the closure itself, but also some initialization Code that
  180    sets a variable holding the closure pointer.
  181 
  182    We could generate a pair of the (init code, body code), but since
  183    the bindings are recursive we also have to initialise the
  184    environment with the CgIdInfo for all the bindings before compiling
  185    anything.  So we do this in 3 stages:
  186 
  187      1. collect all the CgIdInfos and initialise the environment
  188      2. compile each binding into (init, body) code
  189      3. emit all the inits, and then all the bodies
  190 
  191    We'd rather not have separate functions to do steps 1 and 2 for
  192    each binding, since in practice they share a lot of code.  So we
  193    have just one function, cgRhs, that returns a pair of the CgIdInfo
  194    for step 1, and a monadic computation to generate the code in step
  195    2.
  196 
  197    The alternative to separating things in this way is to use a
  198    fixpoint.  That's what we used to do, but it introduces a
  199    maintenance nightmare because there is a subtle dependency on not
  200    being too strict everywhere.  Doing things this way means that the
  201    FCode monad can be strict, for example.
  202  -}
  203 
  204 cgRhs :: Id
  205       -> CgStgRhs
  206       -> FCode (
  207                  CgIdInfo         -- The info for this binding
  208                , FCode CmmAGraph  -- A computation which will generate the
  209                                   -- code for the binding, and return an
  210                                   -- assignment of the form "x = Hp - n"
  211                                   -- (see above)
  212                )
  213 
  214 cgRhs id (StgRhsCon cc con mn _ts args)
  215   = withNewTickyCounterCon (idName id) con $
  216     buildDynCon id mn True cc con (assertNonVoidStgArgs args)
  217       -- con args are always non-void,
  218       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
  219 
  220 {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -}
  221 cgRhs id (StgRhsClosure fvs cc upd_flag args body)
  222   = do profile <- getProfile
  223        mkRhsClosure profile id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body
  224 
  225 ------------------------------------------------------------------------
  226 --              Non-constructor right hand sides
  227 ------------------------------------------------------------------------
  228 
  229 mkRhsClosure :: Profile -> Id -> CostCentreStack
  230              -> [NonVoid Id]                    -- Free vars
  231              -> UpdateFlag
  232              -> [Id]                            -- Args
  233              -> CgStgExpr
  234              -> FCode (CgIdInfo, FCode CmmAGraph)
  235 
  236 {- mkRhsClosure looks for two special forms of the right-hand side:
  237         a) selector thunks
  238         b) AP thunks
  239 
  240 If neither happens, it just calls mkClosureLFInfo.  You might think
  241 that mkClosureLFInfo should do all this, but it seems wrong for the
  242 latter to look at the structure of an expression
  243 
  244 Note [Selectors]
  245 ~~~~~~~~~~~~~~~~
  246 We look at the body of the closure to see if it's a selector---turgid,
  247 but nothing deep.  We are looking for a closure of {\em exactly} the
  248 form:
  249 
  250 ...  = [the_fv] \ u [] ->
  251          case the_fv of
  252            con a_1 ... a_n -> a_i
  253 
  254 Note [Ap thunks]
  255 ~~~~~~~~~~~~~~~~
  256 A more generic AP thunk of the form
  257 
  258         x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
  259 
  260 A set of these is compiled statically into the RTS, so we just use
  261 those.  We could extend the idea to thunks where some of the x_i are
  262 global ids (and hence not free variables), but this would entail
  263 generating a larger thunk.  It might be an option for non-optimising
  264 compilation, though.
  265 
  266 We only generate an Ap thunk if all the free variables are pointers,
  267 for semi-obvious reasons.
  268 
  269 -}
  270 
  271 ---------- Note [Selectors] ------------------
  272 mkRhsClosure    profile bndr _cc
  273                 [NonVoid the_fv]                -- Just one free var
  274                 upd_flag                -- Updatable thunk
  275                 []                      -- A thunk
  276                 expr
  277   | let strip = stripStgTicksTopE (not . tickishIsCode)
  278   , StgCase (StgApp scrutinee [{-no args-}])
  279          _   -- ignore bndr
  280          (AlgAlt _)
  281          [(DataAlt _, params, sel_expr)] <- strip expr
  282   , StgApp selectee [{-no args-}] <- strip sel_expr
  283   , the_fv == scrutinee                -- Scrutinee is the only free variable
  284 
  285   , let (_, _, params_w_offsets) = mkVirtConstrOffsets profile (addIdReps (assertNonVoidIds params))
  286                                    -- pattern binders are always non-void,
  287                                    -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
  288   , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)
  289 
  290   , let offset_into_int = bytesToWordsRoundUp (profilePlatform profile) the_offset
  291                           - fixedHdrSizeW profile
  292   , offset_into_int <= pc_MAX_SPEC_SELECTEE_SIZE (profileConstants profile) -- Offset is small enough
  293   = -- NOT TRUE: assert (is_single_constructor)
  294     -- The simplifier may have statically determined that the single alternative
  295     -- is the only possible case and eliminated the others, even if there are
  296     -- other constructors in the datatype.  It's still ok to make a selector
  297     -- thunk in this case, because we *know* which constructor the scrutinee
  298     -- will evaluate to.
  299     --
  300     -- srt is discarded; it must be empty
  301     let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
  302     in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
  303 
  304 ---------- Note [Ap thunks] ------------------
  305 mkRhsClosure    profile bndr _cc
  306                 fvs
  307                 upd_flag
  308                 []                      -- No args; a thunk
  309                 (StgApp fun_id args)
  310 
  311   -- We are looking for an "ApThunk"; see data con ApThunk in GHC.StgToCmm.Closure
  312   -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)
  313   -- So the xi will all be free variables
  314   | args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and
  315                                -- args are all distinct local variables
  316                                -- The "-1" is for fun_id
  317     -- Missed opportunity:   (f x x) is not detected
  318   , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs
  319   , isUpdatable upd_flag
  320   , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile)
  321   , not (profileIsProfiling profile)
  322                          -- not when profiling: we don't want to
  323                          -- lose information about this particular
  324                          -- thunk (e.g. its type) (#949)
  325   , idArity fun_id == unknownArity -- don't spoil a known call
  326 
  327           -- Ha! an Ap thunk
  328   = cgRhsStdThunk bndr lf_info payload
  329 
  330   where
  331     n_fvs   = length fvs
  332     lf_info = mkApLFInfo bndr upd_flag n_fvs
  333     -- the payload has to be in the correct order, hence we can't
  334     -- just use the fvs.
  335     payload = StgVarArg fun_id : args
  336 
  337 ---------- Default case ------------------
  338 mkRhsClosure profile bndr cc fvs upd_flag args body
  339   = do  { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args
  340         ; (id_info, reg) <- rhsIdInfo bndr lf_info
  341         ; return (id_info, gen_code lf_info reg) }
  342  where
  343  gen_code lf_info reg
  344   = do  {       -- LAY OUT THE OBJECT
  345         -- If the binder is itself a free variable, then don't store
  346         -- it in the closure.  Instead, just bind it to Node on entry.
  347         -- NB we can be sure that Node will point to it, because we
  348         -- haven't told mkClosureLFInfo about this; so if the binder
  349         -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
  350         -- stored in the closure itself, so it will make sure that
  351         -- Node points to it...
  352         ; let   reduced_fvs = filter (NonVoid bndr /=) fvs
  353 
  354         ; profile <- getProfile
  355         ; let platform = profilePlatform profile
  356 
  357         -- MAKE CLOSURE INFO FOR THIS CLOSURE
  358         ; mod_name <- getModuleName
  359         ; dflags <- getDynFlags
  360         ; let   name  = idName bndr
  361                 descr = closureDescription dflags mod_name name
  362                 fv_details :: [(NonVoid Id, ByteOff)]
  363                 header = if isLFThunk lf_info then ThunkHeader else StdHeader
  364                 (tot_wds, ptr_wds, fv_details)
  365                    = mkVirtHeapOffsets profile header (addIdReps reduced_fvs)
  366                 closure_info = mkClosureInfo profile False       -- Not static
  367                                              bndr lf_info tot_wds ptr_wds
  368                                              descr
  369 
  370         -- BUILD ITS INFO TABLE AND CODE
  371         ; forkClosureBody $
  372                 -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
  373                 --                  (b) ignore Sequel from context; use empty Sequel
  374                 -- And compile the body
  375                 closureCodeBody False bndr closure_info cc args
  376                                 body fv_details
  377 
  378         -- BUILD THE OBJECT
  379 --      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
  380         ; let use_cc = cccsExpr; blame_cc = cccsExpr
  381         ; emit (mkComment $ mkFastString "calling allocDynClosure")
  382         ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
  383         ; let info_tbl = mkCmmInfo closure_info bndr currentCCS
  384         ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc
  385                                          (map toVarArg fv_details)
  386 
  387         -- RETURN
  388         ; return (mkRhsInit platform reg lf_info hp_plus_n) }
  389 
  390 -------------------------
  391 cgRhsStdThunk
  392         :: Id
  393         -> LambdaFormInfo
  394         -> [StgArg]             -- payload
  395         -> FCode (CgIdInfo, FCode CmmAGraph)
  396 
  397 cgRhsStdThunk bndr lf_info payload
  398  = do  { (id_info, reg) <- rhsIdInfo bndr lf_info
  399        ; return (id_info, gen_code reg)
  400        }
  401  where
  402  gen_code reg  -- AHA!  A STANDARD-FORM THUNK
  403   = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $
  404     do
  405   {     -- LAY OUT THE OBJECT
  406     mod_name <- getModuleName
  407   ; dflags <- getDynFlags
  408   ; profile <- getProfile
  409   ; let platform = profilePlatform profile
  410         header = if isLFThunk lf_info then ThunkHeader else StdHeader
  411         (tot_wds, ptr_wds, payload_w_offsets)
  412             = mkVirtHeapOffsets profile header
  413                 (addArgReps (nonVoidStgArgs payload))
  414 
  415         descr = closureDescription dflags mod_name (idName bndr)
  416         closure_info = mkClosureInfo profile False       -- Not static
  417                                      bndr lf_info tot_wds ptr_wds
  418                                      descr
  419 
  420 --  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
  421   ; let use_cc = cccsExpr; blame_cc = cccsExpr
  422 
  423 
  424         -- BUILD THE OBJECT
  425   ; let info_tbl = mkCmmInfo closure_info bndr currentCCS
  426   ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info
  427                                    use_cc blame_cc payload_w_offsets
  428 
  429         -- RETURN
  430   ; return (mkRhsInit platform reg lf_info hp_plus_n) }
  431 
  432 
  433 mkClosureLFInfo :: Platform
  434                 -> Id           -- The binder
  435                 -> TopLevelFlag -- True of top level
  436                 -> [NonVoid Id] -- Free vars
  437                 -> UpdateFlag   -- Update flag
  438                 -> [Id]         -- Args
  439                 -> LambdaFormInfo
  440 mkClosureLFInfo platform bndr top fvs upd_flag args
  441   | null args =
  442         mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag
  443   | otherwise =
  444         mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr platform args)
  445 
  446 
  447 ------------------------------------------------------------------------
  448 --              The code for closures
  449 ------------------------------------------------------------------------
  450 
  451 closureCodeBody :: Bool            -- whether this is a top-level binding
  452                 -> Id              -- the closure's name
  453                 -> ClosureInfo     -- Lots of information about this closure
  454                 -> CostCentreStack -- Optional cost centre attached to closure
  455                 -> [Id]            -- incoming args to the closure
  456                 -> CgStgExpr
  457                 -> [(NonVoid Id, ByteOff)] -- the closure's free vars
  458                 -> FCode ()
  459 
  460 {- There are two main cases for the code for closures.
  461 
  462 * If there are *no arguments*, then the closure is a thunk, and not in
  463   normal form. So it should set up an update frame (if it is
  464   shared). NB: Thunks cannot have a primitive type!
  465 
  466 * If there is *at least one* argument, then this closure is in
  467   normal form, so there is no need to set up an update frame.
  468 -}
  469 
  470 -- No args i.e. thunk
  471 closureCodeBody top_lvl bndr cl_info cc [] body fv_details
  472   = withNewTickyCounterThunk
  473         (isStaticClosure cl_info)
  474         (closureUpdReqd cl_info)
  475         (closureName cl_info) $
  476     emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
  477       \(_, node, _) -> thunkCode cl_info fv_details cc node body
  478    where
  479      lf_info  = closureLFInfo cl_info
  480      info_tbl = mkCmmInfo cl_info bndr cc
  481 
  482 closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details
  483   = let nv_args = nonVoidIds args
  484         arity = length args
  485     in
  486     -- See Note [OneShotInfo overview] in GHC.Types.Basic.
  487     withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info)
  488         nv_args $ do {
  489 
  490         ; let
  491              lf_info  = closureLFInfo cl_info
  492              info_tbl = mkCmmInfo cl_info bndr cc
  493 
  494         -- Emit the main entry code
  495         ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl nv_args $
  496             \(_offset, node, arg_regs) -> do
  497                 -- Emit slow-entry code (for entering a closure through a PAP)
  498                 { mkSlowEntryCode bndr cl_info arg_regs
  499                 ; profile <- getProfile
  500                 ; platform <- getPlatform
  501                 ; let node_points = nodeMustPointToIt profile lf_info
  502                       node' = if node_points then Just node else Nothing
  503                 ; loop_header_id <- newBlockId
  504                 -- Extend reader monad with information that
  505                 -- self-recursive tail calls can be optimized into local
  506                 -- jumps. See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr.
  507                 ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do
  508                 {
  509                 -- Main payload
  510                 ; entryHeapCheck cl_info node' arity arg_regs $ do
  511                 { -- emit LDV code when profiling
  512                   when node_points (ldvEnterClosure cl_info (CmmLocal node))
  513                 -- ticky after heap check to avoid double counting
  514                 ; tickyEnterFun cl_info
  515                 ; enterCostCentreFun cc
  516                     (CmmMachOp (mo_wordSub platform)
  517                          [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
  518                          , mkIntExpr platform (funTag platform cl_info) ])
  519                 ; fv_bindings <- mapM bind_fv fv_details
  520                 -- Load free vars out of closure *after*
  521                 -- heap check, to reduce live vars over check
  522                 ; when node_points $ load_fvs node lf_info fv_bindings
  523                 ; void $ cgExpr body
  524                 }}}
  525 
  526   }
  527 
  528 -- Note [NodeReg clobbered with loopification]
  529 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  530 --
  531 -- Previously we used to pass nodeReg (aka R1) here. With profiling, upon
  532 -- entering a closure, enterFunCCS was called with R1 passed to it. But since R1
  533 -- may get clobbered inside the body of a closure, and since a self-recursive
  534 -- tail call does not restore R1, a subsequent call to enterFunCCS received a
  535 -- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to
  536 -- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores
  537 -- the original value of R1. This way R1 may get modified but loopification will
  538 -- not care.
  539 
  540 -- A function closure pointer may be tagged, so we
  541 -- must take it into account when accessing the free variables.
  542 bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
  543 bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
  544 
  545 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
  546 load_fvs node lf_info = mapM_ (\ (reg, off) ->
  547    do platform <- getPlatform
  548       let tag = lfDynTag platform lf_info
  549       emit $ mkTaggedObjectLoad platform reg node off tag)
  550 
  551 -----------------------------------------
  552 -- The "slow entry" code for a function.  This entry point takes its
  553 -- arguments on the stack.  It loads the arguments into registers
  554 -- according to the calling convention, and jumps to the function's
  555 -- normal entry point.  The function's closure is assumed to be in
  556 -- R1/node.
  557 --
  558 -- The slow entry point is used for unknown calls: eg. stg_PAP_entry
  559 
  560 mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
  561 -- If this function doesn't have a specialised ArgDescr, we need
  562 -- to generate the function's arg bitmap and slow-entry code.
  563 -- Here, we emit the slow-entry code.
  564 mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
  565   | Just (_, ArgGen _) <- closureFunInfo cl_info
  566   = do profile <- getProfile
  567        platform <- getPlatform
  568        let node = idToReg platform (NonVoid bndr)
  569            slow_lbl = closureSlowEntryLabel  platform cl_info
  570            fast_lbl = closureLocalEntryLabel platform cl_info
  571            -- mkDirectJump does not clobber `Node' containing function closure
  572            jump = mkJump profile NativeNodeCall
  573                                 (mkLblExpr fast_lbl)
  574                                 (map (CmmReg . CmmLocal) (node : arg_regs))
  575                                 (initUpdFrameOff platform)
  576        tscope <- getTickScope
  577        emitProcWithConvention Slow Nothing slow_lbl
  578          (node : arg_regs) (jump, tscope)
  579   | otherwise = return ()
  580 
  581 -----------------------------------------
  582 thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
  583           -> LocalReg -> CgStgExpr -> FCode ()
  584 thunkCode cl_info fv_details _cc node body
  585   = do { profile <- getProfile
  586        ; let node_points = nodeMustPointToIt profile (closureLFInfo cl_info)
  587              node'       = if node_points then Just node else Nothing
  588         ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling
  589 
  590         -- Heap overflow check
  591         ; entryHeapCheck cl_info node' 0 [] $ do
  592         { -- Overwrite with black hole if necessary
  593           -- but *after* the heap-overflow check
  594         ; tickyEnterThunk cl_info
  595         ; when (blackHoleOnEntry cl_info && node_points)
  596                 (blackHoleIt node)
  597 
  598           -- Push update frame
  599         ; setupUpdate cl_info node $
  600             -- We only enter cc after setting up update so
  601             -- that cc of enclosing scope will be recorded
  602             -- in update frame CAF/DICT functions will be
  603             -- subsumed by this enclosing cc
  604             do { enterCostCentreThunk (CmmReg nodeReg)
  605                ; let lf_info = closureLFInfo cl_info
  606                ; fv_bindings <- mapM bind_fv fv_details
  607                ; load_fvs node lf_info fv_bindings
  608                ; void $ cgExpr body }}}
  609 
  610 
  611 ------------------------------------------------------------------------
  612 --              Update and black-hole wrappers
  613 ------------------------------------------------------------------------
  614 
  615 blackHoleIt :: LocalReg -> FCode ()
  616 -- Only called for closures with no args
  617 -- Node points to the closure
  618 blackHoleIt node_reg
  619   = emitBlackHoleCode (CmmReg (CmmLocal node_reg))
  620 
  621 emitBlackHoleCode :: CmmExpr -> FCode ()
  622 emitBlackHoleCode node = do
  623   dflags <- getDynFlags
  624   profile <- getProfile
  625   let platform = profilePlatform profile
  626 
  627   -- Eager blackholing is normally disabled, but can be turned on with
  628   -- -feager-blackholing.  When it is on, we replace the info pointer
  629   -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.
  630 
  631   -- If we wanted to do eager blackholing with slop filling, we'd need
  632   -- to do it at the *end* of a basic block, otherwise we overwrite
  633   -- the free variables in the thunk that we still need.  We have a
  634   -- patch for this from Andy Cheadle, but not incorporated yet. --SDM
  635   -- [6/2004]
  636   --
  637   -- Previously, eager blackholing was enabled when ticky-ticky was
  638   -- on. But it didn't work, and it wasn't strictly necessary to bring
  639   -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is
  640   -- unconditionally disabled. -- krc 1/2007
  641 
  642   -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
  643   -- because emitBlackHoleCode is called from GHC.Cmm.Parser.
  644 
  645   let  eager_blackholing =  not (profileIsProfiling profile)
  646                          && gopt Opt_EagerBlackHoling dflags
  647              -- Profiling needs slop filling (to support LDV
  648              -- profiling), so currently eager blackholing doesn't
  649              -- work with profiling.
  650 
  651   when eager_blackholing $ do
  652     whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node
  653     emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) currentTSOExpr
  654     -- See Note [Heap memory barriers] in SMP.h.
  655     emitPrimCall [] MO_WriteBarrier []
  656     emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
  657 
  658 setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
  659         -- Nota Bene: this function does not change Node (even if it's a CAF),
  660         -- so that the cost centre in the original closure can still be
  661         -- extracted by a subsequent enterCostCentre
  662 setupUpdate closure_info node body
  663   | not (lfUpdatable (closureLFInfo closure_info))
  664   = body
  665 
  666   | not (isStaticClosure closure_info)
  667   = if not (closureUpdReqd closure_info)
  668       then do tickyUpdateFrameOmitted; body
  669       else do
  670           tickyPushUpdateFrame
  671           dflags <- getDynFlags
  672           let
  673               bh = blackHoleOnEntry closure_info &&
  674                    not (sccProfilingEnabled dflags) &&
  675                    gopt Opt_EagerBlackHoling dflags
  676 
  677               lbl | bh        = mkBHUpdInfoLabel
  678                   | otherwise = mkUpdInfoLabel
  679 
  680           pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
  681 
  682   | otherwise   -- A static closure
  683   = do  { tickyUpdateBhCaf closure_info
  684 
  685         ; if closureUpdReqd closure_info
  686           then do       -- Blackhole the (updatable) CAF:
  687                 { upd_closure <- link_caf node
  688                 ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
  689           else do {tickyUpdateFrameOmitted; body}
  690     }
  691 
  692 -----------------------------------------------------------------------------
  693 -- Setting up update frames
  694 
  695 -- Push the update frame on the stack in the Entry area,
  696 -- leaving room for the return address that is already
  697 -- at the old end of the area.
  698 --
  699 pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()
  700 pushUpdateFrame lbl updatee body
  701   = do
  702        updfr  <- getUpdFrameOff
  703        profile <- getProfile
  704        let
  705            hdr         = fixedHdrSize profile
  706            frame       = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile)
  707        --
  708        emitUpdateFrame (CmmStackSlot Old frame) lbl updatee
  709        withUpdFrameOff frame body
  710 
  711 emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode ()
  712 emitUpdateFrame frame lbl updatee = do
  713   profile <- getProfile
  714   let
  715            hdr         = fixedHdrSize profile
  716            off_updatee = hdr + pc_OFFSET_StgUpdateFrame_updatee (platformConstants platform)
  717            platform    = profilePlatform profile
  718   --
  719   emitStore frame (mkLblExpr lbl)
  720   emitStore (cmmOffset platform frame off_updatee) updatee
  721   initUpdFrameProf frame
  722 
  723 -----------------------------------------------------------------------------
  724 -- Entering a CAF
  725 --
  726 -- See Note [CAF management] in rts/sm/Storage.c
  727 
  728 link_caf :: LocalReg           -- pointer to the closure
  729          -> FCode CmmExpr      -- Returns amode for closure to be updated
  730 -- This function returns the address of the black hole, so it can be
  731 -- updated with the new value when available.
  732 link_caf node = do
  733   { profile <- getProfile
  734         -- Call the RTS function newCAF, returning the newly-allocated
  735         -- blackhole indirection closure
  736   ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing
  737                                     ForeignLabelInExternalPackage IsFunction
  738   ; let platform = profilePlatform profile
  739   ; bh <- newTemp (bWord platform)
  740   ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl
  741       [ (baseExpr,  AddrHint),
  742         (CmmReg (CmmLocal node), AddrHint) ]
  743       False
  744 
  745   -- see Note [atomic CAF entry] in rts/sm/Storage.c
  746   ; updfr  <- getUpdFrameOff
  747   ; ptr_opts <- getPtrOpts
  748   ; let target = entryCode platform (closureInfoPtr ptr_opts (CmmReg (CmmLocal node)))
  749   ; emit =<< mkCmmIfThen
  750       (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform))
  751         -- re-enter the CAF
  752        (mkJump profile NativeNodeCall target [] updfr)
  753 
  754   ; return (CmmReg (CmmLocal bh)) }
  755 
  756 ------------------------------------------------------------------------
  757 --              Profiling
  758 ------------------------------------------------------------------------
  759 
  760 -- For "global" data constructors the description is simply occurrence
  761 -- name of the data constructor itself.  Otherwise it is determined by
  762 -- @closureDescription@ from the let binding information.
  763 
  764 closureDescription
  765    :: DynFlags
  766    -> Module            -- Module
  767    -> Name              -- Id of closure binding
  768    -> String
  769         -- Not called for StgRhsCon which have global info tables built in
  770         -- CgConTbls.hs with a description generated from the data constructor
  771 closureDescription dflags mod_name name
  772   = let ctx = initSDocContext dflags defaultDumpStyle
  773     -- defaultDumpStyle, because we want to see the unique on the Name.
  774     in renderWithContext ctx (char '<' <>
  775                     (if isExternalName name
  776                       then ppr name -- ppr will include the module name prefix
  777                       else pprModule mod_name <> char '.' <> ppr name) <>
  778                     char '>')