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