StgCmmBind.hs 27.4 KB
Newer Older
1 2 3 4 5 6 7 8
-----------------------------------------------------------------------------
--
-- Stg to C-- code generation: bindings
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

Ian Lynagh's avatar
Ian Lynagh committed
9 10 11 12 13 14 15
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

16 17
module StgCmmBind (
	cgTopRhsClosure,
18
	cgBind,
19 20
	emitBlackHoleCode,
        pushUpdateFrame
21 22 23 24
  ) where

#include "HsVersions.h"

25
import StgCmmExpr
26 27 28 29 30 31 32 33 34 35
import StgCmmMonad
import StgCmmEnv
import StgCmmCon
import StgCmmHeap
import StgCmmProf
import StgCmmTicky
import StgCmmGran
import StgCmmLayout
import StgCmmUtils
import StgCmmClosure
36
import StgCmmForeign    (emitPrimCall)
37

38
import MkGraph
39 40
import CoreSyn		( AltCon(..) )
import SMRep
41
import Cmm
42 43 44
import CmmUtils
import CLabel
import StgSyn
45
import CostCentre
46
import Id
47
import Control.Monad
48 49 50 51 52 53 54 55 56
import Name
import Module
import ListSetOps
import Util
import BasicTypes
import Constants
import Outputable
import FastString
import Maybes
57
import DynFlags
58 59 60 61 62 63 64 65 66 67 68 69

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

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

cgTopRhsClosure :: Id
		-> CostCentreStack	-- Optional cost centre annotation
		-> StgBinderInfo
		-> UpdateFlag
70
                -> [Id]                 -- Args
71
		-> StgExpr
72
		-> FCode CgIdInfo
73

74
cgTopRhsClosure id ccs _ upd_flag args body = do
75 76
  {	-- LAY OUT THE OBJECT
    let name = idName id
Simon Marlow's avatar
Simon Marlow committed
77
  ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
78
  ; mod_name <- getModuleName
79 80
  ; dflags   <- getDynFlags
  ; let descr         = closureDescription dflags mod_name name
81
        closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr
82
        closure_label = mkLocalClosureLabel name (idCafInfo id)
83
    	cg_id_info    = litIdInfo id lf_info (CmmLabel closure_label)
84
        caffy         = idCafInfo id
85
        info_tbl      = mkCmmInfo closure_info -- XXX short-cut
86
        closure_rep   = mkStaticClosureFields dflags info_tbl ccs caffy []
87 88 89

  	 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
  ; emitDataLits closure_label closure_rep
90
  ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
91
	(_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info)
92 93
				               (addIdReps [])
  -- Don't drop the non-void args until the closure info has been made
94
  ; forkClosureBody (closureCodeBody True id closure_info ccs
95
                                     (nonVoidIds args) (length args) body fv_details)
96

97
  ; returnFC cg_id_info }
98 99 100 101 102 103 104

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

cgBind :: StgBinding -> FCode ()
cgBind (StgNonRec name rhs)
105 106 107
  = do	{ ((info, init), body) <- getCodeR $ cgRhs name rhs
        ; addBindC (cg_id info) info
        ; emit (init <*> body) }
108 109

cgBind (StgRec pairs)
110
  = do  { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
111 112 113 114 115
               do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
                  ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
       ; addBindsC new_binds
       ; emit (catAGraphs inits <*> body) }

116 117
{- Note [cgBind rec]
   Recursive let-bindings are tricky.
118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138
   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
     ...
139

140 141 142 143 144 145 146 147 148 149 150 151 152
   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.
   The complication here is that we don't know the heap offsets a priori,
   which has two consequences:
     1. we need a fixpoint
     2. we can't trivially separate the Initialization Code from the
        code that compiles the right-hand-sides

   Note: We don't need this complication with let-no-escapes, because
   in that case, the names are bound to labels in the environment,
   and we don't need to emit any code to witness that binding.
-}
153 154

--------------------
155
cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph)
156
   -- The Id is passed along so a binding can be set up
