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