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