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