157 158
   -- The returned values are the binding for the environment
   -- and the Initialization Code that witnesses the binding
159

160 161
cgRhs name (StgRhsCon cc con args)
  = buildDynCon name cc con args
162

Simon Marlow's avatar
Simon Marlow committed
163
cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body)
164 165
  = do dflags <- getDynFlags
       mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body
166 167 168 169 170

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

171
mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo
172
	     -> [NonVoid Id]			-- Free vars
Simon Marlow's avatar
Simon Marlow committed
173
             -> UpdateFlag
174
	     -> [Id]			        -- Args
175
	     -> StgExpr
176
	     -> FCode (CgIdInfo, CmmAGraph)
177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213

{- 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] ------------------
214
mkRhsClosure	dflags bndr cc bi
215
		[NonVoid the_fv]   		-- Just one free var
216
		upd_flag		-- Updatable thunk
Simon Marlow's avatar
Simon Marlow committed
217
                []                      -- A thunk
218 219 220
		body@(StgCase (StgApp scrutinee [{-no args-}])
		      _ _ _ _   -- ignore uniq, etc.
		      (AlgAlt _)
221
		      [(DataAlt _, params, _use_mask,
222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237
			    (StgApp selectee [{-no args-}]))])
  |  the_fv == scrutinee		-- Scrutinee is the only free variable
  && maybeToBool maybe_offset		-- Selectee is a component of the tuple
  && offset_into_int <= mAX_SPEC_SELECTEE_SIZE	-- 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
    cgStdThunk bndr cc bi body lf_info [StgVarArg the_fv]
  where
    lf_info 		  = mkSelectorLFInfo bndr offset_into_int
				 (isUpdatable upd_flag)
238
    (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params)
239
			       -- Just want the layout
240
    maybe_offset	  = assocMaybe params_w_offsets (NonVoid selectee)
241
    Just the_offset 	  = maybe_offset
242
    offset_into_int       = the_offset - fixedHdrSize dflags
243 244

---------- Note [Ap thunks] ------------------
245
mkRhsClosure    dflags bndr cc bi
246 247
		fvs
		upd_flag
Simon Marlow's avatar
Simon Marlow committed
248
                []                      -- No args; a thunk
249 250 251
		body@(StgApp fun_id args)

  | args `lengthIs` (arity-1)
252
 	&& all (isGcPtrRep . idPrimRep . stripNV) fvs
253
 	&& isUpdatable upd_flag
254
 	&& arity <= mAX_SPEC_AP_SIZE
255 256
        && not (dopt Opt_SccProfilingOn dflags)
                                  -- not when profiling: we don't want to
257 258
                                  -- lose information about this particular
                                  -- thunk (e.g. its type) (#949)
259

260
                   -- Ha! an Ap thunk
261 262 263 264 265 266 267 268 269
  = cgStdThunk bndr cc bi body lf_info payload
  where
	lf_info = mkApLFInfo bndr upd_flag arity
	-- the payload has to be in the correct order, hence we can't
 	-- just use the fvs.
	payload = StgVarArg fun_id : args
	arity 	= length fvs

---------- Default case ------------------
270
mkRhsClosure _ bndr cc _ fvs upd_flag args body
271 272 273 274
  = 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
275
	-- haven't told mkClosureLFInfo about this; so if the binder
276 277 278 279 280
	-- _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
		is_elem	     = isIn "cgRhsClosure"
281 282
		bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
		reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
283 284
			    | otherwise	   = fvs

285

286 287 288
	-- MAKE CLOSURE INFO FOR THIS CLOSURE
	; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
	; mod_name <- getModuleName
289
        ; dflags <- getDynFlags
Simon Marlow's avatar
Simon Marlow committed
290
        ; let   name  = idName bndr
291 292
                descr = closureDescription dflags mod_name name
                fv_details :: [(NonVoid Id, VirtualHpOffset)]
293
		(tot_wds, ptr_wds, fv_details)
294
		   = mkVirtHeapOffsets dflags (isLFThunk lf_info)
295
				       (addIdReps (map stripNV reduced_fvs))
296
		closure_info = mkClosureInfo dflags False	-- Not static
297
					     bndr lf_info tot_wds ptr_wds
Simon Marlow's avatar
Simon Marlow committed
298
                                             descr
299 300

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

	-- BUILD THE OBJECT
309 310
--      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
        ; let use_cc = curCCS; blame_cc = curCCS
311
        ; emit (mkComment $ mkFastString "calling allocDynClosure")
312
        ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
Simon Marlow's avatar
Simon Marlow committed
313 314
        ; let info_tbl = mkCmmInfo closure_info
        ; (tmp, init) <- allocDynClosure info_tbl lf_info use_cc blame_cc
315
                                         (map toVarArg fv_details)
316

317
	-- RETURN
318
	; regIdInfo bndr lf_info tmp init }
