compiler/profiling/SCCfinal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   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 module SCCfinal ( stgMassageForProfiling ) where
  27
  28 #include "HsVersions.h"
  29
  30 import StgSyn
  31
  32 import PackageConfig    ( PackageId )
  33 import StaticFlags      ( opt_AutoSccsOnIndividualCafs )
  34 import CostCentre       -- lots of things
  35 import Id
  36 import Name
  37 import Module           ( Module )
  38 import UniqSupply       ( splitUniqSupply, UniqSupply )
  39 #ifdef PROF_DO_BOXING
  40 import UniqSupply       ( uniqFromSupply )
  41 #endif
  42 import Unique           ( Unique )
  43 import VarSet
  44 import ListSetOps       ( removeDups )
  45 import Outputable
  46
  47 infixr 9 `thenMM`, `thenMM_`
  48 \end{code}
  49
  50 \begin{code}
  51 stgMassageForProfiling
  52         :: PackageId
  53         -> Module                       -- module name
  54         -> UniqSupply                   -- unique supply
  55         -> [StgBinding]                 -- input
  56         -> (CollectedCCs, [StgBinding])
  57
  58 stgMassageForProfiling this_pkg mod_name us stg_binds
  59   = let
  60         ((local_ccs, extern_ccs, cc_stacks),
  61          stg_binds2)
  62           = initMM mod_name us (do_top_bindings stg_binds)
  63
  64         (fixed_ccs, fixed_cc_stacks)
  65           = if opt_AutoSccsOnIndividualCafs
  66             then ([],[])  -- don't need "all CAFs" CC
  67                           -- (for Prelude, we use PreludeCC)
  68             else ([all_cafs_cc], [all_cafs_ccs])
  69
  70         local_ccs_no_dups  = fst (removeDups cmpCostCentre local_ccs)
  71         extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)
  72     in
  73     ((fixed_ccs ++ local_ccs_no_dups,
  74       extern_ccs_no_dups,
  75       fixed_cc_stacks ++ cc_stacks), stg_binds2)
  76   where
  77
  78     all_cafs_cc  = mkAllCafsCC mod_name
  79     all_cafs_ccs = mkSingletonCCS all_cafs_cc
  80
  81     ----------
  82     do_top_bindings :: [StgBinding] -> MassageM [StgBinding]
  83
  84     do_top_bindings [] = returnMM []
  85
  86     do_top_bindings (StgNonRec b rhs : bs)
  87       = do_top_rhs b rhs                `thenMM` \ rhs' ->
  88         addTopLevelIshId b (
  89            do_top_bindings bs `thenMM` \bs' ->
  90            returnMM (StgNonRec b rhs' : bs')
  91         )
  92
  93     do_top_bindings (StgRec pairs : bs)
  94       = addTopLevelIshIds binders (
  95            mapMM do_pair pairs          `thenMM` \ pairs2 ->
  96            do_top_bindings bs `thenMM` \ bs' ->
  97            returnMM (StgRec pairs2 : bs')
  98         )
  99       where
 100         binders = map fst pairs
 101         do_pair (b, rhs)
 102            = do_top_rhs b rhs   `thenMM` \ rhs2 ->
 103              returnMM (b, rhs2)
 104
 105     ----------
 106     do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
 107
 108     do_top_rhs binder (StgRhsClosure _ bi fv u srt [] (StgSCC cc (StgConApp con args)))
 109       | not (isSccCountCostCentre cc) && not (isDllConApp this_pkg con args)
 110         -- Trivial _scc_ around nothing but static data
 111         -- Eliminate _scc_ ... and turn into StgRhsCon
 112
 113         -- isDllConApp checks for LitLit args too
 114       = returnMM (StgRhsCon dontCareCCS con args)
 115
 116 {- Can't do this one with cost-centre stacks:  --SDM
 117     do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr))
 118       | (noCCSAttached no_cc || currentOrSubsumedCCS no_cc)
 119         && not (isSccCountCostCentre cc)
 120         -- Top level CAF without a cost centre attached
 121         -- Attach and collect cc of trivial _scc_ in body
 122       = collectCC cc                                    `thenMM_`
 123         set_prevailing_cc cc (do_expr expr)             `thenMM`  \ expr' ->
 124         returnMM (StgRhsClosure cc bi fv u [] expr')
 125 -}
 126
 127     do_top_rhs binder (StgRhsClosure no_cc bi fv u srt [] body)
 128       | noCCSAttached no_cc || currentOrSubsumedCCS no_cc
 129         -- Top level CAF without a cost centre attached
 130         -- Attach CAF cc (collect if individual CAF ccs)
 131       = (if opt_AutoSccsOnIndividualCafs
 132                 then let cc = mkAutoCC binder modl CafCC
 133                          ccs = mkSingletonCCS cc
 134                                 -- careful: the binder might be :Main.main,
 135                                 -- which doesn't belong to module mod_name.
 136                                 -- bug #249, tests prof001, prof002
 137                          modl | Just m <- nameModule_maybe (idName binder) = m
 138                               | otherwise = mod_name
 139                      in
 140                      collectCC  cc  `thenMM_`
 141                      collectCCS ccs `thenMM_`
 142                      returnMM ccs
 143                 else
 144                      returnMM all_cafs_ccs)             `thenMM`  \ caf_ccs ->
 145            set_prevailing_cc caf_ccs (do_expr body)     `thenMM`  \ body' ->
 146            returnMM (StgRhsClosure caf_ccs bi fv u srt [] body')
 147
 148     do_top_rhs binder (StgRhsClosure cc bi fv u srt [] body)
 149         -- Top level CAF with cost centre attached
 150         -- Should this be a CAF cc ??? Does this ever occur ???
 151       = pprPanic "SCCfinal: CAF with cc:" (ppr cc)
 152
 153     do_top_rhs binder (StgRhsClosure no_ccs bi fv u srt args body)
 154         -- Top level function, probably subsumed
 155       | noCCSAttached no_ccs
 156       = set_lambda_cc (do_expr body)    `thenMM` \ body' ->
 157         returnMM (StgRhsClosure subsumedCCS bi fv u srt args body')
 158
 159       | otherwise
 160       = pprPanic "SCCfinal: CAF with cc:" (ppr no_ccs)
 161
 162     do_top_rhs binder (StgRhsCon ccs con args)
 163         -- Top-level (static) data is not counted in heap
 164         -- profiles; nor do we set CCCS from it; so we
 165         -- just slam in dontCareCostCentre
 166       = returnMM (StgRhsCon dontCareCCS con args)
 167
 168     ------
 169     do_expr :: StgExpr -> MassageM StgExpr
 170
 171     do_expr (StgLit l) = returnMM (StgLit l)
 172
 173     do_expr (StgApp fn args)
 174       = boxHigherOrderArgs (StgApp fn) args
 175
 176     do_expr (StgConApp con args)
 177       = boxHigherOrderArgs (\args -> StgConApp con args) args
 178
 179     do_expr (StgOpApp con args res_ty)
 180       = boxHigherOrderArgs (\args -> StgOpApp con args res_ty) args
 181
 182     do_expr (StgSCC cc expr)    -- Ha, we found a cost centre!
 183       = collectCC cc            `thenMM_`
 184         do_expr expr            `thenMM` \ expr' ->
 185         returnMM (StgSCC cc expr')
 186
 187     do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts)
 188       = do_expr expr            `thenMM` \ expr' ->
 189         mapMM do_alt alts       `thenMM` \ alts' ->
 190         returnMM (StgCase expr' fv1 fv2 bndr srt alt_type alts')
 191       where
 192         do_alt (id, bs, use_mask, e)
 193           = do_expr e `thenMM` \ e' ->
 194             returnMM (id, bs, use_mask, e')
 195
 196     do_expr (StgLet b e)
 197         = do_let b e `thenMM` \ (b,e) ->
 198           returnMM (StgLet b e)
 199
 200     do_expr (StgLetNoEscape lvs1 lvs2 b e)
 201         = do_let b e `thenMM` \ (b,e) ->
 202           returnMM (StgLetNoEscape lvs1 lvs2 b e)
 203
 204     do_expr (StgTick m n expr)
 205         = do_expr expr `thenMM` \ expr' ->
 206           returnMM (StgTick m n expr')
 207
 208 #ifdef DEBUG
 209     do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
 210 #endif
 211
 212     ----------------------------------
 213
 214     do_let (StgNonRec b rhs) e
 215       = do_rhs rhs                      `thenMM` \ rhs' ->
 216         addTopLevelIshId b (
 217           do_expr e                     `thenMM` \ e' ->
 218           returnMM (StgNonRec b rhs',e')
 219         )
 220
 221     do_let (StgRec pairs) e
 222       = addTopLevelIshIds binders (
 223            mapMM do_pair pairs          `thenMM` \ pairs' ->
 224            do_expr e                    `thenMM` \ e' ->
 225            returnMM (StgRec pairs', e')
 226         )
 227       where
 228         binders = map fst pairs
 229         do_pair (b, rhs)
 230            = do_rhs rhs                 `thenMM` \ rhs2 ->
 231              returnMM (b, rhs2)
 232
 233     ----------------------------------
 234     do_rhs :: StgRhs -> MassageM StgRhs
 235         -- We play much the same game as we did in do_top_rhs above;
 236         -- but we don't have to worry about cafs etc.
 237
 238 {-
 239     do_rhs (StgRhsClosure closure_cc bi fv u [] (StgSCC ty cc (StgCon (DataCon con) args _)))
 240       | not (isSccCountCostCentre cc)
 241       = collectCC cc `thenMM_`
 242         returnMM (StgRhsCon cc con args)
 243 -}
 244
 245     do_rhs (StgRhsClosure _ bi fv u srt args expr)
 246       = slurpSCCs currentCCS expr       `thenMM` \ (expr', ccs) ->
 247         do_expr expr'                   `thenMM` \ expr'' ->
 248         returnMM (StgRhsClosure ccs bi fv u srt args expr'')
 249       where
 250         slurpSCCs ccs (StgSCC cc e)
 251              = collectCC cc                     `thenMM_`
 252                slurpSCCs (cc `pushCCOnCCS` ccs) e
 253         slurpSCCs ccs e
 254              = returnMM (e, ccs)
 255
 256     do_rhs (StgRhsCon cc con args)
 257       = returnMM (StgRhsCon currentCCS con args)
 258 \end{code}
 259
 260 %************************************************************************
 261 %*                                                                      *
 262 \subsection{Boxing higher-order args}
 263 %*                                                                      *
 264 %************************************************************************
 265
 266 Boxing is *turned off* at the moment, until we can figure out how to
 267 do it properly in general.
 268
 269 \begin{code}
 270 boxHigherOrderArgs
 271     :: ([StgArg] -> StgExpr)
 272                         -- An application lacking its arguments
 273     -> [StgArg]         -- arguments which we might box
 274     -> MassageM StgExpr
 275
 276 #ifndef PROF_DO_BOXING
 277 boxHigherOrderArgs almost_expr args
 278    = returnMM (almost_expr args)
 279 #else
 280 boxHigherOrderArgs almost_expr args
 281   = getTopLevelIshIds           `thenMM` \ ids ->
 282     mapAccumMM (do_arg ids) [] args     `thenMM` \ (let_bindings, new_args) ->
 283     returnMM (foldr (mk_stg_let currentCCS) (almost_expr new_args) let_bindings)
 284   where
 285     ---------------
 286
 287     do_arg ids bindings arg@(StgVarArg old_var)
 288         |  (not (isLocalVar old_var) || elemVarSet old_var ids)
 289         && isFunTy (dropForAlls var_type)
 290       =     -- make a trivial let-binding for the top-level function
 291         getUniqueMM             `thenMM` \ uniq ->
 292         let
 293             new_var = mkSysLocal FSLIT("sf") uniq var_type
 294         in
 295         returnMM ( (new_var, old_var) : bindings, StgVarArg new_var )
 296       where
 297         var_type = idType old_var
 298
 299     do_arg ids bindings arg = returnMM (bindings, arg)
 300
 301     ---------------
 302     mk_stg_let :: CostCentreStack -> (Id, Id) -> StgExpr -> StgExpr
 303
 304     mk_stg_let cc (new_var, old_var) body
 305       = let
 306             rhs_body    = StgApp old_var [{-args-}]
 307             rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant NoSRT{-eeek!!!-} [{-args-}] rhs_body
 308         in
 309         StgLet (StgNonRec new_var rhs_closure) body
 310       where
 311         bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
 312 #endif
 313 \end{code}
 314
 315 %************************************************************************
 316 %*                                                                      *
 317 \subsection{Boring monad stuff for this}
 318 %*                                                                      *
 319 %************************************************************************
 320
 321 \begin{code}
 322 type MassageM result
 323   =  Module             -- module name
 324   -> CostCentreStack    -- prevailing CostCentre
 325                         -- if none, subsumedCosts at top-level
 326                         -- currentCostCentre at nested levels
 327   -> UniqSupply
 328   -> VarSet             -- toplevel-ish Ids for boxing
 329   -> CollectedCCs
 330   -> (CollectedCCs, result)
 331
 332 -- the initMM function also returns the final CollectedCCs
 333
 334 initMM :: Module        -- module name, which we may consult
 335        -> UniqSupply
 336        -> MassageM a
 337        -> (CollectedCCs, a)
 338
 339 initMM mod_name init_us m = m mod_name noCCS init_us emptyVarSet ([],[],[])
 340
 341 thenMM  :: MassageM a -> (a -> MassageM b) -> MassageM b
 342 thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
 343
 344 thenMM expr cont mod scope_cc us ids ccs
 345   = case splitUniqSupply us     of { (s1, s2) ->
 346     case (expr mod scope_cc s1 ids ccs) of { (ccs2, result) ->
 347     cont result mod scope_cc s2 ids ccs2 }}
 348
 349 thenMM_ expr cont mod scope_cc us ids ccs
 350   = case splitUniqSupply us     of { (s1, s2) ->
 351     case (expr mod scope_cc s1 ids ccs) of { (ccs2, _) ->
 352     cont mod scope_cc s2 ids ccs2 }}
 353
 354 returnMM :: a -> MassageM a
 355 returnMM result mod scope_cc us ids ccs = (ccs, result)
 356
 357 nopMM :: MassageM ()
 358 nopMM mod scope_cc us ids ccs = (ccs, ())
 359
 360 mapMM :: (a -> MassageM b) -> [a] -> MassageM [b]
 361 mapMM f [] = returnMM []
 362 mapMM f (m:ms)
 363   = f m         `thenMM` \ r  ->
 364     mapMM f ms  `thenMM` \ rs ->
 365     returnMM (r:rs)
 366
 367 mapAccumMM :: (acc -> x -> MassageM (acc, y)) -> acc -> [x] -> MassageM (acc, [y])
 368 mapAccumMM f b [] = returnMM (b, [])
 369 mapAccumMM f b (m:ms)
 370   = f b m               `thenMM` \ (b2, r)  ->
 371     mapAccumMM f b2 ms  `thenMM` \ (b3, rs) ->
 372     returnMM (b3, r:rs)
 373
 374 #ifdef PROF_DO_BOXING
 375 getUniqueMM :: MassageM Unique
 376 getUniqueMM mod scope_cc us ids ccs = (ccs, uniqFromSupply us)
 377 #endif
 378
 379 addTopLevelIshId :: Id -> MassageM a -> MassageM a
 380 addTopLevelIshId id scope mod scope_cc us ids ccs
 381   | isCurrentCCS scope_cc = scope mod scope_cc us ids ccs
 382   | otherwise             = scope mod scope_cc us (extendVarSet ids id) ccs
 383
 384 addTopLevelIshIds :: [Id] -> MassageM a -> MassageM a
 385 addTopLevelIshIds [] cont = cont
 386 addTopLevelIshIds (id:ids) cont
 387   = addTopLevelIshId id (addTopLevelIshIds ids cont)
 388
 389 getTopLevelIshIds :: MassageM VarSet
 390 getTopLevelIshIds mod scope_cc us ids ccs = (ccs, ids)
 391 \end{code}
 392
 393 The prevailing CCS is used to tell whether we're in a top-levelish
 394 position, where top-levelish is defined as "not inside a lambda".
 395 Prevailing CCs used to be used for something much more complicated,
 396 I'm sure --SDM
 397
 398 \begin{code}
 399 set_lambda_cc :: MassageM a -> MassageM a
 400 set_lambda_cc action mod scope_cc us ids ccs
 401   = action mod currentCCS us ids ccs
 402
 403 set_prevailing_cc :: CostCentreStack -> MassageM a -> MassageM a
 404 set_prevailing_cc cc_to_set_to action mod scope_cc us ids ccs
 405   = action mod cc_to_set_to us ids ccs
 406
 407 get_prevailing_cc :: MassageM CostCentreStack
 408 get_prevailing_cc mod scope_cc us ids ccs = (ccs, scope_cc)
 409 \end{code}
 410
 411 \begin{code}
 412 collectCC :: CostCentre -> MassageM ()
 413
 414 collectCC cc mod_name scope_cc us ids (local_ccs, extern_ccs, ccss)
 415   = ASSERT(not (noCCAttached cc))
 416     if (cc `ccFromThisModule` mod_name) then
 417         ((cc : local_ccs, extern_ccs, ccss), ())
 418     else -- must declare it "extern"
 419         ((local_ccs, cc : extern_ccs, ccss), ())
 420
 421 collectCCS :: CostCentreStack -> MassageM ()
 422
 423 collectCCS ccs mod_name scope_cc us ids (local_ccs, extern_ccs, ccss)
 424   = ASSERT(not (noCCSAttached ccs))
 425     ((local_ccs, extern_ccs, ccs : ccss), ())
 426 \end{code}