ghc/compiler/codeGen/CgClosure.lhs

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