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