ghc/compiler/profiling/SCCfinal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[SCCfinal]{Modify and collect code generation for final StgProgram}
   5
   6 This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.
   7
   8 * Traverses the STG program collecting the cost centres. These are
   9   required to declare the cost centres at the start of code
  10   generation.
  11
  12   Note: because of cross-module unfolding, some of these cost centres
  13   may be from other modules.  But will still have to give them
  14   "extern" declarations.
  15
  16 * Puts on CAF cost-centres if the user has asked for individual CAF
  17   cost-centres.
  18
  19 * Ditto for individual DICT cost-centres.
  20
  21 * Boxes top-level inherited functions passed as arguments.
  22
  23 * "Distributes" given cost-centres to all as-yet-unmarked RHSs.
  24
  25 \begin{code}
  26 #include "HsVersions.h"
  27
  28 module SCCfinal ( stgMassageForProfiling ) where
  29
  30 import Pretty           -- ToDo: rm (debugging only)
  31
  32 import AbsUniType       ( isDictTy, getUniDataTyCon_maybe,
  33                           isTupleTyCon, isFunType, getTauType,
  34                           splitType -- pragmas
  35                         )
  36 import CmdLineOpts
  37 import CostCentre
  38 import Id               ( mkSysLocal, getIdUniType )
  39 import SrcLoc           ( mkUnknownSrcLoc )
  40 import StgSyn
  41 import SplitUniq
  42 import UniqSet          ( emptyUniqSet
  43                           IF_ATTACK_PRAGMAS(COMMA emptyUFM)
  44                         )
  45 import Unique
  46 import Util
  47
  48 infixr 9 `thenMM`, `thenMM_`
  49 \end{code}
  50
  51 \begin{code}
  52 type CollectedCCs = ([CostCentre],          -- locally defined ones
  53                      [CostCentre])          -- ones needing "extern" decls
  54
  55 stgMassageForProfiling
  56         :: FAST_STRING -> FAST_STRING       -- module name, group name
  57         -> SplitUniqSupply                  -- unique supply
  58         -> (GlobalSwitch -> Bool)           -- command-line opts checker
  59         -> [PlainStgBinding]                -- input
  60         -> (CollectedCCs, [PlainStgBinding])
  61
  62 stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
  63   = let
  64         ((local_ccs, extern_ccs),
  65          stg_binds2)
  66           = initMM mod_name us (mapMM do_top_binding stg_binds)
  67
  68         fixed_ccs
  69           = if do_auto_sccs_on_cafs || doing_prelude
  70             then [] -- don't need "all CAFs" CC (for Prelude, we use PreludeCC)
  71             else [all_cafs_cc]
  72
  73         local_ccs_no_dups  = fst (removeDups cmpCostCentre local_ccs)
  74         extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)
  75     in
  76     ((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2)
  77   where
  78     do_auto_sccs_on_cafs  = sw_chkr AutoSccsOnIndividualCafs  -- only use!
  79 --UNUSED:    do_auto_sccs_on_dicts = sw_chkr AutoSccsOnIndividualDicts -- only use! ** UNUSED really **
  80     doing_prelude         = sw_chkr CompilingPrelude
  81
  82     all_cafs_cc = if doing_prelude
  83                   then preludeCafsCostCentre
  84                   else mkAllCafsCC mod_name grp_name
  85
  86     ----------
  87     do_top_binding :: PlainStgBinding -> MassageM PlainStgBinding
  88
  89     do_top_binding (StgNonRec b rhs)
  90       = do_top_rhs b rhs                `thenMM` \ rhs' ->
  91         returnMM (StgNonRec b rhs')
  92
  93     do_top_binding (StgRec pairs)
  94       = mapMM do_pair pairs             `thenMM` \ pairs2 ->
  95         returnMM (StgRec pairs2)
  96       where
  97         do_pair (b, rhs)
  98            = do_top_rhs b rhs   `thenMM` \ rhs2 ->
  99              returnMM (b, rhs2)
 100
 101     ----------
 102     do_top_rhs :: Id -> PlainStgRhs -> MassageM PlainStgRhs
 103
 104     do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc (StgConApp con args lvs)))
 105         -- top-level _scc_ around nothing but static data; toss it -- it's pointless
 106       = returnMM (StgRhsCon dontCareCostCentre con args)
 107
 108     do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc expr))
 109 -- OLD:
 110 --    | noCostCentreAttached rhs_cc || currentOrSubsumedCosts rhs_cc
 111 --      -- doubtful guard... ToDo?
 112         -- Top level CAF with explicit scc expression.  Attach CAF
 113         -- cost centre to StgRhsClosure and collect.
 114       = let
 115            calved_cc = cafifyCC cc
 116         in
 117         collectCC calved_cc     `thenMM_`
 118         set_prevailing_cc calved_cc (
 119             do_expr expr
 120         )                       `thenMM`  \ expr' ->
 121         returnMM (StgRhsClosure calved_cc bi fv u [] expr')
 122
 123     do_top_rhs binder (StgRhsClosure cc bi fv u [] body)
 124       | noCostCentreAttached cc || currentOrSubsumedCosts cc
 125         -- Top level CAF without a cost centre attached: Collect
 126         -- cost centre with binder name, if collecting CAFs.
 127       = let
 128             (did_something, cc2)
 129               = if do_auto_sccs_on_cafs then
 130                    (True, mkAutoCC binder mod_name grp_name IsCafCC)
 131                 else
 132                    (False, all_cafs_cc)
 133         in
 134         (if did_something
 135          then collectCC cc2
 136          else nopMM)            `thenMM_`
 137         set_prevailing_cc cc2 (
 138             do_expr body
 139         )                       `thenMM`  \body2 ->
 140         returnMM (StgRhsClosure cc2 bi fv u [] body2)
 141
 142     do_top_rhs binder (StgRhsClosure _ bi fv u args body@(StgSCC ty cc expr))
 143         -- We blindly use the cc off the _scc_
 144       = set_prevailing_cc cc (
 145             do_expr body
 146         )               `thenMM` \ body2 ->
 147         returnMM (StgRhsClosure cc bi fv u args body2)
 148
 149     do_top_rhs binder (StgRhsClosure cc bi fv u args body)
 150       = let
 151             cc2 = if noCostCentreAttached cc
 152                   then subsumedCosts -- it's not a thunk; it is top-level & arity > 0
 153                   else cc
 154         in
 155         set_prevailing_cc cc2 (
 156             do_expr body
 157         )               `thenMM` \ body' ->
 158         returnMM (StgRhsClosure cc2 bi fv u args body')
 159
 160     do_top_rhs binder (StgRhsCon cc con args)
 161       = returnMM (StgRhsCon dontCareCostCentre con args)
 162         -- Top-level (static) data is not counted in heap
 163         -- profiles; nor do we set CCC from it; so we
 164         -- just slam in dontCareCostCentre
 165
 166     ------
 167     do_expr :: PlainStgExpr -> MassageM PlainStgExpr
 168
 169     do_expr (StgApp fn args lvs)
 170       = boxHigherOrderArgs (StgApp fn) args lvs
 171
 172     do_expr (StgConApp con args lvs)
 173       = boxHigherOrderArgs (StgConApp con) args lvs
 174
 175     do_expr (StgPrimApp op args lvs)
 176       = boxHigherOrderArgs (StgPrimApp op) args lvs
 177
 178     do_expr (StgSCC ty cc expr) -- Ha, we found a cost centre!
 179       = collectCC cc            `thenMM_`
 180         set_prevailing_cc cc (
 181             do_expr expr
 182         )                       `thenMM`  \ expr' ->
 183         returnMM (StgSCC ty cc expr')
 184
 185     do_expr (StgCase expr fv1 fv2 uniq alts)
 186       = do_expr expr            `thenMM` \ expr' ->
 187         do_alts alts            `thenMM` \ alts' ->
 188         returnMM (StgCase expr' fv1 fv2 uniq alts')
 189       where
 190         do_alts (StgAlgAlts ty alts def)
 191           = mapMM do_alt alts   `thenMM` \ alts' ->
 192             do_deflt def        `thenMM` \ def' ->
 193             returnMM (StgAlgAlts ty alts' def')
 194           where
 195             do_alt (id, bs, use_mask, e)
 196               = do_expr e `thenMM` \ e' ->
 197                 returnMM (id, bs, use_mask, e')
 198
 199         do_alts (StgPrimAlts ty alts def)
 200           = mapMM do_alt alts   `thenMM` \ alts' ->
 201             do_deflt def        `thenMM` \ def' ->
 202             returnMM (StgPrimAlts ty alts' def')
 203           where
 204             do_alt (l,e)
 205               = do_expr e `thenMM` \ e' ->
 206                 returnMM (l,e')
 207
 208         do_deflt StgNoDefault = returnMM StgNoDefault
 209         do_deflt (StgBindDefault b is_used e)
 210           = do_expr e                   `thenMM` \ e' ->
 211             returnMM (StgBindDefault b is_used e')
 212
 213     do_expr (StgLet b e)
 214       = set_prevailing_cc_maybe useCurrentCostCentre (
 215         do_binding b            `thenMM` \ b' ->
 216         do_expr e               `thenMM` \ e' ->
 217         returnMM (StgLet b' e') )
 218
 219     do_expr (StgLetNoEscape lvs1 lvs2 rhs body)
 220       = set_prevailing_cc_maybe useCurrentCostCentre (
 221         do_binding rhs          `thenMM` \ rhs' ->
 222         do_expr body            `thenMM` \ body' ->
 223         returnMM (StgLetNoEscape lvs1 lvs2 rhs' body') )
 224
 225     ----------
 226     do_binding :: PlainStgBinding -> MassageM PlainStgBinding
 227
 228     do_binding (StgNonRec b rhs)
 229       = do_rhs rhs                      `thenMM` \ rhs' ->
 230         returnMM (StgNonRec b rhs')
 231
 232     do_binding (StgRec pairs)
 233       = mapMM do_pair pairs `thenMM` \ new_pairs ->
 234         returnMM (StgRec new_pairs)
 235       where
 236         do_pair (b, rhs)
 237           = do_rhs rhs  `thenMM` \ rhs' ->
 238             returnMM (b, rhs')
 239
 240     do_rhs :: PlainStgRhs -> MassageM PlainStgRhs
 241         -- We play much the same game as we did in do_top_rhs above;
 242         -- but we don't have to worry about cafifying, etc.
 243         -- (ToDo: consolidate??)
 244
 245 {- Patrick says NO: it will mess up our counts (WDP 95/07)
 246     do_rhs (StgRhsClosure _ bi fv u [] (StgSCC _ cc (StgConApp con args lvs)))
 247       = collectCC cc `thenMM_`
 248         returnMM (StgRhsCon cc con args)
 249 -}
 250
 251     do_rhs (StgRhsClosure _ bi fv u args body@(StgSCC _ cc _))
 252       = set_prevailing_cc cc (
 253             do_expr body
 254         )                           `thenMM` \ body' ->
 255         returnMM (StgRhsClosure cc bi fv u args body')
 256
 257     do_rhs (StgRhsClosure cc bi fv u args body)
 258       = use_prevailing_cc_maybe cc  `thenMM` \ cc2 ->
 259         set_prevailing_cc cc2 (
 260             do_expr body
 261         )                           `thenMM` \ body' ->
 262         returnMM (StgRhsClosure cc2 bi fv u args body')
 263
 264     do_rhs (StgRhsCon cc con args)
 265       = use_prevailing_cc_maybe cc  `thenMM` \ cc2 ->
 266         returnMM (StgRhsCon cc2 con args)
 267       -- ToDo: Box args (if lex) Pass back let binding???
 268       -- Nope: maybe later? WDP 94/06
 269 \end{code}
 270
 271 %************************************************************************
 272 %*                                                                      *
 273 \subsection{Boxing higher-order args}
 274 %*                                                                      *
 275 %************************************************************************
 276
 277 \begin{code}
 278 boxHigherOrderArgs
 279     :: ([PlainStgAtom] -> PlainStgLiveVars -> PlainStgExpr)
 280         -- An application lacking its arguments and live-var info
 281     -> [PlainStgAtom]   -- arguments which we might box
 282     -> PlainStgLiveVars -- live var info, which we do *not* try
 283                         -- to maintain/update (setStgVarInfo will
 284                         -- do that)
 285     -> MassageM PlainStgExpr
 286
 287 boxHigherOrderArgs almost_expr args live_vars
 288   = mapAccumMM do_arg [] args   `thenMM` \ (let_bindings, new_args) ->
 289     get_prevailing_cc           `thenMM` \ cc ->
 290     returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings)
 291   where
 292     ---------------
 293     do_arg bindings atom@(StgLitAtom _) = returnMM (bindings, atom)
 294
 295     do_arg bindings atom@(StgVarAtom old_var)
 296       = let
 297             var_type = getIdUniType old_var
 298         in
 299         if not (is_fun_type var_type) then
 300             returnMM (bindings, atom) -- easy
 301         else
 302             -- make a trivial let-binding for the higher-order guy
 303             getUniqueMM         `thenMM` \ uniq ->
 304             let
 305                 new_var = mkSysLocal SLIT("ho") uniq var_type mkUnknownSrcLoc
 306             in
 307             returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var )
 308       where
 309         is_fun_type ty = isFunType (getTauType ty)
 310
 311     ---------------
 312     mk_stg_let :: CostCentre -> (Id, Id) -> PlainStgExpr -> PlainStgExpr
 313
 314     mk_stg_let cc (new_var, old_var) body
 315       = let
 316             rhs_body = StgApp (StgVarAtom old_var) [{-no args-}] bOGUS_LVs
 317
 318             rhs = StgRhsClosure cc
 319                         stgArgOcc -- safe...
 320                         [{-junk-}] Updatable [{-no args-}] rhs_body
 321         in
 322         StgLet (StgNonRec new_var rhs) body
 323       where
 324         bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
 325 \end{code}
 326
 327 %************************************************************************
 328 %*                                                                      *
 329 \subsection{Boring monad stuff for this}
 330 %*                                                                      *
 331 %************************************************************************
 332
 333 \begin{code}
 334 type MassageM result
 335   =  FAST_STRING        -- module name
 336   -> CostCentre         -- prevailing CostCentre
 337                         -- if none, subsumedCosts at top-level
 338                         -- useCurrentCostCentre at nested levels
 339   -> SplitUniqSupply
 340   -> CollectedCCs
 341   -> (CollectedCCs, result)
 342
 343 -- the initUs function also returns the final UniqueSupply and CollectedCCs
 344
 345 initMM :: FAST_STRING   -- module name, which we may consult
 346        -> SplitUniqSupply
 347        -> MassageM a
 348        -> (CollectedCCs, a)
 349
 350 initMM mod_name init_us m = m mod_name subsumedCosts{-top-level-} init_us ([],[])
 351
 352 thenMM  :: MassageM a -> (a -> MassageM b) -> MassageM b
 353 thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
 354
 355 thenMM expr cont mod scope_cc us ccs
 356   = case splitUniqSupply us     of { (s1, s2) ->
 357     case (expr mod scope_cc s1 ccs)     of { (ccs2, result) ->
 358     cont result mod scope_cc s2 ccs2 }}
 359
 360 thenMM_ expr cont mod scope_cc us ccs
 361   = case splitUniqSupply us     of { (s1, s2) ->
 362     case (expr mod scope_cc s1 ccs)     of { (ccs2, _) ->
 363     cont mod scope_cc s2 ccs2 }}
 364
 365 returnMM :: a -> MassageM a
 366 returnMM result mod scope_cc us ccs = (ccs, result)
 367
 368 nopMM :: MassageM ()
 369 nopMM mod scope_cc us ccs = (ccs, ())
 370
 371 mapMM :: (a -> MassageM b) -> [a] -> MassageM [b]
 372
 373 mapMM f [] = returnMM []
 374 mapMM f (m:ms)
 375   = f m         `thenMM` \ r  ->
 376     mapMM f ms  `thenMM` \ rs ->
 377     returnMM (r:rs)
 378
 379 mapAccumMM :: (acc -> x -> MassageM (acc, y)) -> acc -> [x] -> MassageM (acc, [y])
 380
 381 mapAccumMM f b [] = returnMM (b, [])
 382 mapAccumMM f b (m:ms)
 383   = f b m               `thenMM` \ (b2, r)  ->
 384     mapAccumMM f b2 ms  `thenMM` \ (b3, rs) ->
 385     returnMM (b3, r:rs)
 386
 387 getUniqueMM :: MassageM Unique
 388 getUniqueMM mod scope_cc us ccs = (ccs, getSUnique us)
 389 \end{code}
 390
 391 \begin{code}
 392 set_prevailing_cc, set_prevailing_cc_maybe
 393         :: CostCentre -> MassageM a -> MassageM a
 394
 395 set_prevailing_cc cc_to_set_to action mod scope_cc us ccs
 396   = action mod cc_to_set_to us ccs
 397     -- set unconditionally
 398
 399 set_prevailing_cc_maybe cc_to_set_to action mod scope_cc us ccs
 400   = let
 401         -- used when switching from top-level to nested
 402         -- scope; if we were chugging along as "subsumed",
 403         -- we change to the new thing; otherwise we
 404         -- keep what we had.
 405
 406         cc_to_use
 407           = if (costsAreSubsumed scope_cc)
 408             then cc_to_set_to
 409             else scope_cc   -- carry on as before
 410     in
 411     action mod cc_to_use us ccs
 412
 413 get_prevailing_cc :: MassageM CostCentre
 414 get_prevailing_cc mod scope_cc us ccs = (ccs, scope_cc)
 415
 416 use_prevailing_cc_maybe :: CostCentre -> MassageM CostCentre
 417
 418 use_prevailing_cc_maybe cc_to_try mod scope_cc us ccs
 419   = let
 420         cc_to_use
 421           = if not (noCostCentreAttached   cc_to_try
 422                  || currentOrSubsumedCosts cc_to_try) then
 423                 cc_to_try
 424             else
 425                 uncalved_scope_cc
 426                 -- carry on as before, but be sure it
 427                 -- isn't marked as CAFish (we're
 428                 -- crossing a lambda...)
 429     in
 430     (ccs, cc_to_use)
 431   where
 432     uncalved_scope_cc = unCafifyCC scope_cc
 433 \end{code}
 434
 435 \begin{code}
 436 collectCC :: CostCentre -> MassageM ()
 437
 438 collectCC cc mod_name scope_cc us (local_ccs, extern_ccs)
 439   = ASSERT(not (noCostCentreAttached cc))
 440     ASSERT(not (currentOrSubsumedCosts cc))
 441     if (cc `ccFromThisModule` mod_name) then
 442         ((cc : local_ccs, extern_ccs), ())
 443     else -- must declare it "extern"
 444         ((local_ccs, cc : extern_ccs), ())
 445 \end{code}