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     moduleName          `thenFC` \ mod_name ->
 439     getIntSwitchChkrC   `thenFC` \ isw_chkr ->
 440
 441     absC (CClosureInfoAndCode closure_info body_absC Nothing
 442                               stdUpd (cl_descr mod_name)
 443                               (dataConLiveness isw_chkr closure_info))
 444   where
 445     cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
 446
 447     body_addr   = CLbl (entryLabelFromCI closure_info) CodePtrKind
 448     body_code   = profCtrC SLIT("ENT_THK") []                   `thenC`
 449                   enterCostCentreCode closure_info cc IsThunk   `thenC`
 450                   thunkWrapper closure_info (cgSccExpr body)
 451
 452     stdUpd      = CLbl mkErrorStdEntryLabel CodePtrKind
 453 \end{code}
 454
 455 If there is {\em at least one argument}, then this closure is in
 456 normal form, so there is no need to set up an update frame.  On the
 457 other hand, we do have to check that there are enough args, and
 458 perform an update if not!
 459
 460 The Macros for GrAnSim are produced at the beginning of the
 461 argSatisfactionCheck (by calling fetchAndReschedule).  There info if
 462 Node points to closure is available. -- HWL
 463
 464 \begin{code}
 465 closureCodeBody binder_info closure_info cc all_args body
 466   = getEntryConvention id lf_info
 467                        (map getIdKind all_args)         `thenFC` \ entry_conv ->
 468
 469     isSwitchSetC EmitArityChecks                        `thenFC` \ do_arity_chks ->
 470
 471     isSwitchSetC ForConcurrent                          `thenFC` \ is_concurrent ->
 472
 473     isStringSwitchSetC AsmTarget                        `thenFC` \ native_code ->
 474
 475     let
 476         stg_arity = length all_args
 477
 478         -- Arg mapping for standard (slow) entry point; all args on stack
 479         (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
 480            = mkVirtStkOffsets
 481                 0 0             -- Initial virtual SpA, SpB
 482                 getIdKind
 483                 all_args
 484
 485         -- Arg mapping for the fast entry point; as many args as poss in
 486         -- registers; the rest on the stack
 487         --      arg_regs are the registers used for arg passing
 488         --      stk_args are the args which are passed on the stack
 489         --
 490         arg_regs = case entry_conv of
 491                 DirectEntry lbl arity regs -> regs
 492                 ViaNode | is_concurrent    -> []
 493                 other                      -> panic "closureCodeBody:arg_regs"
 494
 495         stk_args = drop (length arg_regs) all_args
 496         (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
 497           = mkVirtStkOffsets
 498                 0 0             -- Initial virtual SpA, SpB
 499                 getIdKind
 500                 stk_args
 501
 502         -- HWL; Note: empty list of live regs in slow entry code
 503         -- Old version (reschedule combined with heap check);
 504         -- see argSatisfactionCheck for new version
 505         --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
 506         --                where node = VanillaReg PtrKind 1
 507         --slow_entry_code = forceHeapCheck [] True slow_entry_code'
 508
 509         slow_entry_code
 510           = profCtrC SLIT("ENT_FUN_STD") []                 `thenC`
 511
 512                 -- Bind args, and record expected position of stk ptrs
 513             mapCs bindNewToAStack all_bxd_w_offsets         `thenC`
 514             mapCs bindNewToBStack all_ubxd_w_offsets        `thenC`
 515             setRealAndVirtualSps spA_all_args spB_all_args  `thenC`
 516
 517             argSatisfactionCheck closure_info all_args      `thenC`
 518
 519             -- OK, so there are enough args.  Now we need to stuff as
 520             -- many of them in registers as the fast-entry code expects
 521             -- Note that the zipWith will give up when it hits the end of arg_regs
 522             mapFCs getCAddrMode all_args                    `thenFC` \ stk_amodes ->
 523             absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`
 524
 525             -- Now adjust real stack pointers
 526             adjustRealSps spA_stk_args spB_stk_args             `thenC`
 527
 528             -- set the arity checker, if asked
 529             absC (
 530                 if do_arity_chks
 531                 then CMacroStmt SET_ARITY [mkIntCLit stg_arity]
 532                 else AbsCNop
 533             )                                                   `thenC`
 534
 535 #ifndef DPH
 536             absC (CFallThrough (CLbl fast_label CodePtrKind))
 537 #else
 538             -- Fall through to the fast entry point
 539             absC (AbsCNop)
 540 #endif {- Data Parallel Haskell -}
 541
 542         assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
 543
 544         -- HWL
 545         -- Old version (reschedule combined with heap check);
 546         -- see argSatisfactionCheck for new version
 547         -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
 548
 549         fast_entry_code
 550           = profCtrC SLIT("ENT_FUN_DIRECT") [
 551                     CLbl (mkRednCountsLabel id) PtrKind,
 552                     CString (_PK_ (showId PprDebug id)),
 553                     mkIntCLit stg_arity,        -- total # of args
 554                     mkIntCLit spA_stk_args,     -- # passed on A stk
 555                     mkIntCLit spB_stk_args,     -- B stk (rest in regs)
 556                     CString (_PK_ (map (showTypeCategory . getIdUniType) all_args)),
 557                     CString (_PK_ (show_wrapper_name wrapper_maybe)),
 558                     CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
 559                 ]                       `thenC`
 560             absC (
 561                 if do_arity_chks
 562                 then CMacroStmt CHK_ARITY [mkIntCLit stg_arity]
 563                 else AbsCNop
 564             )                           `thenC`
 565
 566                 -- Bind args to regs/stack as appropriate, and
 567                 -- record expected position of sps
 568             bindArgsToRegs all_args arg_regs                `thenC`
 569             mapCs bindNewToAStack stk_bxd_w_offsets         `thenC`
 570             mapCs bindNewToBStack stk_ubxd_w_offsets        `thenC`
 571             setRealAndVirtualSps spA_stk_args spB_stk_args  `thenC`
 572
 573                 -- Enter the closures cc, if required
 574             enterCostCentreCode closure_info cc IsFunction  `thenC`
 575
 576                 -- Do the business
 577             funWrapper closure_info arg_regs (cgExpr body)
 578     in
 579         -- Make a labelled code-block for the slow and fast entry code
 580     forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
 581                                 `thenFC` \ slow_abs_c ->
 582     forkAbsC fast_entry_code    `thenFC` \ fast_abs_c ->
 583     moduleName                  `thenFC` \ mod_name ->
 584     getIntSwitchChkrC           `thenFC` \ isw_chkr ->
 585
 586         -- Now either construct the info table, or put the fast code in alone
 587         -- (We never have slow code without an info table)
 588     absC (
 589       if info_table_needed then
 590         CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
 591                         stdUpd (cl_descr mod_name)
 592                         (dataConLiveness isw_chkr closure_info)
 593       else
 594         CCodeBlock fast_label fast_abs_c
 595     )
 596   where
 597     lf_info = closureLFInfo closure_info
 598
 599     cl_descr mod_name = closureDescription mod_name id all_args body
 600
 601         -- Figure out what is needed and what isn't
 602     slow_code_needed   = slowFunEntryCodeRequired id binder_info
 603     info_table_needed  = funInfoTableRequired id binder_info lf_info
 604
 605         -- Manufacture labels
 606     id         = closureId closure_info
 607
 608     fast_label = fastLabelFromCI closure_info
 609
 610     stdUpd = CLbl mkErrorStdEntryLabel CodePtrKind
 611
 612     wrapper_maybe = get_ultimate_wrapper Nothing id
 613       where
 614         get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
 615           = case (myWrapperMaybe x) of
 616               Nothing -> deflt
 617               Just xx -> get_ultimate_wrapper (Just xx) xx
 618
 619     show_wrapper_name Nothing   = ""
 620     show_wrapper_name (Just xx) = showId PprDebug xx
 621
 622     show_wrapper_arg_kinds Nothing   = ""
 623     show_wrapper_arg_kinds (Just xx)
 624       = case (getWrapperArgTypeCategories (getIdUniType xx) (getIdStrictness xx)) of
 625           Nothing  -> ""
 626           Just str -> str
 627 \end{code}
 628
 629 For lexically scoped profiling we have to load the cost centre from
 630 the closure entered, if the costs are not supposed to be inherited.
 631 This is done immediately on entering the fast entry point.
 632
 633 Load current cost centre from closure, if not inherited.
 634 Node is guaranteed to point to it, if profiling and not inherited.
 635
 636 \begin{code}
 637 data IsThunk = IsThunk | IsFunction -- Bool-like, local
 638
 639 enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
 640
 641 enterCostCentreCode closure_info cc is_thunk
 642   = costCentresFlag     `thenFC` \ profiling_on ->
 643     if not profiling_on then
 644         nopC
 645     else -- down to business
 646         ASSERT(not (noCostCentreAttached cc))
 647
 648         if costsAreSubsumed cc then
 649             nopC
 650
 651         else if is_current_CC cc then -- fish the CC out of the closure,
 652                                       -- where we put it when we alloc'd;
 653                                       -- NB: chk defn of "is_current_CC"
 654                                       -- if you go to change this! (WDP 94/12)
 655             costCentresC
 656                 (case is_thunk of
 657                    IsThunk    -> SLIT("ENTER_CC_TCL")
 658                    IsFunction -> SLIT("ENTER_CC_FCL"))
 659                 [CReg node]
 660
 661         else if isCafCC cc then
 662             costCentresC
 663                 SLIT("ENTER_CC_CAF")
 664                 [mkCCostCentre cc]
 665
 666         else -- we've got a "real" cost centre right here in our hands...
 667             costCentresC
 668                 (case is_thunk of
 669                    IsThunk    -> SLIT("ENTER_CC_T")
 670                    IsFunction -> SLIT("ENTER_CC_F"))
 671                 [mkCCostCentre cc]
 672   where
 673     is_current_CC cc
 674       = currentOrSubsumedCosts cc
 675         -- but we've already ruled out "subsumed", so it must be "current"!
 676 \end{code}
 677
 678 %************************************************************************
 679 %*                                                                      *
 680 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
 681 %*                                                                      *
 682 %************************************************************************
 683
 684 The argument-satisfaction check code is placed after binding
 685 the arguments to their stack locations. Hence, the virtual stack
 686 pointer is pointing after all the args, and virtual offset 1 means
 687 the base of frame and hence most distant arg.  Hence
 688 virtual offset 0 is just beyond the most distant argument; the
 689 relative offset of this word tells how many words of arguments
 690 are expected.
 691
 692 \begin{code}
 693 argSatisfactionCheck :: ClosureInfo -> [Id] -> Code
 694
 695 argSatisfactionCheck closure_info [] = nopC
 696
 697 argSatisfactionCheck closure_info args
 698   = -- safest way to determine which stack last arg will be on:
 699     -- look up CAddrMode that last arg is bound to;
 700     -- getAmodeKind;
 701     -- check isFollowableKind.
 702
 703     nodeMustPointToIt (closureLFInfo closure_info)      `thenFC` \ node_points ->
 704
 705 #ifdef GRAN
 706     -- HWL:
 707     -- absC (CMacroStmt GRAN_FETCH [])                  `thenC`
 708     -- forceHeapCheck [] node_points (absC AbsCNop)     `thenC`
 709     (if node_points
 710         then fetchAndReschedule  [] node_points
 711         else absC AbsCNop)                              `thenC`
 712 #endif  {- GRAN -}
 713
 714     getCAddrMode (last args)                            `thenFC` \ last_amode ->
 715
 716     if (isFollowableKind (getAmodeKind last_amode)) then
 717         getSpARelOffset 0       `thenFC` \ a_rel_offset ->
 718         if node_points then
 719             absC (CMacroStmt ARGS_CHK_A [mkIntCLit (spARelToInt a_rel_offset)])
 720         else
 721             absC (CMacroStmt ARGS_CHK_A_LOAD_NODE
 722                                 [mkIntCLit (spARelToInt a_rel_offset), set_Node_to_this])
 723     else
 724         getSpBRelOffset 0       `thenFC` \ b_rel_offset ->
 725         if node_points then
 726             absC (CMacroStmt ARGS_CHK_B [mkIntCLit (spBRelToInt b_rel_offset)])
 727         else
 728             absC (CMacroStmt ARGS_CHK_B_LOAD_NODE
 729                                 [mkIntCLit (spBRelToInt b_rel_offset), set_Node_to_this])
 730   where
 731     -- We must tell the arg-satis macro whether Node is pointing to
 732     -- the closure or not.  If it isn't so pointing, then we give to
 733     -- the macro the (static) address of the closure.
 734
 735     set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrKind
 736 \end{code}
 737
 738 %************************************************************************
 739 %*                                                                      *
 740 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
 741 %*                                                                      *
 742 %************************************************************************
 743
 744 \begin{code}
 745 thunkWrapper:: ClosureInfo -> Code -> Code
 746 thunkWrapper closure_info thunk_code
 747   =     -- Stack and heap overflow checks
 748     nodeMustPointToIt (closureLFInfo closure_info)      `thenFC` \ node_points ->
 749
 750 #ifdef GRAN
 751     -- HWL insert macros for GrAnSim if node is live here
 752     (if node_points
 753        then fetchAndReschedule [] node_points
 754        else absC AbsCNop)                               `thenC`
 755 #endif  {- GRAN -}
 756
 757     stackCheck closure_info [] node_points (    -- stackCheck *encloses* the rest
 758
 759     -- Must be after stackCheck: if stchk fails new stack
 760     -- space has to be allocated from the heap
 761
 762     heapCheck [] node_points (
 763                                         -- heapCheck *encloses* the rest
 764         -- The "[]" says there are no live argument registers
 765
 766         -- Overwrite with black hole if necessary
 767     blackHoleIt closure_info                            `thenC`
 768
 769         -- Push update frame if necessary
 770     setupUpdate closure_info (          -- setupUpdate *encloses* the rest
 771
 772         -- Evaluation scoping -- load current cost centre from closure
 773         -- Must be done after the update frame is pushed
 774         -- Node is guaranteed to point to it, if profiling
 775 -- OLD:
 776 --  (if isStaticClosure closure_info
 777 --   then evalCostCentreC "SET_CAFCC_CL" [CReg node]
 778 --   else evalCostCentreC "ENTER_CC_TCL"  [CReg node])  `thenC`
 779
 780         -- Finally, do the business
 781     thunk_code
 782     )))
 783
 784 funWrapper :: ClosureInfo       -- Closure whose code body this is
 785            -> [MagicId]         -- List of argument registers (if any)
 786            -> Code              -- Body of function being compiled
 787            -> Code
 788 funWrapper closure_info arg_regs fun_body
 789   =     -- Stack overflow check
 790     nodeMustPointToIt (closureLFInfo closure_info)      `thenFC` \ node_points ->
 791     stackCheck closure_info arg_regs node_points (      -- stackCheck *encloses* the rest
 792
 793         -- Heap overflow check
 794     heapCheck arg_regs node_points (
 795                                         -- heapCheck *encloses* the rest
 796
 797         -- Finally, do the business
 798     fun_body
 799     ))
 800 \end{code}
 801
 802 %************************************************************************
 803 %*                                                                      *
 804 \subsubsubsection[overflow-checks]{Stack and heap overflow wrappers}
 805 %*                                                                      *
 806 %************************************************************************
 807
 808 Assumption: virtual and real stack pointers are currently exactly aligned.
 809
 810 \begin{code}
 811 stackCheck :: ClosureInfo
 812            -> [MagicId]                 -- Live registers
 813            -> Bool                      -- Node required to point after check?
 814            -> Code
 815            -> Code
 816
 817 stackCheck closure_info regs node_reqd code
 818   = getFinalStackHW (\ aHw -> \ bHw ->  -- Both virtual stack offsets
 819
 820     getVirtSps          `thenFC` \ (vSpA, vSpB) ->
 821
 822     let a_headroom_reqd = aHw - vSpA    -- Virtual offsets are positive integers
 823         b_headroom_reqd = bHw - vSpB
 824     in
 825
 826     absC (if (a_headroom_reqd == 0 && b_headroom_reqd == 0) then
 827                 AbsCNop
 828           else
 829                 CMacroStmt STK_CHK [mkIntCLit liveness_mask,
 830                                     mkIntCLit a_headroom_reqd,
 831                                     mkIntCLit b_headroom_reqd,
 832                                     mkIntCLit vSpA,
 833                                     mkIntCLit vSpB,
 834                                     mkIntCLit (if returns_prim_type then 1 else 0),
 835                                     mkIntCLit (if node_reqd         then 1 else 0)]
 836          )
 837         -- The test is *inside* the absC, to avoid black holes!
 838
 839     `thenC` code
 840     )
 841   where
 842     all_regs = if node_reqd then node:regs else regs
 843     liveness_mask = mkLiveRegsBitMask all_regs
 844
 845     returns_prim_type = closureReturnsUnboxedType closure_info
 846 \end{code}
 847
 848 %************************************************************************
 849 %*                                                                      *
 850 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
 851 %*                                                                      *
 852 %************************************************************************
 853
 854
 855 \begin{code}
 856 blackHoleIt :: ClosureInfo -> Code      -- Only called for thunks
 857 blackHoleIt closure_info
 858   = noBlackHolingFlag   `thenFC` \ no_black_holing ->
 859
 860     if (blackHoleOnEntry no_black_holing closure_info)
 861     then
 862         absC (if closureSingleEntry(closure_info) then
 863                 CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
 864               else
 865                 CMacroStmt UPD_BH_UPDATABLE [CReg node])
 866         -- Node always points to it; see stg-details
 867     else
 868         nopC
 869 \end{code}
 870
 871 \begin{code}
 872 setupUpdate :: ClosureInfo -> Code -> Code      -- Only called for thunks
 873         -- Nota Bene: this function does not change Node (even if it's a CAF),
 874         -- so that the cost centre in the original closure can still be
 875         -- extracted by a subsequent ENTER_CC_TCL
 876
 877 setupUpdate closure_info code
 878  = if (closureUpdReqd closure_info) then
 879         link_caf_if_needed      `thenFC` \ update_closure ->
 880         getIntSwitchChkrC       `thenFC` \ isw_chkr ->
 881         pushUpdateFrame update_closure (vector isw_chkr) code
 882    else
 883         -- Non-updatable thunks still need a resume-cost-centre "update"
 884         -- frame to be pushed if we are doing evaluation profiling.
 885
 886 --OLD:  evalPushRCCFrame False {-never primitive-} (
 887         profCtrC SLIT("UPDF_OMITTED") []
 888                                                 `thenC`
 889         code
 890 --      )
 891  where
 892    link_caf_if_needed :: FCode CAddrMode        -- Returns amode for closure to be updated
 893    link_caf_if_needed
 894      = if not (isStaticClosure closure_info) then
 895           returnFC (CReg node)
 896        else
 897
 898           -- First we must allocate a black hole, and link the
 899           -- CAF onto the CAF list
 900
 901                 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
 902                 --   Hack Warning: Using a CLitLit to get CAddrMode !
 903           let
 904               use_cc   = CLitLit SLIT("CC_HDR(R1.p)") PtrKind
 905               blame_cc = use_cc
 906           in
 907           allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
 908                                                         `thenFC` \ heap_offset ->
 909           getHpRelOffset heap_offset                    `thenFC` \ hp_rel ->
 910           let  amode = CAddr hp_rel
 911           in
 912           absC (CMacroStmt UPD_CAF [CReg node, amode])
 913                                                         `thenC`
 914           returnFC amode
 915
 916    closure_label = mkClosureLabel (closureId closure_info)
 917
 918    vector isw_chkr
 919      = case (closureType closure_info) of
 920         Nothing -> CReg StdUpdRetVecReg
 921         Just (spec_tycon, _, spec_datacons) ->
 922             case (ctrlReturnConvAlg spec_tycon) of
 923               UnvectoredReturn 1 ->
 924                 let
 925                     spec_data_con = head spec_datacons
 926                     only_tag = getDataConTag spec_data_con
 927
 928                     direct = case (dataReturnConvAlg isw_chkr spec_data_con) of
 929                         ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
 930                         ReturnInHeap   -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
 931
 932                     vectored = mkStdUpdVecTblLabel spec_tycon
 933                 in
 934                     CUnVecLbl direct vectored
 935
 936               UnvectoredReturn _ -> CReg StdUpdRetVecReg
 937               VectoredReturn _   -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrKind
 938 \end{code}
 939
 940 %************************************************************************
 941 %*                                                                      *
 942 \subsection[CgClosure-Description]{Profiling Closure Description.}
 943 %*                                                                      *
 944 %************************************************************************
 945
 946 For "global" data constructors the description is simply occurrence
 947 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
 948
 949 Otherwise it is determind by @closureDescription@ from the let
 950 binding information.
 951
 952 \begin{code}
 953 closureDescription :: FAST_STRING       -- Module
 954                    -> Id                -- Id of closure binding
 955                    -> [Id]              -- Args
 956                    -> PlainStgExpr      -- Body
 957                    -> String
 958
 959         -- Not called for StgRhsCon which have global info tables built in
 960         -- CgConTbls.lhs with a description generated from the data constructor
 961
 962 closureDescription mod_name name args body =
 963     uppShow 0 (prettyToUn (
 964         ppBesides [ppChar '<',
 965                    ppPStr mod_name,
 966                    ppChar '.',
 967                    ppr PprDebug name,
 968                    ppChar '>']))
 969 \end{code}
 970
 971 \begin{code}
 972 chooseDynCostCentres cc args fvs body
 973   = let
 974         use_cc -- cost-centre we record in the object
 975           = if currentOrSubsumedCosts cc
 976             then CReg CurCostCentre
 977             else mkCCostCentre cc
 978
 979         blame_cc -- cost-centre on whom we blame the allocation
 980           = case (args, fvs, body) of
 981               ([], [just1], StgApp (StgVarAtom fun) [{-no args-}] _)
 982                 | just1 == fun
 983                 -> mkCCostCentre overheadCostCentre
 984               _ -> use_cc
 985             -- if it's an utterly trivial RHS, then it must be
 986             -- one introduced by boxHigherOrderArgs for profiling,
 987             -- so we charge it to "OVERHEAD".
 988     in
 989     (use_cc, blame_cc)
 990 \end{code}