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