319

320 321 322
-- Use with care; if used inappropriately, it could break invariants.
stripNV :: NonVoid a -> a
stripNV (NonVoid a) = a
323 324 325 326 327 328 329 330 331

-------------------------
cgStdThunk
	:: Id
	-> CostCentreStack	-- Optional cost centre annotation
	-> StgBinderInfo	-- XXX: not used??
	-> StgExpr
	-> LambdaFormInfo
	-> [StgArg]			-- payload
332
	-> FCode (CgIdInfo, CmmAGraph)
333

334
cgStdThunk bndr _cc _bndr_info _body lf_info payload
335 336 337
  = do	-- AHA!  A STANDARD-FORM THUNK
  {	-- LAY OUT THE OBJECT
    mod_name <- getModuleName
338
  ; dflags <- getDynFlags
339
  ; let (tot_wds, ptr_wds, payload_w_offsets)
340
	    = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload)
341

342
	descr = closureDescription dflags mod_name (idName bndr)
343
	closure_info = mkClosureInfo dflags False 	-- Not static
344
				     bndr lf_info tot_wds ptr_wds
Simon Marlow's avatar
Simon Marlow committed
345
                                     descr
346

347 348
--  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
  ; let use_cc = curCCS; blame_cc = curCCS
349 350

	-- BUILD THE OBJECT
Simon Marlow's avatar
Simon Marlow committed
351 352 353
  ; let info_tbl = mkCmmInfo closure_info
  ; (tmp, init) <- allocDynClosure info_tbl lf_info
                                   use_cc blame_cc payload_w_offsets
354 355

	-- RETURN
356
  ; regIdInfo bndr lf_info tmp init }
357 358 359

mkClosureLFInfo :: Id		-- The binder
		-> TopLevelFlag	-- True of top level
360
		-> [NonVoid Id]	-- Free vars
361
		-> UpdateFlag 	-- Update flag
362
		-> [Id]         -- Args
363 364
		-> FCode LambdaFormInfo
mkClosureLFInfo bndr top fvs upd_flag args
365
  | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag)
366
  | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
367
		   ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) }
368 369 370 371 372 373


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

374 375
closureCodeBody :: Bool            -- whether this is a top-level binding
                -> Id              -- the closure's name
376 377
		-> ClosureInfo	   -- Lots of information about this closure
		-> CostCentreStack -- Optional cost centre attached to closure
378 379
	 	-> [NonVoid Id]    -- incoming args to the closure
	 	-> Int             -- arity, including void args
380
		-> StgExpr
381
		-> [(NonVoid Id, VirtualHpOffset)] -- the closure's free vars
382 383
		-> FCode ()

384
{- There are two main cases for the code for closures.
385 386 387 388 389 390 391 392 393

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

  The Macros for GrAnSim are produced at the beginning of the
394
  argSatisfactionCheck (by calling fetchAndReschedule).
395 396
  There info if Node points to closure is available. -- HWL -}

397
closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
398
  | length args == 0 -- No args i.e. thunk
399
  = emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
400
      \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
401 402 403
   where
     lf_info  = closureLFInfo cl_info
     info_tbl = mkCmmInfo cl_info
