ghc/compiler/codeGen/CgClosure.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[CgClosure]{Code generation for closures}
   5
   6 This module provides the support code for @StgToAbstractC@ to deal
   7 with {\em closures} on the RHSs of let(rec)s.  See also
   8 @CgCon@, which deals with constructors.
   9
  10 \begin{code}
  11 #include "HsVersions.h"
  12
  13 module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
  14
  15 import StgSyn
  16 import CgMonad
  17 import AbsCSyn
  18
  19 import PrelInfo         ( PrimOp(..), Name
  20                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  21                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  22                         )
  23 import Type             ( isPrimType, isPrimTyCon,
  24                           getTauType, showTypeCategory, getTyConDataCons
  25                         )
  26 import CgBindery        ( getCAddrMode, getAtomAmodes,
  27                           getCAddrModeAndInfo,
  28                           bindNewToNode, bindNewToAStack, bindNewToBStack,
  29                           bindNewToReg, bindArgsToRegs
  30                         )
  31 import CgCompInfo       ( spARelToInt, spBRelToInt )
  32 import CgExpr           ( cgExpr, cgSccExpr )
  33 import CgUpdate         ( pushUpdateFrame )
  34 import CgHeapery        ( allocDynClosure, heapCheck
  35 #ifdef GRAN
  36                           , heapCheckOnly, fetchAndReschedule  -- HWL
  37 #endif  {- GRAN -}
  38                         )
  39 import CgRetConv        ( ctrlReturnConvAlg, dataReturnConvAlg, mkLiveRegsBitMask,
  40                           CtrlReturnConvention(..), DataReturnConvention(..)
  41                         )
  42 import CgStackery       ( getFinalStackHW, mkVirtStkOffsets,
  43                           adjustRealSps
  44                         )
  45 import CgUsages         ( getVirtSps, setRealAndVirtualSps,
  46                           getSpARelOffset, getSpBRelOffset,
  47                           getHpRelOffset
  48                         )
  49 import CLabel
  50 import ClosureInfo      -- lots and lots of stuff
  51 import CostCentre
  52 import Id               ( idType, getIdPrimRep, isSysLocalId, myWrapperMaybe,
  53                           showId, getIdInfo, getIdStrictness,
  54                           getDataConTag
  55                         )
  56 import IdInfo
  57 import ListSetOps       ( minusList )
  58 import Maybes           ( Maybe(..), maybeToBool )
  59 import PrimRep          ( isFollowableRep )
  60 import UniqSet
  61 import Unpretty
  62 import Util
  63 \end{code}
  64
  65 %********************************************************
  66 %*                                                      *
  67 \subsection[closures-no-free-vars]{Top-level closures}
  68 %*                                                      *
  69 %********************************************************
  70
  71 For closures bound at top level, allocate in static space.
  72 They should have no free variables.
  73
  74 \begin{code}
  75 cgTopRhsClosure :: Id
  76                 -> CostCentre   -- Optional cost centre annotation
  77                 -> StgBinderInfo
  78                 -> [Id]         -- Args
  79                 -> StgExpr
  80                 -> LambdaFormInfo
  81                 -> FCode (Id, CgIdInfo)
  82
  83 cgTopRhsClosure name cc binder_info args body lf_info
  84   =     -- LAY OUT THE OBJECT
  85     let
  86         closure_info = layOutStaticNoFVClosure name lf_info
  87     in
  88
  89         -- GENERATE THE INFO TABLE (IF NECESSARY)
  90     forkClosureBody (closureCodeBody binder_info closure_info
  91                                          cc args body)
  92                                                         `thenC`
  93
  94         -- BUILD VAP INFO TABLES IF NECESSARY
  95         -- Don't build Vap info tables etc for
  96         -- a function whose result is an unboxed type,
  97         -- because we can never have thunks with such a type.
  98     (if closureReturnsUnboxedType closure_info then
  99         nopC
 100     else
 101         let
 102             bind_the_fun = addBindC name cg_id_info     -- It's global!
 103         in
 104         cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info
 105     ) `thenC`
 106
 107         -- BUILD THE OBJECT (IF NECESSARY)
 108     (if staticClosureRequired name binder_info lf_info
 109      then
 110         let
 111             cost_centre = mkCCostCentre cc
 112         in
 113         absC (CStaticClosure
 114                 closure_label   -- Labelled with the name on lhs of defn
 115                 closure_info
 116                 cost_centre
 117                 [])             -- No fields
 118      else
 119         nopC
 120     ) `thenC`
 121
 122     returnFC (name, cg_id_info)
 123   where
 124     closure_label = mkClosureLabel name
 125     cg_id_info    = stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info
 126 \end{code}
 127
 128 %********************************************************
 129 %*                                                      *
 130 \subsection[non-top-level-closures]{Non top-level closures}
 131 %*                                                      *
 132 %********************************************************
 133
 134 For closures with free vars, allocate in heap.
 135
 136 ===================== OLD PROBABLY OUT OF DATE COMMENTS =============
 137
 138 -- Closures which (a) have no fvs and (b) have some args (i.e.
 139 -- combinator functions), are allocated statically, just as if they
 140 -- were top-level closures.  We can't get a space leak that way
 141 -- (because they are HNFs) and it saves allocation.
 142
 143 -- Lexical Scoping: Problem
 144 -- These top level function closures will be inherited, possibly
 145 -- to a different cost centre scope set before entering.
 146
 147 -- Evaluation Scoping: ok as already in HNF
 148
 149 -- Should rely on floating mechanism to achieve this floating to top level.
 150 -- As let floating will avoid floating which breaks cost centre attribution
 151 -- everything will be OK.
 152
 153 -- Disabled: because it breaks lexical-scoped cost centre semantics.
 154 -- cgRhsClosure binder cc bi [] upd_flag args@(_:_) body
 155 --  = cgTopRhsClosure binder cc bi upd_flag args body
 156
 157 ===================== END OF OLD PROBABLY OUT OF DATE COMMENTS =============
 158
 159 \begin{code}
 160 cgRhsClosure    :: Id
 161                 -> CostCentre   -- Optional cost centre annotation
 162                 -> StgBinderInfo
 163                 -> [Id]         -- Free vars
 164                 -> [Id]         -- Args
 165                 -> StgExpr
 166                 -> LambdaFormInfo
 167                 -> FCode (Id, CgIdInfo)
 168
 169 cgRhsClosure binder cc binder_info fvs args body lf_info
 170   | maybeToBool maybe_std_thunk         -- AHA!  A STANDARD-FORM THUNK
 171   -- ToDo: check non-primitiveness (ASSERT)
 172   = (
 173         -- LAY OUT THE OBJECT
 174     getAtomAmodes std_thunk_payload             `thenFC` \ amodes ->
 175     let
 176         (closure_info, amodes_w_offsets)
 177           = layOutDynClosure binder getAmodeRep amodes lf_info
 178
 179         (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
 180     in
 181         -- BUILD THE OBJECT
 182     allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
 183     )
 184                 `thenFC` \ heap_offset ->
 185
 186         -- RETURN
 187     returnFC (binder, heapIdInfo binder heap_offset lf_info)
 188
 189   where
 190     maybe_std_thunk        = getStandardFormThunkInfo lf_info
 191     Just std_thunk_payload = maybe_std_thunk
 192 \end{code}
 193
 194 Here's the general case.
 195 \begin{code}
 196 cgRhsClosure binder cc binder_info fvs args body lf_info
 197   = (
 198         -- LAY OUT THE OBJECT
 199         --
 200         -- If the binder is itself a free variable, then don't store
 201         -- it in the closure.  Instead, just bind it to Node on entry.
 202         -- NB we can be sure that Node will point to it, because we
 203         -- havn't told mkClosureLFInfo about this; so if the binder
 204         -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
 205         -- stored in the closure itself, so it will make sure that
 206         -- Node points to it...
 207     let
 208         is_elem        = isIn "cgRhsClosure"
 209
 210         binder_is_a_fv = binder `is_elem` fvs
 211         reduced_fvs    = if binder_is_a_fv
 212                          then fvs `minusList` [binder]
 213                          else fvs
 214     in
 215     mapFCs getCAddrModeAndInfo reduced_fvs      `thenFC` \ amodes_and_info ->
 216     let
 217         fvs_w_amodes_and_info         = reduced_fvs `zip` amodes_and_info
 218
 219         closure_info :: ClosureInfo
 220         bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
 221
 222         (closure_info, bind_details)
 223           = layOutDynClosure binder get_kind fvs_w_amodes_and_info lf_info
 224
 225         bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
 226
 227         amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
 228
 229         get_kind (id, amode_and_info) = getIdPrimRep id
 230     in
 231         -- BUILD ITS INFO TABLE AND CODE
 232     forkClosureBody (
 233                 -- Bind the fvs
 234             mapCs bind_fv bind_details `thenC`
 235
 236                 -- Bind the binder itself, if it is a free var
 237             (if binder_is_a_fv then
 238                 bindNewToReg binder node lf_info
 239             else
 240                 nopC)                                   `thenC`
 241
 242                 -- Compile the body
 243             closureCodeBody binder_info closure_info cc args body
 244     )   `thenC`
 245
 246         -- BUILD VAP INFO TABLES IF NECESSARY
 247         -- Don't build Vap info tables etc for
 248         -- a function whose result is an unboxed type,
 249         -- because we can never have thunks with such a type.
 250     (if closureReturnsUnboxedType closure_info then
 251         nopC
 252     else
 253         cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info
 254     ) `thenC`
 255
 256         -- BUILD THE OBJECT
 257     let
 258         (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
 259     in
 260     allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
 261     )           `thenFC` \ heap_offset ->
 262
 263         -- RETURN
 264     returnFC (binder, heapIdInfo binder heap_offset lf_info)
 265 \end{code}
 266
 267 @cgVapInfoTables@ generates both Vap info tables, if they are required
 268 at all.  It calls @cgVapInfoTable@ to generate each Vap info table,
 269 along with its entry code.
 270
 271 \begin{code}
 272 -- Don't generate Vap info tables for thunks; only for functions
 273 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun [{- no args; a thunk! -}] lf_info
 274   = nopC
 275
 276 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info
 277   =     -- BUILD THE STANDARD VAP-ENTRY STUFF IF NECESSARY
 278     (if stdVapRequired binder_info then
 279         cgVapInfoTable perhaps_bind_the_fun Updatable fun args fun_in_payload lf_info
 280     else
 281         nopC
 282     )           `thenC`
 283
 284                 -- BUILD THE NO-UPDATE VAP-ENTRY STUFF IF NECESSARY
 285     (if noUpdVapRequired binder_info then
 286         cgVapInfoTable perhaps_bind_the_fun SingleEntry fun args fun_in_payload lf_info
 287     else
 288         nopC
 289     )
 290
 291   where
 292     fun_in_payload = not top_level
 293
 294 cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
 295   = let
 296         -- The vap_entry_rhs is a manufactured STG expression which
 297         -- looks like the RHS of any binding which is going to use the vap-entry
 298         -- point of the function.  Each of these bindings will look like:
 299         --
 300         --      x = [a,b,c] \upd [] -> f a b c
 301         --
 302         -- If f is not top-level, then f is one of the free variables too,
 303         -- hence "payload_ids" isn't the same as "arg_ids".
 304         --
 305         vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyUniqSet
 306                                                                         -- Empty live vars
 307
 308         arg_ids_w_info = [(name,mkLFArgument) | name <- args]
 309         payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
 310                            | otherwise      = arg_ids_w_info
 311
 312         payload_ids | fun_in_payload = fun : args               -- Sigh; needed for mkClosureLFInfo
 313                     | otherwise      = args
 314
 315         vap_lf_info   = mkClosureLFInfo False {-not top level-} payload_ids
 316                                         upd_flag [] vap_entry_rhs
 317                 -- It's not top level, even if we're currently compiling a top-level
 318                 -- function, because any VAP *use* of this function will be for a
 319                 -- local thunk, thus
 320                 --              let x = f p q   -- x isn't top level!
 321                 --              in ...
 322
 323         get_kind (id, info) = getIdPrimRep id
 324
 325         payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
 326         (closure_info, payload_bind_details) = layOutDynClosure
 327                                                         fun
 328                                                         get_kind payload_ids_w_info
 329                                                         vap_lf_info
 330                 -- The dodgy thing is that we use the "fun" as the
 331                 -- Id to give to layOutDynClosure.  This Id gets embedded in
 332                 -- the closure_info it returns.  But of course, the function doesn't
 333                 -- have the right type to match the Vap closure.  Never mind,
 334                 -- a hack in closureType spots the special case.  Otherwise that
 335                 -- Id is just used for label construction, which is OK.
 336
 337         bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info
 338     in
 339
 340         -- BUILD ITS INFO TABLE AND CODE
 341     forkClosureBody (
 342
 343                 -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells
 344                 -- how to bind it.  If it is in payload it'll be bound by payload_bind_details.
 345             perhaps_bind_the_fun                `thenC`
 346             mapCs bind_fv payload_bind_details  `thenC`
 347
 348                 -- Generate the info table and code
 349             closureCodeBody NoStgBinderInfo
 350                             closure_info
 351                             useCurrentCostCentre
 352                             []  -- No args; it's a thunk
 353                             vap_entry_rhs
 354     )
 355 \end{code}
 356 %************************************************************************
 357 %*                                                                      *
 358 \subsection[code-for-closures]{The code for closures}
 359 %*                                                                      *
 360 %************************************************************************
 361
 362 \begin{code}
 363 closureCodeBody :: StgBinderInfo
 364                 -> ClosureInfo  -- Lots of information about this closure
 365                 -> CostCentre   -- Optional cost centre attached to closure
 366                 -> [Id]
 367                 -> StgExpr
 368                 -> Code
 369 \end{code}
 370
 371 There are two main cases for the code for closures.  If there are {\em
 372 no arguments}, then the closure is a thunk, and not in normal form.
 373 So it should set up an update frame (if it is shared).  Also, it has
 374 no argument satisfaction check, so fast and slow entry-point labels
 375 are the same.
 376
 377 \begin{code}
 378 closureCodeBody binder_info closure_info cc [] body
 379   = -- thunks cannot have a primitive type!
 380 #ifdef DEBUG
 381     let
 382         (has_tycon, tycon)
 383           = case (closureType closure_info) of
 384               Nothing       -> (False, panic "debug")
 385               Just (tc,_,_) -> (True,  tc)
 386     in
 387     if has_tycon && isPrimTyCon tycon then
 388         pprPanic "closureCodeBody:thunk:prim type!" (ppr PprDebug tycon)
 389     else
 390 #endif
 391     getAbsC body_code   `thenFC` \ body_absC ->
 392     moduleName          `thenFC` \ mod_name ->
 393     getIntSwitchChkrC   `thenFC` \ isw_chkr ->
 394
 395     absC (CClosureInfoAndCode closure_info body_absC Nothing
 396                               stdUpd (cl_descr mod_name)
 397                               (dataConLiveness isw_chkr closure_info))
 398   where
 399     cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
 400
 401     body_addr   = CLbl (entryLabelFromCI closure_info) CodePtrRep
 402     body_code   = profCtrC SLIT("ENT_THK") []                   `thenC`
 403                   enterCostCentreCode closure_info cc IsThunk   `thenC`
 404                   thunkWrapper closure_info (cgSccExpr body)
 405
 406     stdUpd      = CLbl mkErrorStdEntryLabel CodePtrRep
 407 \end{code}
 408
 409 If there is {\em at least one argument}, then this closure is in
 410 normal form, so there is no need to set up an update frame.  On the
 411 other hand, we do have to check that there are enough args, and
 412 perform an update if not!
 413
 414 The Macros for GrAnSim are produced at the beginning of the
 415 argSatisfactionCheck (by calling fetchAndReschedule).  There info if
 416 Node points to closure is available. -- HWL
 417
 418 \begin{code}
 419 closureCodeBody binder_info closure_info cc all_args body
 420   = getEntryConvention id lf_info
 421                        (map getIdPrimRep all_args)              `thenFC` \ entry_conv ->
 422
 423     isSwitchSetC EmitArityChecks                        `thenFC` \ do_arity_chks ->
 424
 425     isSwitchSetC ForConcurrent                          `thenFC` \ is_concurrent ->
 426
 427     isStringSwitchSetC AsmTarget                        `thenFC` \ native_code ->
 428
 429     let
 430         stg_arity = length all_args
 431
 432         -- Arg mapping for standard (slow) entry point; all args on stack
 433         (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
 434            = mkVirtStkOffsets
 435                 0 0             -- Initial virtual SpA, SpB
 436                 getIdPrimRep
 437                 all_args
 438
 439         -- Arg mapping for the fast entry point; as many args as poss in
 440         -- registers; the rest on the stack
 441         --      arg_regs are the registers used for arg passing
 442         --      stk_args are the args which are passed on the stack
 443         --
 444         arg_regs = case entry_conv of
 445                 DirectEntry lbl arity regs -> regs
 446                 ViaNode | is_concurrent    -> []
 447                 other                      -> panic "closureCodeBody:arg_regs"
 448
 449         stk_args = drop (length arg_regs) all_args
 450         (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
 451           = mkVirtStkOffsets
 452                 0 0             -- Initial virtual SpA, SpB
 453                 getIdPrimRep
 454                 stk_args
 455
 456         -- HWL; Note: empty list of live regs in slow entry code
 457         -- Old version (reschedule combined with heap check);
 458         -- see argSatisfactionCheck for new version
 459         --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
 460         --                where node = VanillaReg PtrRep 1
 461         --slow_entry_code = forceHeapCheck [] True slow_entry_code'
 462
 463         slow_entry_code
 464           = profCtrC SLIT("ENT_FUN_STD") []                 `thenC`
 465
 466                 -- Bind args, and record expected position of stk ptrs
 467             mapCs bindNewToAStack all_bxd_w_offsets         `thenC`
 468             mapCs bindNewToBStack all_ubxd_w_offsets        `thenC`
 469             setRealAndVirtualSps spA_all_args spB_all_args  `thenC`
 470
 471             argSatisfactionCheck closure_info all_args      `thenC`
 472
 473             -- OK, so there are enough args.  Now we need to stuff as
 474             -- many of them in registers as the fast-entry code
 475             -- expects Note that the zipWith will give up when it hits
 476             -- the end of arg_regs.
 477
 478             mapFCs getCAddrMode all_args                    `thenFC` \ stk_amodes ->
 479             absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`
 480
 481             -- Now adjust real stack pointers
 482             adjustRealSps spA_stk_args spB_stk_args             `thenC`
 483
 484             -- set the arity checker, if asked
 485             absC (
 486                 if do_arity_chks
 487                 then CMacroStmt SET_ARITY [mkIntCLit stg_arity]
 488                 else AbsCNop
 489             )                                                   `thenC`
 490             absC (CFallThrough (CLbl fast_label CodePtrRep))
 491
 492         assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
 493
 494         -- HWL
 495         -- Old version (reschedule combined with heap check);
 496         -- see argSatisfactionCheck for new version
 497         -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
 498
 499         fast_entry_code
 500           = profCtrC SLIT("ENT_FUN_DIRECT") [
 501                     CLbl (mkRednCountsLabel id) PtrRep,
 502                     CString (_PK_ (showId PprDebug id)),
 503                     mkIntCLit stg_arity,        -- total # of args
 504                     mkIntCLit spA_stk_args,     -- # passed on A stk
 505                     mkIntCLit spB_stk_args,     -- B stk (rest in regs)
 506                     CString (_PK_ (map (showTypeCategory . idType) all_args)),
 507                     CString (_PK_ (show_wrapper_name wrapper_maybe)),
 508                     CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
 509                 ]                       `thenC`
 510             absC (
 511                 if do_arity_chks
 512                 then CMacroStmt CHK_ARITY [mkIntCLit stg_arity]
 513                 else AbsCNop
 514             )                           `thenC`
 515
 516                 -- Bind args to regs/stack as appropriate, and
 517                 -- record expected position of sps
 518             bindArgsToRegs all_args arg_regs                `thenC`
 519             mapCs bindNewToAStack stk_bxd_w_offsets         `thenC`
 520             mapCs bindNewToBStack stk_ubxd_w_offsets        `thenC`
 521             setRealAndVirtualSps spA_stk_args spB_stk_args  `thenC`
 522
 523                 -- Enter the closures cc, if required
 524             enterCostCentreCode closure_info cc IsFunction  `thenC`
 525
 526                 -- Do the business
 527             funWrapper closure_info arg_regs (cgExpr body)
 528     in
 529         -- Make a labelled code-block for the slow and fast entry code
 530     forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
 531                                 `thenFC` \ slow_abs_c ->
 532     forkAbsC fast_entry_code    `thenFC` \ fast_abs_c ->
 533     moduleName                  `thenFC` \ mod_name ->
 534     getIntSwitchChkrC           `thenFC` \ isw_chkr ->
 535
 536         -- Now either construct the info table, or put the fast code in alone
 537         -- (We never have slow code without an info table)
 538     absC (
 539       if info_table_needed then
 540         CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
 541                         stdUpd (cl_descr mod_name)
 542                         (dataConLiveness isw_chkr closure_info)
 543       else
 544         CCodeBlock fast_label fast_abs_c
 545     )
 546   where
 547     lf_info = closureLFInfo closure_info
 548
 549     cl_descr mod_name = closureDescription mod_name id all_args body
 550
 551         -- Figure out what is needed and what isn't
 552     slow_code_needed   = slowFunEntryCodeRequired id binder_info
 553     info_table_needed  = funInfoTableRequired id binder_info lf_info
 554
 555         -- Manufacture labels
 556     id         = closureId closure_info
 557
 558     fast_label = fastLabelFromCI closure_info
 559
 560     stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
 561
 562     wrapper_maybe = get_ultimate_wrapper Nothing id
 563       where
 564         get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
 565           = case (myWrapperMaybe x) of
 566               Nothing -> deflt
 567               Just xx -> get_ultimate_wrapper (Just xx) xx
 568
 569     show_wrapper_name Nothing   = ""
 570     show_wrapper_name (Just xx) = showId PprDebug xx
 571
 572     show_wrapper_arg_kinds Nothing   = ""
 573     show_wrapper_arg_kinds (Just xx)
 574       = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
 575           Nothing  -> ""
 576           Just str -> str
 577 \end{code}
 578
 579 For lexically scoped profiling we have to load the cost centre from
 580 the closure entered, if the costs are not supposed to be inherited.
 581 This is done immediately on entering the fast entry point.
 582
 583 Load current cost centre from closure, if not inherited.
 584 Node is guaranteed to point to it, if profiling and not inherited.
 585
 586 \begin{code}
 587 data IsThunk = IsThunk | IsFunction -- Bool-like, local
 588
 589 enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
 590
 591 enterCostCentreCode closure_info cc is_thunk
 592   = costCentresFlag     `thenFC` \ profiling_on ->
 593     if not profiling_on then
 594         nopC
 595     else -- down to business
 596         ASSERT(not (noCostCentreAttached cc))
 597
 598         if costsAreSubsumed cc then
 599             nopC
 600
 601         else if is_current_CC cc then -- fish the CC out of the closure,
 602                                       -- where we put it when we alloc'd;
 603                                       -- NB: chk defn of "is_current_CC"
 604                                       -- if you go to change this! (WDP 94/12)
 605             costCentresC
 606                 (case is_thunk of
 607                    IsThunk    -> SLIT("ENTER_CC_TCL")
 608                    IsFunction -> SLIT("ENTER_CC_FCL"))
 609                 [CReg node]
 610
 611         else if isCafCC cc then
 612             costCentresC
 613                 SLIT("ENTER_CC_CAF")
 614                 [mkCCostCentre cc]
 615
 616         else -- we've got a "real" cost centre right here in our hands...
 617             costCentresC
 618                 (case is_thunk of
 619                    IsThunk    -> SLIT("ENTER_CC_T")
 620                    IsFunction -> SLIT("ENTER_CC_F"))
 621                 [mkCCostCentre cc]
 622   where
 623     is_current_CC cc
 624       = currentOrSubsumedCosts cc
 625         -- but we've already ruled out "subsumed", so it must be "current"!
 626 \end{code}
 627
 628 %************************************************************************
 629 %*                                                                      *
 630 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
 631 %*                                                                      *
 632 %************************************************************************
 633
 634 The argument-satisfaction check code is placed after binding
 635 the arguments to their stack locations. Hence, the virtual stack
 636 pointer is pointing after all the args, and virtual offset 1 means
 637 the base of frame and hence most distant arg.  Hence
 638 virtual offset 0 is just beyond the most distant argument; the
 639 relative offset of this word tells how many words of arguments
 640 are expected.
 641
 642 \begin{code}
 643 argSatisfactionCheck :: ClosureInfo -> [Id] -> Code
 644
 645 argSatisfactionCheck closure_info [] = nopC
 646
 647 argSatisfactionCheck closure_info args
 648   = -- safest way to determine which stack last arg will be on:
 649     -- look up CAddrMode that last arg is bound to;
 650     -- getAmodeRep;
 651     -- check isFollowableRep.
 652
 653     nodeMustPointToIt (closureLFInfo closure_info)      `thenFC` \ node_points ->
 654
 655 #ifdef GRAN
 656     -- HWL:
 657     -- absC (CMacroStmt GRAN_FETCH [])                  `thenC`
 658     -- forceHeapCheck [] node_points (absC AbsCNop)     `thenC`
 659     (if node_points
 660         then fetchAndReschedule  [] node_points
 661         else absC AbsCNop)                              `thenC`
 662 #endif  {- GRAN -}
 663
 664     getCAddrMode (last args)                            `thenFC` \ last_amode ->
 665
 666     if (isFollowableRep (getAmodeRep last_amode)) then
 667         getSpARelOffset 0       `thenFC` \ (SpARel spA off) ->
 668         if node_points then
 669             absC (CMacroStmt ARGS_CHK_A [mkIntCLit (spARelToInt spA off)])
 670         else
 671             absC (CMacroStmt ARGS_CHK_A_LOAD_NODE
 672                                 [mkIntCLit (spARelToInt spA off), set_Node_to_this])
 673     else
 674         getSpBRelOffset 0       `thenFC` \ b_rel_offset ->
 675         if node_points then
 676             absC (CMacroStmt ARGS_CHK_B [mkIntCLit (spBRelToInt b_rel_offset)])
 677         else
 678             absC (CMacroStmt ARGS_CHK_B_LOAD_NODE
 679                                 [mkIntCLit (spBRelToInt b_rel_offset), set_Node_to_this])
 680   where
 681     -- We must tell the arg-satis macro whether Node is pointing to
 682     -- the closure or not.  If it isn't so pointing, then we give to
 683     -- the macro the (static) address of the closure.
 684
 685     set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
 686 \end{code}
 687
 688 %************************************************************************
 689 %*                                                                      *
 690 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
 691 %*                                                                      *
 692 %************************************************************************
 693
 694 \begin{code}
 695 thunkWrapper:: ClosureInfo -> Code -> Code
 696 thunkWrapper closure_info thunk_code
 697   =     -- Stack and heap overflow checks
 698     nodeMustPointToIt (closureLFInfo closure_info)      `thenFC` \ node_points ->
 699
 700 #ifdef GRAN
 701     -- HWL insert macros for GrAnSim if node is live here
 702     (if node_points
 703        then fetchAndReschedule [] node_points
 704        else absC AbsCNop)                               `thenC`
 705 #endif  {- GRAN -}
 706
 707     stackCheck closure_info [] node_points (    -- stackCheck *encloses* the rest
 708
 709     -- Must be after stackCheck: if stchk fails new stack
 710     -- space has to be allocated from the heap
 711
 712     heapCheck [] node_points (
 713                                         -- heapCheck *encloses* the rest
 714         -- The "[]" says there are no live argument registers
 715
 716         -- Overwrite with black hole if necessary
 717     blackHoleIt closure_info                            `thenC`
 718
 719         -- Push update frame if necessary
 720     setupUpdate closure_info (          -- setupUpdate *encloses* the rest
 721         thunk_code
 722     )))
 723
 724 funWrapper :: ClosureInfo       -- Closure whose code body this is
 725            -> [MagicId]         -- List of argument registers (if any)
 726            -> Code              -- Body of function being compiled
 727            -> Code
 728 funWrapper closure_info arg_regs fun_body
 729   =     -- Stack overflow check
 730     nodeMustPointToIt (closureLFInfo closure_info)      `thenFC` \ node_points ->
 731     stackCheck closure_info arg_regs node_points (      -- stackCheck *encloses* the rest
 732
 733         -- Heap overflow check
 734     heapCheck arg_regs node_points (
 735                                         -- heapCheck *encloses* the rest
 736
 737         -- Finally, do the business
 738     fun_body
 739     ))
 740 \end{code}
 741
 742 %************************************************************************
 743 %*                                                                      *
 744 \subsubsubsection[overflow-checks]{Stack and heap overflow wrappers}
 745 %*                                                                      *
 746 %************************************************************************
 747
 748 Assumption: virtual and real stack pointers are currently exactly aligned.
 749
 750 \begin{code}
 751 stackCheck :: ClosureInfo
 752            -> [MagicId]                 -- Live registers
 753            -> Bool                      -- Node required to point after check?
 754            -> Code
 755            -> Code
 756
 757 stackCheck closure_info regs node_reqd code
 758   = getFinalStackHW (\ aHw -> \ bHw ->  -- Both virtual stack offsets
 759
 760     getVirtSps          `thenFC` \ (vSpA, vSpB) ->
 761
 762     let a_headroom_reqd = aHw - vSpA    -- Virtual offsets are positive integers
 763         b_headroom_reqd = bHw - vSpB
 764     in
 765
 766     absC (if (a_headroom_reqd == 0 && b_headroom_reqd == 0) then
 767                 AbsCNop
 768           else
 769                 CMacroStmt STK_CHK [mkIntCLit liveness_mask,
 770                                     mkIntCLit a_headroom_reqd,
 771                                     mkIntCLit b_headroom_reqd,
 772                                     mkIntCLit vSpA,
 773                                     mkIntCLit vSpB,
 774                                     mkIntCLit (if returns_prim_type then 1 else 0),
 775                                     mkIntCLit (if node_reqd         then 1 else 0)]
 776          )
 777         -- The test is *inside* the absC, to avoid black holes!
 778
 779     `thenC` code
 780     )
 781   where
 782     all_regs = if node_reqd then node:regs else regs
 783     liveness_mask = mkLiveRegsBitMask all_regs
 784
 785     returns_prim_type = closureReturnsUnboxedType closure_info
 786 \end{code}
 787
 788 %************************************************************************
 789 %*                                                                      *
 790 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
 791 %*                                                                      *
 792 %************************************************************************
 793
 794
 795 \begin{code}
 796 blackHoleIt :: ClosureInfo -> Code      -- Only called for thunks
 797 blackHoleIt closure_info
 798   = noBlackHolingFlag   `thenFC` \ no_black_holing ->
 799
 800     if (blackHoleOnEntry no_black_holing closure_info)
 801     then
 802         absC (if closureSingleEntry(closure_info) then
 803                 CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
 804               else
 805                 CMacroStmt UPD_BH_UPDATABLE [CReg node])
 806         -- Node always points to it; see stg-details
 807     else
 808         nopC
 809 \end{code}
 810
 811 \begin{code}
 812 setupUpdate :: ClosureInfo -> Code -> Code      -- Only called for thunks
 813         -- Nota Bene: this function does not change Node (even if it's a CAF),
 814         -- so that the cost centre in the original closure can still be
 815         -- extracted by a subsequent ENTER_CC_TCL
 816
 817 setupUpdate closure_info code
 818  = if (closureUpdReqd closure_info) then
 819         link_caf_if_needed      `thenFC` \ update_closure ->
 820         getIntSwitchChkrC       `thenFC` \ isw_chkr ->
 821         pushUpdateFrame update_closure (vector isw_chkr) code
 822    else
 823         profCtrC SLIT("UPDF_OMITTED") [] `thenC`
 824         code
 825  where
 826    link_caf_if_needed :: FCode CAddrMode        -- Returns amode for closure to be updated
 827    link_caf_if_needed
 828      = if not (isStaticClosure closure_info) then
 829           returnFC (CReg node)
 830        else
 831
 832           -- First we must allocate a black hole, and link the
 833           -- CAF onto the CAF list
 834
 835                 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
 836                 --   Hack Warning: Using a CLitLit to get CAddrMode !
 837           let
 838               use_cc   = CLitLit SLIT("CC_HDR(R1.p)") PtrRep
 839               blame_cc = use_cc
 840           in
 841           allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
 842                                                         `thenFC` \ heap_offset ->
 843           getHpRelOffset heap_offset                    `thenFC` \ hp_rel ->
 844           let  amode = CAddr hp_rel
 845           in
 846           absC (CMacroStmt UPD_CAF [CReg node, amode])
 847                                                         `thenC`
 848           returnFC amode
 849
 850    closure_label = mkClosureLabel (closureId closure_info)
 851
 852    vector isw_chkr
 853      = case (closureType closure_info) of
 854         Nothing -> CReg StdUpdRetVecReg
 855         Just (spec_tycon, _, spec_datacons) ->
 856             case (ctrlReturnConvAlg spec_tycon) of
 857               UnvectoredReturn 1 ->
 858                 let
 859                     spec_data_con = head spec_datacons
 860                     only_tag = getDataConTag spec_data_con
 861
 862                     direct = case (dataReturnConvAlg isw_chkr spec_data_con) of
 863                         ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
 864                         ReturnInHeap   -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
 865
 866                     vectored = mkStdUpdVecTblLabel spec_tycon
 867                 in
 868                     CUnVecLbl direct vectored
 869
 870               UnvectoredReturn _ -> CReg StdUpdRetVecReg
 871               VectoredReturn _   -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrRep
 872 \end{code}
 873
 874 %************************************************************************
 875 %*                                                                      *
 876 \subsection[CgClosure-Description]{Profiling Closure Description.}
 877 %*                                                                      *
 878 %************************************************************************
 879
 880 For "global" data constructors the description is simply occurrence
 881 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
 882
 883 Otherwise it is determind by @closureDescription@ from the let
 884 binding information.
 885
 886 \begin{code}
 887 closureDescription :: FAST_STRING       -- Module
 888                    -> Id                -- Id of closure binding
 889                    -> [Id]              -- Args
 890                    -> StgExpr   -- Body
 891                    -> String
 892
 893         -- Not called for StgRhsCon which have global info tables built in
 894         -- CgConTbls.lhs with a description generated from the data constructor
 895
 896 closureDescription mod_name name args body =
 897     uppShow 0 (prettyToUn (
 898         ppBesides [ppChar '<',
 899                    ppPStr mod_name,
 900                    ppChar '.',
 901                    ppr PprDebug name,
 902                    ppChar '>']))
 903 \end{code}
 904
 905 \begin{code}
 906 chooseDynCostCentres cc args fvs body
 907   = let
 908         use_cc -- cost-centre we record in the object
 909           = if currentOrSubsumedCosts cc
 910             then CReg CurCostCentre
 911             else mkCCostCentre cc
 912
 913         blame_cc -- cost-centre on whom we blame the allocation
 914           = case (args, fvs, body) of
 915               ([], [just1], StgApp (StgVarArg fun) [{-no args-}] _)
 916                 | just1 == fun
 917                 -> mkCCostCentre overheadCostCentre
 918               _ -> use_cc
 919             -- if it's an utterly trivial RHS, then it must be
 920             -- one introduced by boxHigherOrderArgs for profiling,
 921             -- so we charge it to "OVERHEAD".
 922     in
 923     (use_cc, blame_cc)
 924 \end{code}