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