404

405
closureCodeBody top_lvl bndr cl_info _cc args arity body fv_details
406
  = ASSERT( length args > 0 )
407 408 409
    do  { -- Allocate the global ticky counter,
          -- and establish the ticky-counter
          -- label for this block
410
          let ticky_ctr_lbl = closureRednCountsLabel cl_info
411 412 413
        ; emitTickyCounter cl_info (map stripNV args)
        ; setTickyCtrLabel ticky_ctr_lbl $ do

414 415 416 417
        ; let
             lf_info  = closureLFInfo cl_info
             info_tbl = mkCmmInfo cl_info

418
        -- Emit the main entry code
419
        ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
420 421
            \(offset, node, arg_regs) -> do
                -- Emit slow-entry code (for entering a closure through a PAP)
422 423
                { mkSlowEntryCode cl_info arg_regs

424
                ; dflags <- getDynFlags
425
                ; let lf_info = closureLFInfo cl_info
426
                      node_points = nodeMustPointToIt dflags lf_info
427
                      node' = if node_points then Just node else Nothing
428 429 430 431
                ; tickyEnterFun cl_info
                ; whenC node_points (ldvEnterClosure cl_info)
                ; granYield arg_regs node_points

432 433
                -- Main payload
                ; entryHeapCheck cl_info offset node' arity arg_regs $ do
434
                { fv_bindings <- mapM bind_fv fv_details
435
                -- Load free vars out of closure *after*
436 437 438
                -- heap check, to reduce live vars over check
                ; if node_points then load_fvs node lf_info fv_bindings
                                 else return ()
439 440
                ; void $ cgExpr body
                }}
441 442
  }

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

load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode ()
load_fvs node lf_info = mapCs (\ (reg, off) ->
450
      emit $ mkTaggedObjectLoad reg node off tag)
451 452
  where tag = lfDynTag lf_info

453 454 455 456 457 458
-----------------------------------------
-- 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.
459 460
--
-- The slow entry point is used for unknown calls: eg. stg_PAP_entry
461

462
mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
463
-- If this function doesn't have a specialised ArgDescr, we need
464 465
-- to generate the function's arg bitmap and slow-entry code.
-- Here, we emit the slow-entry code.
466 467
mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
468
  | Just (_, ArgGen _) <- closureFunInfo cl_info
469 470 471
  = do dflags <- getDynFlags
       let slow_lbl = closureSlowEntryLabel  cl_info
           fast_lbl = closureLocalEntryLabel dflags cl_info
