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