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