472
           -- mkDirectJump does not clobber `Node' containing function closure
473 474
           jump = mkDirectJump dflags
                               (mkLblExpr fast_lbl)
475 476
                               (map (CmmReg . CmmLocal) arg_regs)
                               initUpdFrameOff
477
       emitProcWithConvention Slow Nothing slow_lbl arg_regs jump
478
  | otherwise = return ()
479 480

-----------------------------------------
481 482
thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack
          -> LocalReg -> Int -> StgExpr -> FCode ()
483
thunkCode cl_info fv_details _cc node arity body
484 485
  = do { dflags <- getDynFlags
       ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)
486 487 488 489
             node'       = if node_points then Just node else Nothing
        ; tickyEnterThunk cl_info
        ; ldvEnterClosure cl_info -- NB: Node always points when profiling
        ; granThunk node_points
490 491

        -- Heap overflow check
492 493 494
        ; entryHeapCheck cl_info 0 node' arity [] $ do
        { -- Overwrite with black hole if necessary
          -- but *after* the heap-overflow check
495
        ; whenC (blackHoleOnEntry cl_info && node_points)
496 497 498 499 500 501 502 503
                (blackHoleIt cl_info)

          -- Push update frame
        ; setupUpdate cl_info node $
            -- We only enter cc after setting up update so
            -- that cc of enclosing scope will be recorded
            -- in update frame CAF/DICT functions will be
            -- subsumed by this enclosing cc
504
            do { enterCostCentreThunk (CmmReg nodeReg)
505 506 507
               ; let lf_info = closureLFInfo cl_info
               ; fv_bindings <- mapM bind_fv fv_details
               ; load_fvs node lf_info fv_bindings
508
               ; void $ cgExpr body }}}
509 510 511 512 513 514 515 516 517 518 519 520


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

blackHoleIt :: ClosureInfo -> FCode ()
-- Only called for closures with no args
-- Node points to the closure
blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)

emitBlackHoleCode :: Bool -> FCode ()
521
emitBlackHoleCode is_single_entry = do
522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541
  dflags <- 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.

542
  let  eager_blackholing =  not (dopt Opt_SccProfilingOn dflags)
543 544 545 546 547 548 549
                         && dopt Opt_EagerBlackHoling dflags
             -- Profiling needs slop filling (to support LDV
             -- profiling), so currently eager blackholing doesn't
             -- work with profiling.

  whenC eager_blackholing $ do
    tickyBlackHole (not is_single_entry)
550
    emitStore (cmmOffsetW (CmmReg nodeReg) (fixedHdrSize dflags))
551
                  (CmmReg (CmmGlobal CurrentTSO))
552
    emitPrimCall [] MO_WriteBarrier []
553
    emitStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo))
554

555
setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
556 557 558
	-- 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
559
setupUpdate closure_info node body
560
  | closureReEntrant closure_info
561
  = body
562 563

  | not (isStaticClosure closure_info)
564 565 566 567
  = if not (closureUpdReqd closure_info)
      then do tickyUpdateFrameOmitted; body
      else do
          tickyPushUpdateFrame
568 569 570
          dflags <- getDynFlags
          let
              bh = blackHoleOnEntry closure_info &&
571 572
                   not (dopt Opt_SccProfilingOn dflags) &&
                   dopt Opt_EagerBlackHoling dflags
573 574 575 576 577

              lbl | bh        = mkBHUpdInfoLabel
                  | otherwise = mkUpdInfoLabel

          pushUpdateFrame [CmmReg (CmmLocal node), mkLblExpr lbl] body
578

579 580 581 582 583
  | otherwise	-- A static closure
  = do 	{ tickyUpdateBhCaf closure_info

	; if closureUpdReqd closure_info
	  then do	-- Blackhole the (updatable) CAF:
Simon Marlow's avatar
Simon Marlow committed
584
                { upd_closure <- link_caf True
585
                ; pushUpdateFrame [upd_closure,
586
                                   mkLblExpr mkBHUpdInfoLabel] body }
587
	  else do {tickyUpdateFrameOmitted; body}
588 589
    }

590 591 592
-----------------------------------------------------------------------------
-- Setting up update frames

593 594 595 596 597
-- 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 :: [CmmExpr] -> FCode () -> FCode ()
pushUpdateFrame es body
598 599
  = do -- [EZY] I'm not sure if we need to special-case for BH too
       updfr  <- getUpdFrameOff
600 601 602
       offset <- foldM push updfr es
       withUpdFrameOff offset body
     where push off e =
Simon Marlow's avatar
Simon Marlow committed
603
             do emitStore (CmmStackSlot Old base) e
604 605
                return base
             where base = off + widthInBytes (cmmExprWidth e)
606 607 608 609 610 611 612 613 614 615 616 617

-----------------------------------------------------------------------------
-- Entering a CAF
--
-- When a CAF is first entered, it creates a black hole in the heap,
-- and updates itself with an indirection to this new black hole.
--
-- We update the CAF with an indirection to a newly-allocated black
-- hole in the heap.  We also set the blocking queue on the newly
-- allocated black hole to be empty.
--
-- Why do we make a black hole in the heap when we enter a CAF?
618
--
619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635
--     - for a  generational garbage collector, which needs a fast
--       test for whether an updatee is in an old generation or not
--
--     - for the parallel system, which can implement updates more
--       easily if the updatee is always in the heap. (allegedly).
--
-- When debugging, we maintain a separate CAF list so we can tell when
-- a CAF has been garbage collected.

-- newCAF must be called before the itbl ptr is overwritten, since
-- newCAF records the old itbl ptr in order to do CAF reverting
-- (which Hugs needs to do in order that combined mode works right.)
--

-- ToDo [Feb 04]  This entire link_caf nonsense could all be moved
-- into the "newCAF" RTS procedure, which we call anyway, including
-- the allocation of the black-hole indirection closure.
636
-- That way, code size would fall, the CAF-handling code would
637 638 639
-- be closer together, and the compiler wouldn't need to know
-- about off_indirectee etc.

640 641
link_caf :: Bool               -- True <=> updatable, False <=> single-entry
         -> FCode CmmExpr      -- Returns amode for closure to be updated
642 643 644 645 646 647
-- To update a CAF we must allocate a black hole, link the CAF onto the
-- CAF list, then update the CAF to point to the fresh black hole.
-- This function returns the address of the black hole, so it can be
-- updated with the new value when available.  The reason for all of this
-- is that we only want to update dynamic heap objects, not static ones,
-- so that generational GC is easier.
Simon Marlow's avatar
Simon Marlow committed
648
link_caf _is_upd = do
649 650
  { dflags <- getDynFlags
    -- Alloc black hole specifying CC_HDR(Node) as the cost centre
651 652
  ; let	use_cc   = costCentreFrom (CmmReg nodeReg)
        blame_cc = use_cc
653
        tso      = CmmReg (CmmGlobal CurrentTSO)
Simon Marlow's avatar
Simon Marlow committed
654

655
  ; hp_rel <- allocDynClosureCmm cafBlackHoleInfoTable mkLFBlackHole
656
                                         use_cc blame_cc [(tso,fixedHdrSize dflags)]
657 658 659 660 661 662 663 664 665
        -- small optimisation: we duplicate the hp_rel expression in
        -- both the newCAF call and the value returned below.
        -- If we instead used allocDynClosureReg which assigns it to a reg,
        -- then the reg is live across the newCAF call and gets spilled,
        -- which is stupid.  Really we should have an optimisation pass to
        -- fix this, but we don't yet. --SDM

        -- Call the RTS function newCAF to add the CAF to the CafList
        -- so that the garbage collector can find them
666
	-- This must be done *before* the info table pointer is overwritten,
667
	-- because the old info table ptr is needed for reversion
668 669
  ; ret <- newTemp bWord
  ; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF")
670
      [ (CmmReg (CmmGlobal BaseReg),  AddrHint),
671
        (CmmReg nodeReg, AddrHint),
672
        (hp_rel, AddrHint) ]
673 674 675 676
      (Just [node]) False
        -- node is live, so save it.

  -- see Note [atomic CAF entry] in rts/sm/Storage.c
677
  ; updfr  <- getUpdFrameOff
678 679
  ; emit =<< mkCmmIfThen
      (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), CmmLit zeroCLit])
680 681 682
        -- re-enter R1.  Doing this directly is slightly dodgy; we're
        -- assuming lots of things, like the stack pointer hasn't
        -- moved since we entered the CAF.
683
       (let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) in
684
        mkJump dflags target [] updfr)
685 686 687 688

  ; return hp_rel }

------------------------------------------------------------------------
689
--		Profiling
690 691 692 693 694 695
------------------------------------------------------------------------

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

696 697
closureDescription :: DynFlags
           -> Module		-- Module
698 699 700 701
		   -> Name		-- Id of closure binding
		   -> String
	-- Not called for StgRhsCon which have global info tables built in
	-- CgConTbls.lhs with a description generated from the data constructor
702 703
closureDescription dflags mod_name name
  = showSDocDump dflags (char '<' <>
704 705 706 707 708
		    (if isExternalName name
		      then ppr name -- ppr will include the module name prefix
		      else pprModule mod_name <> char '.' <> ppr name) <>
		    char '>')
   -- showSDocDump, because we want to see the unique on the Name.
709