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